'From MicroSqueak 0.1 (December 17, 2003) [No updates present.] on 1 October 2008 at 7:47:40 pm'! This is a simple ADPCM (adapative delta pulse code modulation) codec. This is a general audio codec that compresses speech, music, or sound effects equally well, and works at any sampling rate (i.e., it contains no frequency-sensitive filters). It compresses 16-bit sample data down to 5, 4, 3, or 2 bits per sample, with lower fidelity and increased noise at the lowest bit rates. Although it does not deliver state-of-the-art compressions, the alorithm is small, simple, and extremely fast, since the encode/decode primitives have been translated into C primitives. This codec will also encode and decode all Flash .swf file compressed sound formats, both mono and stereo. (Note: stereo Flash compression is not yet implemented, but stereo decompression works.) ! !ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 16:24'! nextBits: n "Answer the next n bits of my bit stream as an unsigned integer." | result remaining shift | self inline: true. result _ 0. remaining _ n. [true] whileTrue: [ shift _ remaining - bitPosition. result _ result + (currentByte bitShift: shift). shift > 0 ifTrue: [ "consumed currentByte buffer; fetch next byte" remaining _ remaining - bitPosition. currentByte _ (encodedBytes at: (byteIndex _ byteIndex + 1)). bitPosition _ 8] ifFalse: [ "still some bits left in currentByte buffer" bitPosition _ bitPosition - remaining. "mask out the consumed bits:" currentByte _ currentByte bitAnd: (255 bitShift: (bitPosition - 8)). ^ result]]. ! ! !ADPCMCodec methodsFor: 'bit streaming' stamp: 'jm 3/28/1999 20:21'! nextBits: n put: anInteger "Write the next n bits to my bit stream." | buf bufBits bitsAvailable shift | self inline: true. buf _ anInteger. bufBits _ n. [true] whileTrue: [ bitsAvailable _ 8 - bitPosition. shift _ bitsAvailable - bufBits. "either left or right shift" "append high bits of buf to end of currentByte:" currentByte _ currentByte + (buf bitShift: shift). shift < 0 ifTrue: [ "currentByte buffer filled; output it" encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte. bitPosition _ 0. currentByte _ 0. "clear saved high bits of buf:" buf _ buf bitAnd: (1 bitShift: 0 - shift) - 1. bufBits _ bufBits - bitsAvailable] ifFalse: [ "still some bits available in currentByte buffer" bitPosition _ bitPosition + bufBits. ^ self]]. ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/12/2001 17:57'! bytesPerEncodedFrame "Answer the number of bytes required to hold one frame of compressed sound data." "Note: When used as a normal codec, the frame size is always 8 samples which results in (8 * bitsPerSample) / 8 = bitsPerSample bytes." | bitCount | frameSizeMask = 0 ifTrue: [^ bitsPerSample]. "Following assumes mono:" bitCount _ 16 + 6 + ((self samplesPerFrame - 1) * bitsPerSample). ^ (bitCount + 7) // 8 ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 7/2/1999 13:29'! compressAndDecompress: aSound "Compress and decompress the given sound. Overridden to use same bits per sample for both compressing and decompressing." | compressed decoder | compressed _ self compressSound: aSound. decoder _ self class new initializeForBitsPerSample: bitsPerSample samplesPerFrame: 0. ^ decoder decompressSound: compressed ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:37'! decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." encodedBytes _ srcByteArray. byteIndex _ srcIndex - 1. bitPosition _ 0. currentByte _ 0. samples _ dstSoundBuffer. sampleIndex _ dstIndex - 1. self privateDecodeMono: (frameCount * self samplesPerFrame). ^ Array with: (byteIndex - (srcIndex - 1)) with: (sampleIndex - (dstIndex - 1)) ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 15:28'! encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." samples _ srcSoundBuffer. sampleIndex _ srcIndex - 1. encodedBytes _ dstByteArray. byteIndex _ dstIndex - 1. bitPosition _ 0. currentByte _ 0. self privateEncodeMono: (frameCount * self samplesPerFrame). ^ Array with: frameCount with: (byteIndex - (dstIndex - 1)) ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 12/14/2001 11:21'! reset self resetForMono. ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'! resetForMono "Reset my encoding and decoding state for mono." predicted _ 0. index _ 0. ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/28/1999 20:12'! resetForStereo "Reset my encoding and decoding state for stereo." "keep state as SoundBuffers to allow fast access from primitive" predicted _ SoundBuffer new: 2. index _ SoundBuffer new: 2. ! ! !ADPCMCodec methodsFor: 'codec stuff' stamp: 'jm 3/27/1999 08:34'! samplesPerFrame "Answer the number of sound samples per compression frame." frameSizeMask > 0 ifTrue: [^ frameSizeMask + 1]. ^ 8 "frame size when there are no running headers" ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 06:26'! decode: aByteArray bitsPerSample: bits ^ self decode: aByteArray sampleCount: (aByteArray size * 8) // bits bitsPerSample: bits frameSize: 0 stereo: false ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 15:57'! decode: aByteArray sampleCount: count bitsPerSample: bits frameSize: frameSize stereo: stereoFlag self initializeForBitsPerSample: bits samplesPerFrame: frameSize. encodedBytes _ aByteArray. byteIndex _ 0. bitPosition _ 0. currentByte _ 0. stereoFlag ifTrue: [ self resetForStereo. samples _ SoundBuffer newMonoSampleCount: count. rightSamples _ SoundBuffer newMonoSampleCount: count. sampleIndex _ 0. self privateDecodeStereo: count. ^ Array with: samples with: rightSamples] ifFalse: [ samples _ SoundBuffer newMonoSampleCount: count. sampleIndex _ 0. self privateDecodeMono: count. ^ samples] ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/30/1999 08:56'! decodeFlash: aByteArray sampleCount: sampleCount stereo: stereoFlag | bits | encodedBytes _ aByteArray. byteIndex _ 0. bitPosition _ 0. currentByte _ 0. bits _ 2 + (self nextBits: 2). "bits per sample" self initializeForBitsPerSample: bits samplesPerFrame: 4096. stereoFlag ifTrue: [ self resetForStereo. samples _ SoundBuffer newMonoSampleCount: sampleCount. rightSamples _ SoundBuffer newMonoSampleCount: sampleCount. sampleIndex _ 0. self privateDecodeStereo: sampleCount. ^ Array with: samples with: rightSamples] ifFalse: [ samples _ SoundBuffer newMonoSampleCount: sampleCount. sampleIndex _ 0. self privateDecodeMono: sampleCount. ^ Array with: samples]. ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 08:59'! encode: aSoundBuffer bitsPerSample: bits ^ self encodeLeft: aSoundBuffer right: nil bitsPerSample: bits frameSize: 0 forFlash: false ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 08:58'! encodeFlashLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits ^ self encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: 4096 forFlash: true ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 11/21/2001 11:35'! encodeLeft: leftSoundBuffer right: rightSoundBuffer bitsPerSample: bits frameSize: frameSize forFlash: flashFlag | stereoFlag sampleCount sampleBitCount bitCount | self initializeForBitsPerSample: bits samplesPerFrame: frameSize. stereoFlag _ rightSoundBuffer notNil. sampleCount _ leftSoundBuffer monoSampleCount. stereoFlag ifTrue: [sampleBitCount _ 2 * (sampleCount * bitsPerSample)] ifFalse: [sampleBitCount _ sampleCount * bitsPerSample]. bitCount _ sampleBitCount + (self headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag). encodedBytes _ ByteArray new: ((bitCount / 8) ceiling roundUpTo: self bytesPerEncodedFrame). byteIndex _ 0. bitPosition _ 0. currentByte _ 0. flashFlag ifTrue: [self nextBits: 2 put: bits - 2]. stereoFlag ifTrue: [ samples _ Array with: leftSoundBuffer with: rightSoundBuffer. sampleIndex _ Array with: 0 with: 0. self privateEncodeStereo: sampleCount] ifFalse: [ samples _ leftSoundBuffer. sampleIndex _ 0. self privateEncodeMono: sampleCount]. ^ encodedBytes ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/27/1999 12:14'! headerBitsForSampleCount: sampleCount stereoFlag: stereoFlag "Answer the number of extra header bits required for the given number of samples. This will be zero if I am not using frame headers." | frameCount bitsPerHeader | frameSizeMask = 0 ifTrue: [^ 0]. frameCount _ (sampleCount / self samplesPerFrame) ceiling. bitsPerHeader _ 16 + 6. stereoFlag ifTrue: [bitsPerHeader _ 2 * bitsPerHeader]. ^ frameCount * bitsPerHeader ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 16:08'! indexForDeltaFrom: thisSample to: nextSample "Answer the best index to use for the difference between the given samples." "Details: Scan stepSizeTable for the first entry >= the absolute value of the difference between sample values. Since indexes are zero-based, the index used during decoding will be the one in the following stepSizeTable entry. Since the index field of a Flash frame header is only six bits, the maximum index value is 63." "Note: Since there does not appear to be any documentation of how Flash acutally computes the indices used in its frame headers, this algorithm was guessed by reverse-engineering the Flash ADPCM decoder." | diff bestIndex | self inline: true. diff _ nextSample - thisSample. diff < 0 ifTrue: [diff _ 0 - diff]. bestIndex _ 63. 1 to: 62 do: [:j | bestIndex = 63 ifTrue: [ (stepSizeTable at: j) >= diff ifTrue: [bestIndex _ j]]]. ^ bestIndex ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/28/1999 20:48'! initializeForBitsPerSample: sampleBits samplesPerFrame: frameSize self resetForMono. stepSizeTable _ #(7 8 9 10 11 12 13 14 16 17 19 21 23 25 28 31 34 37 41 45 50 55 60 66 73 80 88 97 107 118 130 143 157 173 190 209 230 253 279 307 337 371 408 449 494 544 598 658 724 796 876 963 1060 1166 1282 1411 1552 1707 1878 2066 2272 2499 2749 3024 3327 3660 4026 4428 4871 5358 5894 6484 7132 7845 8630 9493 10442 11487 12635 13899 15289 16818 18500 20350 22385 24623 27086 29794 32767). indexTable _ nil. sampleBits = 2 ifTrue: [ indexTable _ #(-1 2)]. sampleBits = 3 ifTrue: [ indexTable _ #(-1 -1 2 4)]. sampleBits = 4 ifTrue: [ indexTable _ #(-1 -1 -1 -1 2 4 6 8)]. sampleBits = 5 ifTrue: [ indexTable _ #(-1 -1 -1 -1 -1 -1 -1 -1 1 2 4 6 8 10 13 16)]. indexTable ifNil: [self error: 'unimplemented bits/sample']. bitsPerSample _ sampleBits. deltaSignMask _ 1 bitShift: bitsPerSample - 1. deltaValueMask _ deltaSignMask - 1. deltaValueHighBit _ deltaSignMask / 2. frameSize <= 1 ifTrue: [frameSizeMask _ 0] ifFalse: [ (frameSize = (1 bitShift: frameSize highBit - 1)) ifFalse: [self error: 'frameSize must be a power of two']. frameSizeMask _ frameSize - 1]. "keep as SoundBuffer to allow fast access from primitive" indexTable _ SoundBuffer fromArray: indexTable. stepSizeTable _ SoundBuffer fromArray: stepSizeTable. ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/29/1999 07:13'! privateDecodeMono: count | delta step predictedDelta bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predicted _ self nextBits: 16. predicted > 32767 ifTrue: [predicted _ predicted - 65536]. index _ self nextBits: 6. samples at: (sampleIndex _ sampleIndex + 1) put: predicted] ifFalse: [ delta _ self nextBits: bitsPerSample. step _ stepSizeTable at: index + 1. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (delta bitAnd: bit) > 0 ifTrue: [predictedDelta _ predictedDelta + step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. (delta bitAnd: deltaSignMask) > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. index _ index + (indexTable at: (delta bitAnd: deltaValueMask) + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predicted]]. ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/29/1999 07:13'! privateDecodeStereo: count | predictedLeft predictedRight indexLeft indexRight deltaLeft deltaRight stepLeft stepRight predictedDeltaLeft predictedDeltaRight bit | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. self var: #rightSamples declareC: 'short int *rightSamples'. self var: #predicted declareC: 'short int *predicted'. self var: #index declareC: 'short int *index'. "make local copies of decoder state variables" predictedLeft _ predicted at: 1. predictedRight _ predicted at: 2. indexLeft _ index at: 1. indexRight _ index at: 2. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ "start of frame; read frame header" predictedLeft _ self nextBits: 16. indexLeft _ self nextBits: 6. predictedRight _ self nextBits: 16. indexRight _ self nextBits: 6. predictedLeft > 32767 ifTrue: [predictedLeft _ predictedLeft - 65536]. predictedRight > 32767 ifTrue: [predictedRight _ predictedRight - 65536]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight] ifFalse: [ deltaLeft _ self nextBits: bitsPerSample. deltaRight _ self nextBits: bitsPerSample. stepLeft _ stepSizeTable at: indexLeft + 1. stepRight _ stepSizeTable at: indexRight + 1. predictedDeltaLeft _ predictedDeltaRight _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ (deltaLeft bitAnd: bit) > 0 ifTrue: [ predictedDeltaLeft _ predictedDeltaLeft + stepLeft]. (deltaRight bitAnd: bit) > 0 ifTrue: [ predictedDeltaRight _ predictedDeltaRight + stepRight]. stepLeft _ stepLeft bitShift: -1. stepRight _ stepRight bitShift: -1. bit _ bit bitShift: -1]. predictedDeltaLeft _ predictedDeltaLeft + stepLeft. predictedDeltaRight _ predictedDeltaRight + stepRight. (deltaLeft bitAnd: deltaSignMask) > 0 ifTrue: [predictedLeft _ predictedLeft - predictedDeltaLeft] ifFalse: [predictedLeft _ predictedLeft + predictedDeltaLeft]. (deltaRight bitAnd: deltaSignMask) > 0 ifTrue: [predictedRight _ predictedRight - predictedDeltaRight] ifFalse: [predictedRight _ predictedRight + predictedDeltaRight]. predictedLeft > 32767 ifTrue: [predictedLeft _ 32767] ifFalse: [predictedLeft < -32768 ifTrue: [predictedLeft _ -32768]]. predictedRight > 32767 ifTrue: [predictedRight _ 32767] ifFalse: [predictedRight < -32768 ifTrue: [predictedRight _ -32768]]. indexLeft _ indexLeft + (indexTable at: (deltaLeft bitAnd: deltaValueMask) + 1). indexLeft < 0 ifTrue: [indexLeft _ 0] ifFalse: [indexLeft > 88 ifTrue: [indexLeft _ 88]]. indexRight _ indexRight + (indexTable at: (deltaRight bitAnd: deltaValueMask) + 1). indexRight < 0 ifTrue: [indexRight _ 0] ifFalse: [indexRight > 88 ifTrue: [indexRight _ 88]]. samples at: (sampleIndex _ sampleIndex + 1) put: predictedLeft. rightSamples at: sampleIndex put: predictedRight]]. "save local copies of decoder state variables" predicted at: 1 put: predictedLeft. predicted at: 2 put: predictedRight. index at: 1 put: indexLeft. index at: 2 put: indexRight. ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 3/29/1999 07:13'! privateEncodeMono: count | step sign diff delta predictedDelta bit p | self var: #stepSizeTable declareC: 'short int *stepSizeTable'. self var: #indexTable declareC: 'short int *indexTable'. self var: #samples declareC: 'short int *samples'. self var: #encodedBytes declareC: 'unsigned char *encodedBytes'. step _ stepSizeTable at: 1. 1 to: count do: [:i | (i bitAnd: frameSizeMask) = 1 ifTrue: [ predicted _ samples at: (sampleIndex _ sampleIndex + 1). (p _ predicted) < 0 ifTrue: [p _ p + 65536]. self nextBits: 16 put: p. i < count ifTrue: [ index _ self indexForDeltaFrom: predicted to: (samples at: sampleIndex + 1)]. self nextBits: 6 put: index. ] ifFalse: [ "compute sign and magnitude of difference from the predicted sample" sign _ 0. diff _ (samples at: (sampleIndex _ sampleIndex + 1)) - predicted. diff < 0 ifTrue: [ sign _ deltaSignMask. diff _ 0 - diff]. "Compute encoded delta and the difference that this will cause in the predicted sample value during decoding. Note that this code approximates: delta _ (4 * diff) / step. predictedDelta _ ((delta + 0.5) * step) / 4; but in the shift step bits are dropped. Thus, even if you have fast mul/div hardware you cannot use it since you would get slightly different bits what than the algorithm defines." delta _ 0. predictedDelta _ 0. bit _ deltaValueHighBit. [bit > 0] whileTrue: [ diff >= step ifTrue: [ delta _ delta + bit. predictedDelta _ predictedDelta + step. diff _ diff - step]. step _ step bitShift: -1. bit _ bit bitShift: -1]. predictedDelta _ predictedDelta + step. "compute and clamp new prediction" sign > 0 ifTrue: [predicted _ predicted - predictedDelta] ifFalse: [predicted _ predicted + predictedDelta]. predicted > 32767 ifTrue: [predicted _ 32767] ifFalse: [predicted < -32768 ifTrue: [predicted _ -32768]]. "compute new index and step values" index _ index + (indexTable at: delta + 1). index < 0 ifTrue: [index _ 0] ifFalse: [index > 88 ifTrue: [index _ 88]]. step _ stepSizeTable at: index + 1. "output encoded, signed delta" self nextBits: bitsPerSample put: (sign bitOr: delta)]]. bitPosition > 0 ifTrue: [ "flush the last output byte, if necessary" encodedBytes at: (byteIndex _ byteIndex + 1) put: currentByte]. ! ! !ADPCMCodec methodsFor: 'as yet unclassified' stamp: 'jm 5/29/2003 21:34'! privateEncodeStereo: count self inline: false. self notYetImplemented. ! ! !ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 3/27/1999 11:15'! new ^ super new initializeForBitsPerSample: 4 samplesPerFrame: 0. ! ! !ADPCMCodec class methodsFor: 'instance creation' stamp: 'jm 11/15/2001 16:02'! newBitsPerSample: bitsPerSample ^ super new initializeForBitsPerSample: bitsPerSample samplesPerFrame: 0. ! ! I am a parser for AIFF (audio interchange file format) files. I can read uncompressed 8-bit and 16-bit mono, stereo, or multichannel AIFF files. I read the marker information used by the TransferStation utility to mark the loop points in sounds extracted from commercial sampled-sound CD-ROMs. ! !AIFFFileReader methodsFor: 'reading' stamp: 'jm 8/2/1998 16:27'! readFromFile: fileName "Read the AIFF file of the given name." "AIFFFileReader new readFromFile: 'test.aiff'" self readFromFile: fileName mergeIfStereo: false skipDataChunk: false. ! ! !AIFFFileReader methodsFor: 'reading' stamp: 'jm 10/17/2001 17:20'! readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read the AIFF file of the given name. See comment in readFromStream:mergeIfStereo:skipDataChunk:." "AIFFFileReader new readFromFile: 'test.aiff' mergeIfStereo: false skipDataChunk: true" | f | f _ (FileStream readOnlyFileNamed: fileName) binary. self readFromStream: f mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag. f close. ! ! !AIFFFileReader methodsFor: 'reading'! readFromStream: aBinaryStream mergeIfStereo: mergeFlag skipDataChunk: skipDataFlag "Read an AIFF file from the given binary stream. If mergeFlag is true and the file contains stereo data, then the left and right channels will be mixed together as the samples are read in. If skipDataFlag is true, then the data chunk to be skipped; this allows the other chunks of a file to be processed in order to extract format information quickly without reading the data." mergeIfStereo _ mergeFlag. skipDataChunk _ skipDataFlag. isLooped _ false. gain _ 1.0. self readFrom: aBinaryStream. ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! bitsPerSample ^ bitsPerSample ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'! channelCount ^ channelCount ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! channelData ^ channelData ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 10/20/2001 15:07'! channelDataOffset ^ channelDataOffset ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:24'! frameCount ^ frameCount ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! gain ^ gain ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:40'! isLooped ^ isLooped ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 20:02'! isStereo ^ channelData size = 2 ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:26'! leftSamples ^ channelData at: 1 ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'! loopEnd ^ markers last last ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:30'! loopLength ^ markers last last - markers first last ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 21:25'! markers ^ markers ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 01:48'! pitch ^ pitch ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 8/2/1998 19:34'! rightSamples ^ channelData at: 2 ! ! !AIFFFileReader methodsFor: 'accessing' stamp: 'jm 7/12/1998 18:25'! samplingRate ^ samplingRate ! ! !AIFFFileReader methodsFor: 'other' stamp: 'jm 8/17/1998 20:36'! edit | ed | ed _ WaveEditor new. ed data: channelData first. ed loopEnd: markers last last. ed loopLength: (markers last last - markers first last) + 1. ed openInWorld. ! ! !AIFFFileReader methodsFor: 'other' stamp: 'jm 7/12/1998 01:44'! pitchForKey: midiKey "Convert my MIDI key number to a pitch and return it." | indexInOctave octave p | indexInOctave _ (midiKey \\ 12) + 1. octave _ (midiKey // 12) + 1. "Table generator: (0 to: 11) collect: [:i | 16.3516 * (2.0 raisedTo: i asFloat / 12.0)]" p _ #(16.3516 17.32391 18.35405 19.44544 20.60173 21.82677 23.12466 24.49972 25.95655 27.50000 29.13524 30.86771) at: indexInOctave. ^ p * (#(0.5 1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0) at: octave) ! ! !AIFFFileReader methodsFor: 'other' stamp: 'jm 1/14/1999 10:11'! sound "Answer the sound represented by this AIFFFileReader. This method should be called only after readFrom: has been done." | snd rightSnd | snd _ SampledSound samples: (channelData at: 1) samplingRate: samplingRate. self isStereo ifTrue: [ rightSnd _ SampledSound samples: (channelData at: 2) samplingRate: samplingRate. snd _ MixedSound new add: snd pan: 0; add: rightSnd pan: 1.0]. ^ snd ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 07:33'! readChunk: chunkType size: chunkSize "Read a AIFF chunk of the given type. Skip unrecognized chunks. Leave the input stream positioned chunkSize bytes past its position when this method is called." chunkType = 'COMM' ifTrue: [^ self readCommonChunk: chunkSize]. chunkType = 'SSND' ifTrue: [^ self readSamplesChunk: chunkSize]. chunkType = 'INST' ifTrue: [^ self readInstrumentChunk: chunkSize]. chunkType = 'MARK' ifTrue: [^ self readMarkerChunk: chunkSize]. in skip: chunkSize. "skip unknown chunks" ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 7/12/1998 18:24'! readCommonChunk: chunkSize "Read a COMM chunk. All AIFF files have exactly one chunk of this type." | compressionType | channelCount _ in nextNumber: 2. frameCount _ in nextNumber: 4. bitsPerSample _ in nextNumber: 2. samplingRate _ self readExtendedFloat. chunkSize > 18 ifTrue: [ fileType = 'AIFF' ifTrue: [self error: 'unexpectedly long COMM chunk size for AIFF file']. compressionType _ (in next: 4) asString. compressionType = 'NONE' ifFalse: [self error: 'cannot read compressed AIFF files']. in skip: (chunkSize - 22)]. "skip the reminder of AIFF-C style chunk" ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 6/29/1998 11:43'! readExtendedFloat "Read and answer an Apple extended-precision 80-bit floating point number from the input stream." "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do." | signAndExp mantissa sign exp | signAndExp _ in nextNumber: 2. mantissa _ in nextNumber: 8. "scaled by (2 raisedTo: -64) below" (signAndExp bitAnd: 16r8000) = 0 ifTrue: [sign _ 1.0] ifFalse: [sign _ -1.0]. exp _ (signAndExp bitAnd: 16r7FFF) - 16r4000 + 2. "not sure why +2 is needed..." ^ (sign * mantissa asFloat * (2.0 raisedTo: exp - 64)) roundTo: 0.00000001 ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 19:58'! readFrom: aBinaryStream "Read AIFF data from the given binary stream." "Details: An AIFF file consists of a header (FORM chunk) followed by a sequence of tagged data chunks. Each chunk starts with a header consisting of a four-byte tag (a string) and a four byte size. These eight bytes of chunk header are not included in the chunk size. For each chunk, the readChunk:size: method consumes chunkSize bytes of the input stream, parsing recognized chunks or skipping unrecognized ones. If chunkSize is odd, it will be followed by a padding byte. Chunks may occur in any order." | sz end chunkType chunkSize p | in _ aBinaryStream. "read FORM chunk" (in next: 4) asString = 'FORM' ifFalse: [^ self error: 'not an AIFF file']. sz _ in nextNumber: 4. end _ in position + sz. fileType _ (in next: 4) asString. [in atEnd not and: [in position < end]] whileTrue: [ chunkType _ (in next: 4) asString. chunkSize _ in nextNumber: 4. p _ in position. self readChunk: chunkType size: chunkSize. (in position = (p + chunkSize)) ifFalse: [self error: 'chunk size mismatch; bad AIFF file?']. chunkSize odd ifTrue: [in skip: 1]]. "skip padding byte" ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/5/1998 17:31'! readInstrumentChunk: chunkSize | midiKey detune lowNote highNote lowVelocity highVelocity sustainMode sustainStartID sustainEndID releaseMode releaseStartID releaseEndID | midiKey _ in next. detune _ in next. lowNote _ in next. highNote _ in next. lowVelocity _ in next. highVelocity _ in next. gain _ in nextNumber: 2. sustainMode _ in nextNumber: 2. sustainStartID _ in nextNumber: 2. sustainEndID _ in nextNumber: 2. releaseMode _ in nextNumber: 2. releaseStartID _ in nextNumber: 2. releaseEndID _ in nextNumber: 2. isLooped _ sustainMode = 1. (isLooped and: [markers notNil]) ifTrue: [ ((markers first last > frameCount) or: [markers last last > frameCount]) ifTrue: [ "bad loop data; some sample CD files claim to be looped but aren't" isLooped _ false]]. pitch _ self pitchForKey: midiKey. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 21:22'! readMarkerChunk: chunkSize | markerCount id position labelBytes label | markerCount _ in nextNumber: 2. markers _ Array new: markerCount. 1 to: markerCount do: [:i | id _ in nextNumber: 2. position _ in nextNumber: 4. labelBytes _ in next. label _ (in next: labelBytes) asString. labelBytes even ifTrue: [in skip: 1]. markers at: i put: (Array with: id with: label with: position)]. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:58'! readMergedStereoChannelDataFrom: s "Read stereophonic channel data from the given stream, mixing the two channels to create a single monophonic channel. Each frame contains two samples." | buf w1 w2 | buf _ channelData at: 1. bitsPerSample = 8 ifTrue: [ 1 to: frameCount do: [:i | w1 _ s next. w1 > 127 ifTrue: [w1 _ w1 - 256]. w2 _ s next. w2 > 127 ifTrue: [w2 _ w2 - 256]. buf at: i put: ((w1 + w2) bitShift: 7)]] ifFalse: [ 1 to: frameCount do: [:i | w1 _ (s next bitShift: 8) + s next. w1 > 32767 ifTrue: [w1 _ w1 - 65536]. w2 _ (s next bitShift: 8) + s next. w2 > 32767 ifTrue: [w2 _ w2 - 65536]. buf at: i put: ((w1 + w2) bitShift: -1)]]. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:53'! readMonoChannelDataFrom: s "Read monophonic channel data from the given stream. Each frame contains a single sample." | buf w | buf _ channelData at: 1. "the only buffer" bitsPerSample = 8 ifTrue: [ 1 to: frameCount do: [:i | w _ s next. w > 127 ifTrue: [w _ w - 256]. buf at: i put: (w bitShift: 8)]] ifFalse: [ 1 to: frameCount do: [:i | w _ (s next bitShift: 8) + s next. w > 32767 ifTrue: [w _ w - 65536]. buf at: i put: w]]. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:55'! readMultiChannelDataFrom: s "Read multi-channel data from the given stream. Each frame contains channelCount samples." | w | bitsPerSample = 8 ifTrue: [ 1 to: frameCount do: [:i | 1 to: channelCount do: [:ch | w _ s next. w > 127 ifTrue: [w _ w - 256]. (channelData at: ch) at: i put: (w bitShift: 8)]]] ifFalse: [ 1 to: frameCount do: [:i | 1 to: channelCount do: [:ch | w _ (s next bitShift: 8) + s next. w > 32767 ifTrue: [w _ w - 65536]. (channelData at: ch) at: i put: w]]]. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 10/20/2001 15:07'! readSamplesChunk: chunkSize "Read a SSND chunk. All AIFF files with a non-zero frameCount contain exactly one chunk of this type." | offset blockSize bytesOfSamples s | offset _ in nextNumber: 4. blockSize _ in nextNumber: 4. ((offset ~= 0) or: [blockSize ~= 0]) ifTrue: [^ self error: 'this AIFF reader cannot handle blocked sample chunks']. bytesOfSamples _ chunkSize - 8. bytesOfSamples = (channelCount * frameCount * (bitsPerSample // 8)) ifFalse: [self error: 'actual sample count does not match COMM chunk']. channelDataOffset _ in position. "record stream position for start of data" skipDataChunk ifTrue: [in skip: (chunkSize - 8). ^ self]. "if skipDataChunk, skip sample data" (mergeIfStereo and: [channelCount = 2]) ifTrue: [ channelData _ Array with: (SoundBuffer newMonoSampleCount: frameCount)] ifFalse: [ channelData _ (1 to: channelCount) collect: [:i | SoundBuffer newMonoSampleCount: frameCount]]. (bytesOfSamples < (Smalltalk garbageCollectMost - 300000)) ifTrue: [s _ ReadStream on: (in next: bytesOfSamples)] "bulk-read, then process" ifFalse: [s _ in]. "not enough space to buffer; read directly from file" "mono and stereo are special-cased for better performance" channelCount = 1 ifTrue: [^ self readMonoChannelDataFrom: s]. channelCount = 2 ifTrue: [ mergeIfStereo ifTrue: [channelCount _ 1. ^ self readMergedStereoChannelDataFrom: s] ifFalse: [^ self readStereoChannelDataFrom: s]]. self readMultiChannelDataFrom: s. ! ! !AIFFFileReader methodsFor: 'private' stamp: 'jm 8/2/1998 18:56'! readStereoChannelDataFrom: s "Read stereophonic channel data from the given stream. Each frame contains two samples." | left right w | left _ channelData at: 1. right _ channelData at: 2. bitsPerSample = 8 ifTrue: [ 1 to: frameCount do: [:i | w _ s next. w > 127 ifTrue: [w _ w - 256]. left at: i put: (w bitShift: 8). w _ s next. w > 127 ifTrue: [w _ w - 256]. right at: i put: (w bitShift: 8)]] ifFalse: [ 1 to: frameCount do: [:i | w _ (s next bitShift: 8) + s next. w > 32767 ifTrue: [w _ w - 65536]. left at: i put: w. w _ (s next bitShift: 8) + s next. w > 32767 ifTrue: [w _ w - 65536]. right at: i put: w]]. ! ! !AbstractScoreEvent methodsFor: 'accessing' stamp: 'di 6/17/1999 14:28'! adjustTimeBy: delta time _ time + delta ! ! !AbstractScoreEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'! endTime "Subclasses should override to return the ending time if the event has some duration." ^ time ! ! !AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! isControlChange ^ false ! ! !AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! isPitchBend ^ false ! ! !AbstractScoreEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:43'! isProgramChange ^ false ! ! !AbstractScoreEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! outputOnMidiPort: aMidiPort "Output this event to the given MIDI port. This default implementation does nothing." ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 3/24/1999 12:03'! loudness: aNumber "Initialize my volume envelopes and initial volume. Subclasses overriding this method should include a resend to super." | vol | vol _ (aNumber asFloat max: 0.0) min: 1.0. envelopes do: [:e | (e isKindOf: VolumeEnvelope) ifTrue: [e scale: vol]]. self initialVolume: vol. ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:04'! nameOrNumberToPitch: aStringOrNumber "Answer the pitch in cycles/second for the given pitch specification. The specification can be either a numeric pitch or pitch name such as 'c4'." aStringOrNumber isNumber ifTrue: [^ aStringOrNumber asFloat] ifFalse: [^ AbstractSound pitchForName: aStringOrNumber] ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 8/19/1998 08:45'! setPitch: pitchNameOrNumber dur: d loudness: l "Initialize my envelopes for the given parameters. Subclasses overriding this method should include a resend to super." | p | p _ self nameOrNumberToPitch: pitchNameOrNumber. envelopes do: [:e | e volume: l. e centerPitch: p]. self initialVolume: l. self duration: d. ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 17:11'! soundForMidiKey: midiKey dur: d loudness: l "Answer an initialized sound object (a copy of the receiver) that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)." ^ self copy setPitch: (AbstractSound pitchForMIDIKey: midiKey) dur: d loudness: l ! ! !AbstractSound methodsFor: 'initialization' stamp: 'jm 8/3/1998 16:58'! soundForPitch: pitchNameOrNumber dur: d loudness: l "Answer an initialized sound object (a copy of the receiver) that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0." ^ self copy setPitch: pitchNameOrNumber dur: d loudness: l ! ! !AbstractSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 22:34'! isStereo "Answer true if this sound has distinct left and right channels. (Every sound plays into a stereo sample buffer, but most sounds, which produce exactly the same samples on both channels, are not stereo.)" ^ false ! ! !AbstractSound methodsFor: 'sampling rates' stamp: 'jm 12/16/2001 13:14'! originalSamplingRate "For sampled sounds, answer the sampling rate used to record the stored samples. For other sounds, this is the same as the playback sampling rate." ^ SoundPlayer samplingRate ! ! !AbstractSound methodsFor: 'copying' stamp: 'di 3/4/1999 21:29'! sounds "Allows simple sounds to behave as, eg, sequential sounds" ^ Array with: self! ! !AbstractSound methodsFor: 'conversion' stamp: 'jm 12/16/2001 13:26'! asSampledSound "Answer a SampledSound containing my samples. If the receiver is some kind of sampled sound, the resulting SampledSound will have the same original sampling rate as the receiver." ^ SampledSound samples: self samples samplingRate: self originalSamplingRate ! ! !AbstractSound methodsFor: 'conversion' stamp: 'jm 9/9/2003 17:00'! formPixelsPerSecond: pixPerSec "Answer a Form that displays this sound graphically. Time is scaled so that one second takes the given number of pixels." | w f buf samplesPerBucket c x max min baseY v r | w _ (self duration * pixPerSec) ceiling. f _ Form extent: (w@32) + 2 depth: 4. f fillWhite. f borderWidth: 1. buf _ self samples. samplesPerBucket _ self originalSamplingRate // pixPerSec. c _ Color darkGray. x _ 1. max _ min _ 0. baseY _ 17. 'Computing sound thumbnail...' displayProgressAt: Sensor cursorPoint from: 1 to: buf size during: [:bar | 1 to: buf size do: [:i | v _ buf at: i. v > max ifTrue: [max _ v. max = 32767 ifTrue: [c _ Color red]]. v < min ifTrue: [min _ v. min = -32768 ifTrue: [c _ Color red]]. (i \\ samplesPerBucket) = 0 ifTrue: [ bar value: i. r _ (x@(baseY - (max // 1024))) corner: (x + 1)@(baseY - (min // 1024)). f fill: r fillColor: c. x _ x + 1. c _ Color darkGray. max _ min _ 0]]]. ^ f ! ! !AbstractSound methodsFor: 'envelopes' stamp: 'jm 8/18/1998 09:57'! removeAllEnvelopes "Remove all envelopes from my envelopes list." envelopes _ #(). ! ! !AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:37'! loudness "Answer the current volume setting for this sound." ^ scaledVol asFloat / ScaleFactor asFloat! ! !AbstractSound methodsFor: 'volume' stamp: 'jm 8/13/1998 16:28'! 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." self error: 'not yet implemented'. ! ! !AbstractSound methodsFor: 'playing' stamp: 'ar 12/5/1998 22:20'! isPlaying "Return true if the receiver is currently playing" ^ SoundPlayer isPlaying: self! ! !AbstractSound methodsFor: 'playing' stamp: 'di 5/30/1999 12:46'! millisecondsSinceStart ^ mSecsSinceStart! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 15:09'! playAndWaitUntilDone "Play this sound to the sound ouput port and wait until it has finished playing before returning." SoundPlayer playSound: self. [self samplesRemaining > 0] whileTrue. (Delay forMilliseconds: 2 * SoundPlayer bufferMSecs) wait. "ensure last buffer has been output" ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 8/18/1998 10:52'! playChromaticRunFrom: startPitch to: endPitch "Play a fast chromatic run between the given pitches. Useful for auditioning a sound." (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 8/13/1998 16:17'! playSampleCount: n into: aSoundBuffer startingAt: startIndex "Mix the next n samples of this sound into the given buffer starting at the given index. Update the receiver's control parameters periodically." | fullVol samplesBetweenControlUpdates pastEnd i remainingSamples count | fullVol _ AbstractSound scaleFactor. samplesBetweenControlUpdates _ self samplingRate // self controlRate. pastEnd _ startIndex + n. "index just after the 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 7/5/1998 17:53'! playSilently "Compute the samples of this sound without outputting them. Used for performance analysis." | bufSize buf | self reset. bufSize _ self samplingRate // 10. buf _ SoundBuffer newStereoSampleCount: bufSize. [self samplesRemaining > 0] whileTrue: [ buf primFill: 0. self playSampleCount: bufSize into: buf startingAt: 1]. ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:22'! samples "Answer a monophonic sample buffer containing my samples. The left and write channels are merged." "Warning: This may require a lot of memory!!" ^ (self computeSamplesForSeconds: self duration) mergeStereo ! ! !AbstractSound methodsFor: 'playing' stamp: 'jm 12/16/2001 13:24'! viewSamples "Open a WaveEditor on my samples." WaveEditor openOn: self samples. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:34'! 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 | envelopes size > 0 ifTrue: [ pitchModOrRatioChange _ false. 1 to: envelopes size do: [:i | ((envelopes at: i) updateTargetAt: mSecsSinceStart) ifTrue: [pitchModOrRatioChange _ true]]. pitchModOrRatioChange ifTrue: [self internalizeModulationAndRatio]]. mSecsSinceStart _ mSecsSinceStart + (1000 // self controlRate). ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 7/6/1998 06:40'! 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 ScaleFactor is full volume." self subclassResponsibility. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 13:45'! reset "Reset my internal state for a replay. Methods that override this method should do super reset." mSecsSinceStart _ 0. samplesUntilNextControl _ 0. envelopes size > 0 ifTrue: [ 1 to: envelopes size do: [:i | (envelopes at: i) reset]]. ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:56'! stopAfterMSecs: mSecs "Terminate this sound this note after the given number of milliseconds. This default implementation does nothing." ! ! !AbstractSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:54'! stopGracefully "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes." | decayInMs env | envelopes isEmpty ifTrue: [ self adjustVolumeTo: 0 overMSecs: 10. decayInMs _ 10] ifFalse: [ env _ envelopes first. decayInMs _ env attackTime + env decayTime]. self duration: (mSecsSinceStart + decayInMs) / 1000.0. self stopAfterMSecs: decayInMs. ! ! !AbstractSound methodsFor: 'composition' stamp: 'jm 2/2/1999 15:53'! asSound ^ self ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:51'! storeAIFFOnFileNamed: fileName "Store this sound as a AIFF file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeAIFFSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:31'! storeAIFFSamplesOn: aBinaryStream "Store this sound as a 16-bit AIFF file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write AIFF file header:" aBinaryStream nextPutAll: 'FORM' asByteArray. aBinaryStream nextInt32Put: ((7 * 4) + 18) + dataByteCount. aBinaryStream nextPutAll: 'AIFF' asByteArray. aBinaryStream nextPutAll: 'COMM' asByteArray. aBinaryStream nextInt32Put: 18. aBinaryStream nextNumber: 2 put: channelCount. aBinaryStream nextInt32Put: samplesToStore. aBinaryStream nextNumber: 2 put: 16. "bits/sample" self storeExtendedFloat: self samplingRate on: aBinaryStream. aBinaryStream nextPutAll: 'SSND' asByteArray. aBinaryStream nextInt32Put: dataByteCount + 8. aBinaryStream nextInt32Put: 0. aBinaryStream nextInt32Put: 0. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 3/13/1999 11:34'! storeExtendedFloat: aNumber on: aBinaryStream "Store an Apple extended-precision 80-bit floating point number on the given stream." "Details: I could not find the specification for this format, so constants were determined empirically based on assumption of 1-bit sign, 15-bit exponent, 64-bit mantissa. This format does not seem to have an implicit one before the mantissa as some float formats do." | n isNeg exp mantissa | n _ aNumber asFloat. isNeg _ false. n < 0.0 ifTrue: [ n _ 0.0 - n. isNeg _ true]. exp _ (n log: 2.0) ceiling. mantissa _ (n * (2 raisedTo: 64 - exp)) truncated. exp _ exp + 16r4000 - 2. "not sure why the -2 is needed..." isNeg ifTrue: [exp _ exp bitOr: 16r8000]. "set sign bit" aBinaryStream nextPut: ((exp bitShift: -8) bitAnd: 16rFF). aBinaryStream nextPut: (exp bitAnd: 16rFF). 8 to: 1 by: -1 do: [:i | aBinaryStream nextPut: (mantissa digitAt: i)]. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/17/2001 08:36'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files). If self isStereo is true, both channels are stored, creating a stereo file. Otherwise, only the left channel is stored, creating a mono file." | bufSize stereoBuffer reverseBytes remaining out | self reset. bufSize _ (2 * self samplingRate rounded) min: samplesToStore. "two second buffer" stereoBuffer _ SoundBuffer newStereoSampleCount: bufSize. reverseBytes _ bigEndianFlag ~= (Smalltalk endianness = #big). 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: samplesToStore during: [:bar | remaining _ samplesToStore. [remaining > 0] whileTrue: [ bar value: samplesToStore - remaining. stereoBuffer primFill: 0. "clear the buffer" self playSampleCount: (bufSize min: remaining) into: stereoBuffer startingAt: 1. self isStereo ifTrue: [out _ stereoBuffer] ifFalse: [out _ stereoBuffer extractLeftChannel]. reverseBytes ifTrue: [out reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (out size // 2) putAll: out startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: out monoSampleCount do: [:i | aBinaryStream int16: (out at: i)]]. remaining _ remaining - bufSize]]. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:47'! storeSunAudioOnFileNamed: fileName "Store this sound as an uncompressed Sun audio file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeSunAudioSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeSunAudioSamplesOn: aBinaryStream "Store this sound as a 16-bit Sun audio file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. "write Sun audio file header" channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. aBinaryStream nextPutAll: '.snd' asByteArray. aBinaryStream uint32: 24. "header size in bytes" aBinaryStream uint32: dataByteCount. aBinaryStream uint32: 3. "format: 16-bit linear" aBinaryStream uint32: self samplingRate truncated. aBinaryStream uint32: channelCount. "write data:" self storeSampleCount: samplesToStore bigEndian: true on: aBinaryStream. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:03'! storeWAVOnFileNamed: fileName "Store this sound as a 16-bit Windows WAV file of the given name." | f | f _ (FileStream fileNamed: fileName) binary. self storeWAVSamplesOn: f. f close. ! ! !AbstractSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 22:32'! storeWAVSamplesOn: aBinaryStream "Store this sound as a 16-bit Windows WAV file at the current SoundPlayer sampling rate. Store both channels if self isStereo is true; otherwise, store the left channel only as a mono sound." | samplesToStore channelCount dataByteCount samplesPerSec bytesPerSec | samplesToStore _ (self duration * self samplingRate) ceiling. channelCount _ self isStereo ifTrue: [2] ifFalse: [1]. dataByteCount _ samplesToStore * channelCount * 2. samplesPerSec _ self samplingRate rounded. bytesPerSec _ samplesPerSec * channelCount * 2. "file header" aBinaryStream nextPutAll: 'RIFF' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount + 36; "total length of all chunks" nextPutAll: 'WAVE' asByteArray. "format chunk" aBinaryStream nextPutAll: 'fmt ' asByteArray; nextLittleEndianNumber: 4 put: 16; "length of this chunk" nextLittleEndianNumber: 2 put: 1; "format tag" nextLittleEndianNumber: 2 put: channelCount; nextLittleEndianNumber: 4 put: samplesPerSec; nextLittleEndianNumber: 4 put: bytesPerSec; nextLittleEndianNumber: 2 put: 4; "alignment" nextLittleEndianNumber: 2 put: 16. "bits per sample" "data chunk" aBinaryStream nextPutAll: 'data' asByteArray; nextLittleEndianNumber: 4 put: dataByteCount. "length of this chunk" self storeSampleCount: samplesToStore bigEndian: false on: aBinaryStream. ! ! !AbstractSound class methodsFor: 'class initialization' stamp: 'jm 8/3/1998 16:13'! initialize "AbstractSound initialize" | bottomC | ScaleFactor _ 2 raisedTo: 15. FloatScaleFactor _ ScaleFactor asFloat. MaxScaledValue _ ((2 raisedTo: 31) // ScaleFactor) - 1. "magnitude of largest scaled value in 32-bits" "generate pitches for c-1 through c0" bottomC _ (440.0 / 32) * (2.0 raisedTo: -9.0 / 12.0). PitchesForBottomOctave _ (0 to: 12) collect: [:i | bottomC * (2.0 raisedTo: i asFloat / 12.0)]. TopOfBottomOctave _ PitchesForBottomOctave last. ! ! !AbstractSound class methodsFor: 'instance creation' stamp: 'jm 8/3/1998 17:00'! 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 soundForPitch: pitch dur: (el at: 2) loudness: (el at: 3) / 1000.0)] ifFalse: [ score add: (RestSound dur: (el at: 2))]]. ^ score ! ! !AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'! indexOfBottomOctavePitch: p "Answer the index of the first pitch in the bottom octave equal to or higher than the given pitch. Assume that the given pitch is below the top pitch of the bottom octave." 1 to: PitchesForBottomOctave size do: [:i | (PitchesForBottomOctave at: i) >= p ifTrue: [^ i]]. self error: 'implementation error: argument pitch should be below or within the bottom octave'. ! ! !AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:16'! midiKeyForPitch: pitchNameOrNumber "Answer the midiKey closest to the given pitch. Pitch may be a numeric pitch or a pitch name string such as 'c4'." "AbstractSound midiKeyForPitch: 440.0" | p octave i midiKey | pitchNameOrNumber isNumber ifTrue: [p _ pitchNameOrNumber asFloat] ifFalse: [p _ AbstractSound pitchForName: pitchNameOrNumber]. octave _ -1. [p >= TopOfBottomOctave] whileTrue: [ octave _ octave + 1. p _ p / 2.0]. i _ self indexOfBottomOctavePitch: p. (i > 1) ifTrue: [ (p - (PitchesForBottomOctave at: i - 1)) < ((PitchesForBottomOctave at: i) - p) ifTrue: [i _ i - 1]]. midiKey _ ((octave * 12) + 11 + i). midiKey > 127 ifTrue: [midiKey _ 127]. ^ midiKey ! ! !AbstractSound class methodsFor: 'utilities' stamp: 'jm 8/3/1998 16:43'! pitchForMIDIKey: midiKey "Answer the pitch for the given MIDI key." "(1 to: 127) collect: [:i | AbstractSound pitchForMIDIKey: i]" | indexInOctave octave | indexInOctave _ (midiKey \\ 12) + 1. octave _ (midiKey // 12) + 1. ^ (PitchesForBottomOctave at: indexInOctave) * (#(1.0 2.0 4.0 8.0 16.0 32.0 64.0 128.0 256.0 512.0 1024.0) at: octave) ! ! !AbstractSound class methodsFor: 'utilities' stamp: 'jm 7/6/1998 15:47'! pitchTable "AbstractSound pitchTable" | out note i | out _ WriteStream on: (String new: 1000). i _ 12. 0 to: 8 do: [:octave | #(c 'c#' d eb e f fs g 'g#' a bf b) do: [:noteName | note _ noteName, octave printString. out nextPutAll: note; tab. out nextPutAll: i printString; tab. out nextPutAll: (AbstractSound pitchForName: note) printString; cr. i _ i + 1]]. ^ out contents ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 6/30/1998 18:40'! chromaticPitchesFrom: aPitch | halfStep pitch | halfStep _ 2.0 raisedTo: (1.0 / 12.0). pitch _ aPitch isNumber ifTrue: [aPitch] ifFalse: [self pitchForName: aPitch]. pitch _ pitch / halfStep. ^ (0 to: 14) collect: [:i | pitch _ pitch * halfStep] ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 8/18/1998 11:32'! chromaticRunFrom: startPitch to: endPitch on: aSound "Answer a composite sound consisting of a rapid chromatic run between the given pitches on the given sound." "(AbstractSound chromaticRunFrom: 'c3' to: 'c#5' on: FMSound oboe1) play" | scale halfStep pEnd p | scale _ SequentialSound new. halfStep _ 2.0 raisedTo: (1.0 / 12.0). endPitch isNumber ifTrue: [pEnd _ endPitch asFloat] ifFalse: [pEnd _ AbstractSound pitchForName: endPitch]. startPitch isNumber ifTrue: [p _ startPitch asFloat] ifFalse: [p _ AbstractSound pitchForName: startPitch]. [p <= pEnd] whileTrue: [ scale add: (aSound soundForPitch: p dur: 0.2 loudness: 0.5). p _ p * halfStep]. ^ scale ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 8/3/1998 17:00'! 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 soundForPitch: (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: 'jm 7/13/1998 13:09'! majorScaleOn: aSound from: aPitch "FMSound majorScale play" ^ self noteSequenceOn: aSound from: ((self majorPitchesFrom: aPitch) collect: [:pitch | Array with: pitch with: 0.5 with: 300]) ! ! !AbstractSound class methodsFor: 'examples' stamp: 'jm 1/4/1999 09:26'! majorScaleOn: aSound from: aPitch octaves: octaveCount "(AbstractSound majorScaleOn: FMSound oboe1 from: #c2 octaves: 5) play" | startingPitch pitches chromatic | startingPitch _ aPitch isNumber ifTrue: [aPitch] ifFalse: [self pitchForName: aPitch]. pitches _ OrderedCollection new. 0 to: octaveCount - 1 do: [:i | chromatic _ self chromaticPitchesFrom: startingPitch * (2 raisedTo: i). #(1 3 5 6 8 10 12) do: [:j | pitches addLast: (chromatic at: j)]]. pitches addLast: startingPitch * (2 raisedTo: octaveCount). ^ self noteSequenceOn: aSound from: (pitches collect: [:pitch | Array with: pitch with: 0.5 with: 300]) ! ! !AbstractSound class methodsFor: 'examples' stamp: 'di 4/13/1999 13:53'! 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 ratio | 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. ratio _ mousePt y asFloat / 20.0. s modulation: mod ratio: ratio. lastVal _ mousePt. status _ 'mod: ', mod printString, ' ratio: ', ratio printString. status displayOn: Display at: 10@10]]. SoundPlayer shutDown. ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:27'! initSounds "AbstractSound initSounds" Sounds _ Dictionary new. (FMSound class organization listAtCategoryNamed: #instruments) do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)]. ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/14/1998 13:25'! soundNamed: soundName ^ Sounds at: soundName ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'tk 6/24/1999 11:31'! soundNamed: soundName put: aSound Sounds at: soundName put: aSound. Smalltalk at: #ScorePlayerMorph ifPresent: [:playerClass | playerClass allSubInstancesDo: [:player | player updateInstrumentsFromLibrary]]. ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/19/1998 14:11'! soundNames ^ Sounds keys asSortedCollection asArray ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'jm 8/4/1998 18:26'! sounds ^ Sounds ! ! !AbstractSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 13:00'! updateFMSounds "AbstractSound updateFMSounds" Sounds keys do: [:k | ((Sounds at: k) isKindOf: FMSound) ifTrue: [ Sounds removeKey: k ifAbsent: []]]. (FMSound class organization listAtCategoryNamed: #instruments) do: [:sel | Sounds at: sel asString put: (FMSound perform: sel)]. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'sge 2/13/2000 05:20'! fileInSoundLibrary "Prompt the user for a file name and the file in the sound library with that name." "AbstractSound fileInSoundLibrary" | fileName | fileName _ FillInTheBlank request: 'Sound library file name?'. fileName isEmptyOrNil ifTrue: [^ self]. (fileName endsWith: '.sounds') ifFalse: [fileName _ fileName, '.sounds']. self fileInSoundLibraryNamed: fileName. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 10/14/2002 18:18'! fileInSoundLibraryNamed: fileName "File in the sound library with the given file name, and add its contents to the current sound library." | newSounds | self flag: 'took out object storage system'. self error: 'depended on object storage system'. newSounds associationsDo: [:assoc | self storeFiledInSound: assoc value named: assoc key]. ScorePlayerMorph allSubInstances do: [:p | p updateInstrumentsFromLibrary]. Smalltalk garbageCollect. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 8/19/1998 12:42'! fileOutSoundLibrary "File out the current sound library." "AbstractSound fileOutSoundLibrary" self fileOutSoundLibrary: Sounds. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 10/14/2002 17:37'! fileOutSoundLibrary: aDictionary "File out the given dictionary, which is assumed to contain sound and instrument objects keyed by their names." "Note: This method is separated out so that one can file out edited sound libraries, as well as the system sound library. To make such a collection, you can inspect AbstractSound sounds and remove the items you don't want. Then do: 'AbstractSound fileOutSoundLibrary: self' from the Dictionary inspector." | fileName | (aDictionary isKindOf: Dictionary) ifFalse: [self error: 'arg should be a dictionary of sounds']. fileName _ FillInTheBlank request: 'Sound library file name?'. fileName isEmptyOrNil ifTrue: [^ self]. self flag: 'took out object storage system'. self error: 'depended on object storage system'. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:35'! storeFiledInSound: snd named: sndName "Store the given sound in the sound library. Use the given name if it isn't in use, otherwise ask the user what to do." | menu choice i | (Sounds includesKey: sndName) ifFalse: [ "no name clash" Sounds at: sndName put: snd. ^ self]. (Sounds at: sndName) == UnloadedSnd ifTrue: [ "re-loading a sound that was unloaded to save space" Sounds at: sndName put: snd. ^ self]. "the given sound name is already used" menu _ SelectionMenu selections: #('replace the existing sound' 'rename the new sound' 'skip it'). choice _ menu startUpWithCaption: '"', sndName, '" has the same name as an existing sound'. (choice beginsWith: 'replace') ifTrue: [ Sounds at: sndName put: snd. ^ self]. (choice beginsWith: 'rename') ifTrue: [ i _ 2. [Sounds includesKey: (sndName, ' v', i printString)] whileTrue: [i _ i + 1]. Sounds at: (sndName, ' v', i printString) put: snd]. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 22:18'! unloadSampledTimbres "This can be done to unload those bulky sampled timbres to shrink the image. The unloaded sounds are replaced by a well-known 'unloaded sound' object to enable the unloaded sounds to be detected when the process is reversed." "AbstractSound unloadSampledTimbres" Sounds keys copy do: [:soundName | (((Sounds at: soundName) isKindOf: SampledInstrument) or: [(Sounds at: soundName) isKindOf: LoopedSampledSound]) ifTrue: [ Sounds at: soundName put: self unloadedSound]]. self updateScorePlayers. Smalltalk garbageCollect. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/11/1998 16:47'! unloadSoundNamed: soundName (Sounds includesKey: soundName) ifTrue: [ Sounds at: soundName put: self unloadedSound]. self updateScorePlayers. ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'jm 9/12/1998 21:48'! unloadedSound "Answer a sound to be used as the place-holder for sounds that have been unloaded." UnloadedSnd ifNil: [UnloadedSnd _ UnloadedSound default copy]. ^ UnloadedSnd ! ! !AbstractSound class methodsFor: 'sound library-file in/out' stamp: 'tk 6/24/1999 07:20'! updateScorePlayers "Force all ScorePlayers to update their instrument list from the sound library. This may done after loading, unloading, or replacing a sound to make all ScorePlayers feel the change." ScorePlayer allSubInstances do: [:p | p pause]. SoundPlayer shutDown. ScorePlayerMorph allInstances do: [:p | p updateInstrumentsFromLibrary]. ! ! !AcceptableCleanTextMorph methodsFor: 'as yet unclassified' stamp: 'di 6/22/1998 21:38'! accept "Overridden to allow accept of clean text" | textToAccept ok | textToAccept _ textMorph asText. ok _ (setTextSelector == nil) or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]]. ok ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]! ! !AcornFileDirectory methodsFor: 'file name utilities' stamp: 'ar 12/18/1999 00:47'! fullPathFor: path path isEmpty ifTrue:[^pathName]. ((path includes: $$ ) or:[path includes: $:]) ifTrue:[^path]. ^pathName, self slash, path! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/12/1998 22:48'! isActiveDirectoryClass "Does this class claim to be that properly active subclass of FileDirectory for this platform? On Acorn, the test is whether systemAttribute 1001 = 'RiscOS' (on newer VMs) or if the primPathNameDelimiter is $. (on older ones), which is what we would like to use for a dirsep if only it would work out. See pathNameDelimiter for more woeful details - then just get on and enjoy Squeak" | attr | attr _ Smalltalk getSystemAttribute: 1001. attr isNil ifFalse:[^attr = 'RiscOS']. ^self primPathNameDelimiter = $. ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 7/20/1999 17:52'! maxFileNameLength ^ 255 ! ! !AcornFileDirectory class methodsFor: 'platform specific' stamp: 'TPR 5/10/1998 21:45'! pathNameDelimiter "Acorn RiscOS uses a dot as the directory separator and has no real concept of filename extensions. We tried to make code handle this, but there are just too many uses of dot as a filename extension - so fake it out by pretending to use a slash. The file prims do conversions instead. Sad, but pragmatic" ^ $/ ! ! Layout my submorphs in a row or column, depending on the setting of orientation. You use rows of columns or columns of rows to create 2-D layouts, but if you need a true table layout AlignmentMorph is not the answer. Centering in the minor dimension (e.g. the vertical placement of morphs in a row) is controlled by the centering setting. Resizing in each dimension in indpendent and can be either "shrinkWrap" (shrink to the smallest possible size that encloses my submorphs), "rigid" (don't change size), or "spaceFill" (grow to fill the available space if I'm in another AlignmentMorph). See my 'accessing' category for other settings. ! !AlignmentMorph methodsFor: 'initialization' stamp: 'jm 7/19/2003 15:07'! 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" layoutNeeded _ true. color _ Color r: 0.8 g: 1.0 b: 0.8. ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'jm 6/5/2003 17:46'! centering: aSymbol "Set the minor dimension alignment to #topLeft, #center, or #bottomRight." (#(topLeft #center #bottomRight) includes: aSymbol) ifTrue: [centering _ aSymbol]. ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'jm 6/5/2003 17:45'! hResizing: aSymbol "Set the horizontal resizing style to #spaceFill, #shrinkWrap, or #rigid." (#(spaceFill #shrinkWrap #rigid) includes: aSymbol) ifTrue: [hResizing _ aSymbol]. ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'jm 6/5/2003 17:42'! orientation: aSymbol "Set the major layout dimension to #horizontal or #vertical." #horizontal == aSymbol ifTrue: [orientation _ #horizontal] ifFalse: [orientation _ #vertical]. ! ! !AlignmentMorph methodsFor: 'accessing' stamp: 'jm 6/5/2003 17:44'! vResizing: aSymbol "Set the vertical resizing style to #spaceFill, #shrinkWrap, or #rigid." (#(spaceFill #shrinkWrap #rigid) includes: aSymbol) ifTrue: [vResizing _ aSymbol]. ! ! !AlignmentMorph methodsFor: 'dropping/grabbing' stamp: 'jm 6/5/2003 18:35'! 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' stamp: 'panda 4/25/2000 15:47'! rootForGrabOf: aMorph | root | self dragNDropEnabled ifFalse: [^ super rootForGrabOf: aMorph]. root _ aMorph. [root == self] whileFalse: [root owner = self ifTrue: [^ root]. root _ root owner]. ^ super rootForGrabOf: aMorph ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'di 11/26/1999 21:37'! 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: [ self resizeIfNeeded. self fixLayout. super fullBounds. "updates cache" priorFullBounds == nil ifTrue: [self invalidRect: fullBounds] ifFalse: [fullBounds = priorFullBounds ifFalse: ["report change due to layout" self invalidRect: (fullBounds merge: priorFullBounds)]]. layoutNeeded _ false]. ^ super fullBounds ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'jm 7/19/2003 15:05'! 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]]. ^ spaceNeeded ! ! !AlignmentMorph methodsFor: 'layout' stamp: 'jm 7/19/2003 15:04'! 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]]. orientation == #vertical ifTrue: [ minW _ 0. submorphs do: [:m | minW _ minW max: m minWidth]. spaceNeeded _ minW + (2 * (inset + borderWidth))]. ^ spaceNeeded ! ! !AlignmentMorph methodsFor: 'menu' stamp: 'jm 10/11/2002 08:56'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'orientation...' action: #chooseOrientation. aCustomMenu add: ((self dragNDropEnabled ifTrue: ['close'] ifFalse: ['open']), ' dragNdrop') action: #toggleDragNDrop. ! ! !AlignmentMorph methodsFor: 'menu' stamp: 'jm 6/5/2003 18:32'! 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: 'private' stamp: 'sw 5/6/2000 03:09'! drawSubmorphsOn: aCanvas ((self hasProperty: #clipToOwnerWidth) and: [owner isWorldOrHandMorph not]) ifFalse: [super drawSubmorphsOn: aCanvas] ifTrue: [aCanvas clipBy: (self bounds intersect: owner bounds) during: [:clippedCanvas | super drawSubmorphsOn: clippedCanvas]]! ! !AlignmentMorph methodsFor: 'private' stamp: 'jm 7/19/2003 15:04'! extraSpacePerMorph | spaceFillingMorphs spaceNeeded extra | spaceFillingMorphs _ 0. spaceNeeded _ 2 * (inset + borderWidth). orientation = #horizontal ifTrue: [ submorphs do: [:m | spaceNeeded _ spaceNeeded + m minWidth. (m isAlignmentMorph and: [m hResizing = #spaceFill]) ifTrue: [spaceFillingMorphs _ spaceFillingMorphs + 1]]. extra _ (bounds width - spaceNeeded) max: 0. ] ifFalse: [ submorphs do: [:m | spaceNeeded _ spaceNeeded + m minHeight. (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 asFloat / spaceFillingMorphs ! ! !AlignmentMorph methodsFor: 'private' stamp: 'jm 11/10/1998 13:33'! fixLayout | extraPerMorph fractionalExtra fractionAccumulator nextPlace extra space | extraPerMorph _ self extraSpacePerMorph asFloat. fractionalExtra _ extraPerMorph fractionPart. extraPerMorph _ extraPerMorph truncated. orientation = #horizontal ifTrue: [nextPlace _ bounds left + inset + borderWidth] ifFalse: [nextPlace _ bounds top + inset + borderWidth]. fractionAccumulator _ 0.0. submorphs do: [:m | fractionAccumulator _ fractionAccumulator + fractionalExtra. fractionAccumulator > 0.5 ifTrue: [ extra _ extraPerMorph + 1. fractionAccumulator _ fractionAccumulator - 1.0] ifFalse: [extra _ extraPerMorph]. space _ self placeAndSize: m at: nextPlace padding: extra. nextPlace _ nextPlace + space]. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'di 11/26/1999 22:16'! layoutChanged layoutNeeded ifTrue: [^ self]. "In process." layoutNeeded _ true. priorFullBounds _ fullBounds. "Remember fullBounds" super layoutChanged. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'di 11/26/1999 22:11'! 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). self layoutChanged]. ((vResizing = #spaceFill) and: [bounds height ~= h]) ifTrue: [ bounds _ bounds origin extent: (bounds width @ h). self layoutChanged]. ! ! !AlignmentMorph methodsFor: 'private' stamp: 'jm 7/19/2003 15:06'! placeAndSize: m at: nextPlace padding: padding | space totalInset fullBnds left top | totalInset _ inset + borderWidth. orientation = #horizontal ifTrue: [ space _ m minWidth. m isAlignmentMorph ifTrue: [ (m hResizing = #spaceFill) ifTrue: [space _ space + padding]. m layoutInWidth: space height: (bounds height - (2 * totalInset))]] ifFalse: [ space _ m minHeight. 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: 'sw 5/6/2000 02:53'! 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. owner ifNotNil: [(self hasProperty: #clipToOwnerWidth) ifTrue: [newWidth _ newWidth min: (owner right - bounds left)]]]. 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" bounds _ bounds origin extent: newWidth@newHeight]. ! ! !AlignmentMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:02'! includeInNewMorphMenu ^ true ! ! I present an ArrayedCollection whose elements are objects.! !Array methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer with the receiver itself." ^ self! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:22'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array. The identityHashes remain with the pointers rather than with the objects so that objects in hashed structures should still be properly indexed after the mutation." self primitiveFailed! ! !Array methodsFor: 'converting' stamp: 'di 3/28/1999 10:23'! elementsForwardIdentityTo: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. The identityHashes remain with the pointers rather than with the objects so that the objects in this array should still be properly indexed in any existing hashed structures after the mutation." self primitiveFailed! ! !Array methodsFor: 'printing' stamp: 'jm 5/29/2003 18:49'! isLiteral self do: [:each | each isLiteral ifFalse: [^ false]]. ^ true ! ! !Array methodsFor: 'printing' stamp: 'sma 6/1/2000 09:39'! printOn: aStream aStream nextPut: $#. self printElementsOn: aStream! ! !Array methodsFor: 'private' stamp: 'sma 6/3/2000 21:39'! hasLiteral: literal "Answer true if literal is identical to any literal in this array, even if imbedded in further array structure. This method is only intended for private use by CompiledMethod hasLiteralSymbol:" | lit | 1 to: self size do: [:index | (lit _ self at: index) == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]]. ^ false! ! !Array class methodsFor: 'class initialization' stamp: 'jm 10/13/2002 17:31'! initialize "This empty array object can be shared, since it is immutable:" EmptyArray _ Array new. ! ! !Array class methodsFor: 'constants' stamp: 'jm 10/13/2002 17:32'! empty ^ EmptyArray ! ! !Array class methodsFor: 'brace support' stamp: 'di 11/18/1999 22:53'! braceStream: nElements "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ WriteStream basicNew braceArray: (self new: nElements) ! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWith: a "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array _ self new: 1. array at: 1 put: a. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:15'! braceWith: a with: b "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array _ self new: 2. array at: 1 put: a. array at: 2 put: b. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array _ self new: 3. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:17'! braceWith: a with: b with: c with: d "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." | array | array _ self new: 4. array at: 1 put: a. array at: 2 put: b. array at: 3 put: c. array at: 4 put: d. ^ array! ! !Array class methodsFor: 'brace support' stamp: 'di 11/19/1999 08:16'! braceWithNone "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ self new: 0! ! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.! !ArrayedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:36'! size "Answer how many elements the receiver contains." ^ self basicSize! ! !ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:57'! isSorted "Return true if the receiver is sorted by the given criterion. Optimization for isSortedBy: [:a :b | a <= b]." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm _ self first. 2 to: self size do: [:index | elm _ self at: index. lastElm <= elm ifFalse: [^ false]. lastElm _ elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 6/1/2000 11:58'! isSortedBy: aBlock "Return true if the receiver is sorted by the given criterion." | lastElm elm | self isEmpty ifTrue: [^ true]. lastElm _ self first. 2 to: self size do: [:index | elm _ self at: index. (aBlock value: lastElm value: elm) ifFalse: [^ false]. lastElm _ elm]. ^ true! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:28'! mergeFirst: first middle: middle last: last into: dst by: aBlock "Private. Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." | i1 i2 val1 val2 out | i1 _ first. i2 _ middle + 1. val1 _ self at: i1. val2 _ self at: i2. out _ first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" [(i1 <= middle) and: [i2 <= last]] whileTrue: [(aBlock value: val1 value: val2) ifTrue: [dst at: (out _ out + 1) put: val1. val1 _ self at: (i1 _ i1 + 1)] ifFalse: [dst at: (out _ out + 1) put: val2. i2 _ i2 + 1. i2 <= last ifTrue: [val2 _ self at: i2]]]. "copy the remaining elements" i1 <= middle ifTrue: [dst replaceFrom: out + 1 to: last with: self startingAt: i1] ifFalse: [dst replaceFrom: out + 1 to: last with: self startingAt: i2]! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:25'! mergeSortFrom: startIndex to: stopIndex by: aBlock "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." self size <= 1 ifTrue: [^ self]. "nothing to do" startIndex = stopIndex ifTrue: [^ self]. self assert: [startIndex >= 1 and: [startIndex < stopIndex]]. "bad start index" self assert: [stopIndex <= self size]. "bad stop index" self mergeSortFrom: startIndex to: stopIndex src: self clone dst: self by: aBlock! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:26'! mergeSortFrom: first to: last src: src dst: dst by: aBlock "Private. Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." | middle | first = last ifTrue: [^ self]. middle _ (first + last) // 2. self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. src mergeFirst: first middle: middle last: last into: dst by: aBlock! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:22'! sort "Sort this array into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !ArrayedCollection methodsFor: 'sorting' stamp: 'sma 5/12/2000 14:21'! sort: aSortBlock "Sort this array using aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." self mergeSortFrom: 1 to: self size by: aSortBlock! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sw 10/24/1998 22:22'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer a new instance of me, containing only the 6 arguments as elements." | newCollection | newCollection _ self new: 6. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. newCollection at: 3 put: thirdObject. newCollection at: 4 put: fourthObject. newCollection at: 5 put: fifthObject. newCollection at: 6 put: sixthObject. ^ newCollection! ! !ArrayedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:37'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) replaceFrom: 1 to: aCollection size with: aCollection! ! !AssignmentNode methodsFor: 'initialize-release' stamp: 'di 3/22/1999 12:00'! variable: aVariable value: expression from: encoder (aVariable isMemberOf: MessageAsTempNode) ifTrue: ["Case of remote temp vars" ^ aVariable store: expression from: encoder]. variable _ aVariable. value _ expression! ! !AssignmentNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:54'! asTranslatorNode ^ TAssignmentNode new setVariable: variable asTranslatorNode expression: value asTranslatorNode ! ! I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.! I represent a single atom (particle) in the BouncingAtomsMorph simulation. ! !AtomMorph methodsFor: 'as yet unclassified' stamp: 'jm 8/10/1998 17:40'! bounceIn: aRect "Move this atom one step along its velocity vector and make it bounce if it goes outside the given rectangle. Return true if it is bounced." | p vx vy px py bounced | p _ self position. vx _ velocity x. vy _ velocity y. px _ p x + vx. py _ p y + vy. bounced _ false. px > aRect right ifTrue: [ px _ aRect right - (px - aRect right). vx _ velocity x negated. bounced _ true]. py > aRect bottom ifTrue: [ py _ aRect bottom - (py - aRect bottom). vy _ velocity y negated. bounced _ true]. px < aRect left ifTrue: [ px _ aRect left - (px - aRect left). vx _ velocity x negated. bounced _ true]. py < aRect top ifTrue: [ py _ aRect top - (py - aRect top). vy _ velocity y negated. bounced _ true]. self position: px @ py. bounced ifTrue: [self velocity: vx @ vy]. ^ bounced ! ! !AtomMorph methodsFor: 'as yet unclassified'! 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: 'as yet unclassified'! infected ^ color = Color red! ! !AtomMorph methodsFor: 'as yet unclassified'! infected: aBoolean aBoolean ifTrue: [self color: Color red] ifFalse: [self color: Color blue].! ! !AtomMorph methodsFor: 'as yet unclassified'! 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: 'as yet unclassified'! 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: 'as yet unclassified'! velocity ^ velocity! ! !AtomMorph methodsFor: 'as yet unclassified'! velocity: newVelocity velocity _ newVelocity.! ! I represent an unordered collection of possibly duplicate elements. I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index put: anObject self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'tao 1/5/2000 18:25'! cumulativeCounts "Answer with a collection of cumulative percents covered by elements so far." | s n | s _ self size / 100.0. n _ 0. ^ self sortedCounts asArray collect: [:a | n _ n + a key. (n / s roundTo: 0.1) -> a value]! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:35'! size "Answer how many elements the receiver contains." | tally | tally _ 0. contents do: [:each | tally _ tally + each]. ^ tally! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:18'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject." ^ self add: newObject withOccurrences: 1! ! !Bag methodsFor: 'adding' stamp: 'sma 5/12/2000 17:20'! add: newObject withOccurrences: anInteger "Add newObject anInteger times to the receiver. Answer newObject." contents at: newObject put: (contents at: newObject ifAbsent: [0]) + anInteger. ^ newObject! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:34'! asBag ^ self! ! !Bag methodsFor: 'converting' stamp: 'sma 5/12/2000 14:30'! asSet "Answer a set with the elements of the receiver." ^ contents keys! ! !Bag methodsFor: 'copying' stamp: 'sma 5/12/2000 14:53'! copy ^ self shallowCopy setContents: contents copy! ! !Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents _ aDictionary! ! !Bag methodsFor: 'removing' stamp: 'sma 5/12/2000 14:32'! remove: oldObject ifAbsent: exceptionBlock "Refer to the comment in Collection|remove:ifAbsent:." | count | count _ contents at: oldObject ifAbsent: [^ exceptionBlock value]. count = 1 ifTrue: [contents removeKey: oldObject] ifFalse: [contents at: oldObject put: count - 1]. ^ oldObject! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! new ^ self new: 4! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 14:49'! new: nElements ^ super new setContents: (Dictionary new: nElements)! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:17'! newFrom: aCollection "Answer an instance of me containing the same elements as aCollection." ^ self withAll: aCollection "Examples: Bag newFrom: {1. 2. 3. 3} {1. 2. 3. 3} as: Bag "! ! 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: 'initialization' stamp: 'sw 2/3/2000 00:16'! initialize super initialize. color _ Color paleYellow. borderColor _ Color black. borderWidth _ 1. offsetFromTarget _ 0@0! ! !BalloonMorph methodsFor: 'stepping' stamp: 'sma 12/23/1999 14:05'! step "Move with target." target ifNotNil: [self position: target position + offsetFromTarget]. ! ! !BalloonMorph methodsFor: 'private' stamp: 'sw 2/7/2000 01:49'! adjustedCenter "This horizontal adjustment is needed because we want the interior TextMorph to be centered within the visual balloon rather than simply within the BalloonMorph's bounding box. Without this, balloon-help text would be a bit off-center" ^ self center + (offsetFromTarget x sign * (5 @ 0))! ! !BalloonMorph methodsFor: 'private' stamp: 'sma 12/23/1999 14:06'! setTarget: aMorph (target _ aMorph) ifNotNil: [offsetFromTarget _ self position - target position]! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:05'! string: str for: morph ^ self string: str for: morph corner: #bottomLeft! ! !BalloonMorph class methodsFor: 'instance creation' stamp: 'sma 12/23/1999 20:04'! string: str for: morph corner: cornerName "Make up and return a balloon for morph. Find the quadrant that clips the text the least, using cornerName as a tie-breaker. tk 9/12/97" | tm vertices | tm _ self getTextMorph: str. vertices _ self getVertices: tm bounds. vertices _ self getBestLocation: vertices for: morph corner: cornerName. ^ self new color: morph balloonColor; setVertices: vertices; addMorph: tm; setTarget: morph! ! !BalloonMorph class methodsFor: 'private' stamp: 'sw 2/7/2000 12:10'! getBestLocation: vertices for: morph corner: cornerName "Try four rel locations of the balloon for greatest unclipped area. 12/99 sma" | rect maxArea verts rectCorner morphPoint mbc a mp dir bestVerts result usableArea | rect _ vertices first rect: (vertices at: 5). maxArea _ -1. verts _ vertices. usableArea _ morph world viewBox. 1 to: 4 do: [:i | dir _ #(vertical horizontal) atWrap: i. verts _ verts collect: [:p | p flipBy: dir centerAt: rect center]. rectCorner _ #(bottomLeft bottomRight topRight topLeft) at: i. morphPoint _ #(topCenter topCenter bottomCenter bottomCenter) at: i. a _ ((rect align: (rect perform: rectCorner) with: (mbc _ morph boundsInWorld perform: morphPoint)) intersect: usableArea) area. (a > maxArea or: [a = rect area and: [rectCorner = cornerName]]) ifTrue: [maxArea _ a. bestVerts _ verts. mp _ mbc]]. result _ bestVerts collect: [:p | p + (mp - bestVerts first)] "Inlined align:with:". ^ result! ! !BalloonMorph class methodsFor: 'private' stamp: 'sw 2/2/2000 22:13'! getTextMorph: aStringOrMorph "Construct text morph." | m text | aStringOrMorph isMorph ifTrue: [m _ aStringOrMorph] ifFalse: [BalloonFont ifNil: [text _ aStringOrMorph] ifNotNil: [text _ Text string: aStringOrMorph attribute: (TextFontReference toFont: BalloonFont)]. m _ (TextMorph new contents: text) centered]. m setToAdhereToEdge: #adjustedCenter. ^ m! ! !BalloonMorph class methodsFor: 'private' stamp: 'sma 12/23/1999 15:34'! getVertices: bounds "Construct vertices for a balloon up and to left of anchor" | corners | corners _ bounds corners atAll: #(1 4 3 2). ^ (Array with: corners first + (0 - bounds width // 3 @ 0) with: corners first + (0 - bounds width // 6 @ (bounds height // 2))) , corners! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:43'! balloonFont ^ BalloonFont! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:39'! chooseBalloonFont "BalloonMorph chooseBalloonFont" Preferences chooseFontWithPrompt: 'Select the font to be used for balloon help' andSendTo: self withSelector: #setBalloonFontTo:! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sw 1/31/2000 15:40'! setBalloonFontTo: aFont aFont ifNotNil: [BalloonFont _ aFont]! ! 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' stamp: 'ar 7/19/1999 23:00'! forgetDoIts "get rid of old DoIt methods" self removeSelectorSimply: #DoIt; removeSelectorSimply: #DoItIn:! ! !Behavior methodsFor: 'initialize-release' stamp: 'di 3/10/2000 08:40'! nonObsoleteClass "Attempt to find and return the current version of this obsolete class" | obsName | obsName _ self name. [obsName beginsWith: 'AnObsolete'] whileTrue: [obsName _ obsName copyFrom: 'AnObsolete' size + 1 to: obsName size]. ^ Smalltalk at: obsName asSymbol! ! !Behavior methodsFor: 'initialize-release' stamp: 'ar 9/10/1999 17:33'! obsolete "Invalidate and recycle local messages, e.g., zap the method dictionary if can be done safely." self canZapMethodDictionary ifTrue:[ methodDict _ MethodDictionary new ].! ! !Behavior methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 16:39'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver. Must only be sent to a new instance; else we would need Object flushCache." superclass _ aClass. format _ fmt. methodDict _ mDict.! ! !Behavior methodsFor: 'accessing' stamp: 'sw 3/10/2000 16:55'! 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." | count aMenu answer caption allCalls | allCalls _ Smalltalk allCallsOn: aSelector. (count _ allCalls size) == 0 ifTrue: [^ 1]. "no senders -- let the removal happen without warning" count == 1 ifTrue: [MessageSet parse: allCalls first toClassAndSelector: [:aClass :aSel | (aClass == self and: [aSel == aSelector]) ifTrue: [^ 1]]]. "only sender is itself" 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! ! !Behavior methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:17'! environment "Return the environment in which the receiver is visible" ^Smalltalk! ! !Behavior methodsFor: 'accessing' stamp: 'di 3/27/1999 23:19'! methodDict methodDict == nil ifTrue: [self recoverFromMDFault]. ^ methodDict! ! !Behavior methodsFor: 'accessing' stamp: 'ar 7/12/1999 11:10'! name "Answer a String that is the name of the receiver." ^'a sublcass of ', superclass name! ! !Behavior methodsFor: 'accessing' stamp: 'ar 7/13/1999 22:00'! typeOfClass "Answer a symbol uniquely describing the type of the receiver" self instSpec = CompiledMethod instSpec ifTrue:[^#compiledMethod]. "Very special!!" self isBytes ifTrue:[^#bytes]. (self isWords and:[self isPointers not]) ifTrue:[^#words]. self isWeak ifTrue:[^#weak]. self isVariable ifTrue:[^#variable]. ^#normal.! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/15/1999 14:03'! autoMutateInstances "Return true if the receiver should automatically mutate its instances to a new class layout on recompilation." ^true! ! !Behavior methodsFor: 'testing' stamp: 'ar 9/10/1999 17:29'! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! isBehavior "Return true if the receiver is a behavior" ^true! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/14/1999 02:38'! isObsolete "Return true if the receiver is obsolete." ^self instanceCount = 0! ! !Behavior methodsFor: 'testing' stamp: 'ar 3/21/98 02:36'! isWeak "Answer whether the receiver has contains weak references." ^ self instSpec = 4! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/11/1999 05:36'! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(Smalltalk compactClassesArray includes: self) or:[(Smalltalk specialObjectsArray includes: self) or:[self isKindOf: self]]! ! !Behavior methodsFor: 'copying' stamp: 'di 2/17/2000 22:37'! copy "Answer a copy of the receiver without a list of subclasses." | myCopy | myCopy _ self shallowCopy. ^myCopy methodDictionary: self methodDict copy! ! !Behavior methodsFor: 'copying' stamp: 'di 2/17/2000 22:37'! copyOfMethodDictionary "Return a copy of the receiver's method dictionary" ^ self methodDict copy! ! !Behavior methodsFor: 'copying' stamp: 'tk 4/16/1999 17:30'! deepCopy "Classes should only be shallowCopied or made anew." ^ self shallowCopy! ! !Behavior methodsFor: 'creating class hierarchy' stamp: 'ar 7/10/1999 12:10'! superclass: aClass "Change the receiver's superclass to be aClass." "Note: Do not use 'aClass isKindOf: Behavior' here in case we recompile from Behavior itself." (aClass == nil or: [aClass isBehavior]) ifTrue: [superclass _ aClass. Object flushCache] ifFalse: [self error: 'superclass must be a class-describing object']! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'di 2/17/2000 22:41'! addSelector: selector withMethod: compiledMethod "Add the message selector with the corresponding compiled method to the receiver's method dictionary." | oldMethod | oldMethod _ self lookupSelector: selector. self methodDict at: selector put: compiledMethod. "Now flush Squeak's method cache, either by selector or by method" oldMethod == nil ifFalse: [oldMethod flushCache]. selector flushCache! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'jm 10/7/2002 05:49'! compileAllFrom: oldClass "Compile all the methods in the receiver's method dictionary. This validates sourceCode and variable references and forces all methods to use the current bytecode set." "ar 7/10/1999: Use oldClass selectors not self selectors" oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. ! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'di 2/17/2000 22:37'! compress "Compact the method dictionary of the receiver." self methodDict rehash! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ar 7/11/1999 05:11'! methodDictionary "Convenience" ^self methodDict! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'ar 7/12/1999 07:45'! methodDictionary: aDictionary "Store the argument, aDictionary, as the method dictionary of the receiver." methodDict _ aDictionary.! ! !Behavior methodsFor: 'creating method dictionary' stamp: 'di 5/24/2000 16:05'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method _ oldClass compiledMethodAt: selector. trailer _ (method endPC + 1 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' stamp: 'di 1/2/1999 15:16'! removeSelector: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." ^ self removeSelectorSimply: selector! ! !Behavior methodsFor: 'instance creation' stamp: 'di 8/18/2000 22:10'! basicNew: sizeRequested "Primitive. Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested. Fail if this class is not indexable or if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." self isVariable ifFalse: [self error: self printString, ' cannot have variable sized instances']. (sizeRequested isInteger and: [sizeRequested >= 0]) ifTrue: ["arg okay; space must be low." Smalltalk signalLowSpace. ^ self basicNew: sizeRequested "retry if user proceeds"]. self primitiveFailed! ! !Behavior methodsFor: 'instance creation' stamp: 'di 8/18/2000 20:27'! new "Answer a new instance of the receiver (which is a class) with no indexable variables. Fail if the class is indexable." "This method runs primitively if successful" ^ self basicNew "Exceptional conditions will be handled in basicNew" ! ! !Behavior methodsFor: 'instance creation' stamp: 'di 8/18/2000 20:32'! new: sizeRequested "Answer an instance of this class with the number of indexable variables specified by the argument, sizeRequested." "This method runs primitively if successful" ^ self basicNew: sizeRequested "Exceptional conditions will be handled in basicNew:" ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'bf 9/27/1999 17:23'! >> selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^self compiledMethodAt: selector ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sw 10/19/1999 15:12'! changeRecordsAt: selector "Return a list of ChangeRecords for all versions of the method at selector. Source code can be retrieved by sending string to any one. Return nil if the method is absent." "(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]" | aList | aList _ VersionsBrowser new scanVersionsOf: (self compiledMethodAt: selector ifAbsent: [^ nil]) class: self meta: self isMeta category: (self whichCategoryIncludesSelector: selector) selector: selector. ^ aList ifNotNil: [aList changeList]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:37'! compiledMethodAt: selector "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, create an error notification." ^ self methodDict at: selector! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'! compiledMethodAt: selector ifAbsent: aBlock "Answer the compiled method associated with the argument, selector (a Symbol), a message selector in the receiver's method dictionary. If the selector is not in the dictionary, return the value of aBlock" ^ self methodDict at: selector ifAbsent: [aBlock value]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'tk 4/26/1999 07:28'! formalParametersAt: aSelector "Return the names of the arguments used in this method." | source parser message list params | source _ self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" (parser _ self parserClass new) parseSelector: source. message _ source copyFrom: 1 to: (parser endOfLastToken min: source size). list _ message string findTokens: Character separators. params _ OrderedCollection new. list withIndexDo: [:token :ind | ind even ifTrue: [params addLast: token]]. ^ params! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'! lookupSelector: selector "Look up the given selector in my methodDictionary. Return the corresponding method if found. Otherwise chase the superclass chain and try again. Return nil if no method is found." | lookupClass | lookupClass _ self. [lookupClass == nil] whileFalse: [(lookupClass includesSelector: selector) ifTrue: [^ lookupClass compiledMethodAt: selector]. lookupClass _ lookupClass superclass]. ^ nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'! methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary." ^ self methodDict valuesDo: aBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 3/27/1999 23:21'! 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 _ self methodDict keyAtIdentityValue: 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' stamp: 'di 2/17/2000 22:38'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys "Point selectors."! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:41'! selectorsAndMethodsDo: aBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysAndValuesDo: aBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:38'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: selectorBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:40'! sourceCodeAt: selector ^ (self methodDict at: selector) getSourceFor: selector in: self! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 2/17/2000 22:40'! sourceCodeAt: selector ifAbsent: aBlock ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) getSourceFor: selector in: self! ! !Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'! includesBehavior: aClass ^self == aClass or:[self inheritsFrom: aClass]! ! !Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/21/98 02:36'! kindOfSubclass "Answer a String that is the keyword that describes the receiver's kind of subclass, either a regular subclass, a variableSubclass, a variableByteSubclass, a variableWordSubclass, or a weakSubclass" self isWeak ifTrue:[^' weakSubclass: ']. self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:40'! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^ self methodDict size > 0! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 3/27/1999 23:20'! includesSelector: aSymbol "Answer whether the message whose selector is the argument is in the method dictionary of the receiver's class." ^ self methodDict includesKey: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sma 6/3/2000 22:03'! 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 | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((method hasLiteralThorough: 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: sel]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:39'! 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." (self methodDict includesKey: aSymbol) ifTrue: [^ self]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol "Rectangle whichClassIncludesSelector: #inspect."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:40'! 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]. ^ self methodDict keys select: [:sel | ((self methodDict at: sel) readsField: instVarIndex) or: [(self methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ls 10/10/1999 13:22'! whichSelectorsReferTo: literal "Answer a Set of selectors whose methods access the argument as a literal." | special byte | special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:b | byte _ b]. ^self whichSelectorsReferTo: literal special: special byte: byte "Rectangle whichSelectorsReferTo: #+."! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sma 6/3/2000 22:01'! whichSelectorsReferTo: literal special: specialFlag byte: specialByte "Answer a set of selectors whose methods access the argument as a literal." | who | who _ Set new. self selectorsAndMethodsDo: [:sel :method | ((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: sel]]]. ^ who! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'di 2/17/2000 22:39'! 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]. ^ self methodDict keys select: [:sel | (self methodDict at: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! ! !Behavior methodsFor: 'enumerating' stamp: 'jm 5/18/2003 14:56'! allSubclassesDo: aBlock "Evaluate the given Block for each of my subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]. ! ! !Behavior methodsFor: 'enumerating' stamp: 'jm 5/18/2003 14:57'! withAllSubclassesDo: aBlock "Evaluate the the given Block for me and each of my subclasses." aBlock value: self. self allSubclassesDo: aBlock. ! ! !Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'! withAllSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." aBlock value: self. superclass == nil ifFalse: [superclass withAllSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'user interface' stamp: 'ls 10/10/1999 13:22'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." | aSortedCollection special byte | aSortedCollection _ SortedCollection new. special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:b | byte _ b ]. 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 4/4/2000 11:22'! allUnreferencedInstanceVariables "Return a list of the instance variables known to the receiver which are not referenced in the receiver or any of its subclasses OR superclasses" | any definingClass | ^ self allInstVarNames copy reject: [:ivn | any _ false. definingClass _ self classThatDefinesInstanceVariable: ivn. definingClass withAllSubclasses do: [:class | any ifFalse: [(class whichSelectorsAccess: ivn asSymbol) do: [:sel | sel ~~ #DoIt ifTrue: [any _ true]]]]. any]! ! !Behavior methodsFor: 'private' stamp: 'tk 12/29/1999 22:04'! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ 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' stamp: 'tk 1/10/2000 14:50'! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Squeak, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue:[^ self halt: 'You must not make a weak class compact']. cct _ Smalltalk compactClassesArray. (self indexIfCompact > 0 or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format _ format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'di 2/17/2000 22:38'! removeSelectorSimply: selector "Assuming that the argument, selector (a Symbol), is a message selector in my method dictionary, remove it and its method." | oldMethod | oldMethod _ self methodDict at: selector ifAbsent: [^ self]. self methodDict removeKey: selector. "Now flush Squeak's method cache, either by selector or by method" oldMethod flushCache. selector flushCache.! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! shutDown "This message is sent on system shutdown to registered classes" ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! shutDown: quitting "This message is sent on system shutdown to registered classes" ^self shutDown.! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! startUp "This message is sent to registered classes when the system is coming up." ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! startUp: resuming "This message is sent to registered classes when the system is coming up." ^self startUp! ! !Behavior class methodsFor: 'testing' stamp: 'ar 9/10/1999 17:28'! canZapMethodDictionary "Return false since zapping the method dictionary of Behavior class or its subclasses will cause the system to fail." ^false! ! I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm. The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm. If both are specified, their pixel values are combined with a logical AND function prior to transfer. In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule. The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows: 8: if source is 0 and destination is 0 4: if source is 0 and destination is 1 2: if source is 1 and destination is 0 1: if source is 1 and destination is 1. At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions; if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero. Forms may be of different depths, see the comment in class Form. In addition to the original 16 combination rules, this BitBlt supports 16 fails (to simulate paint bits) 17 fails (to simulate erase bits) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord. Sum of color components 21 rgbSub: sourceWord with: destinationWord. Difference of color components 22 OLDrgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 23 OLDtallyIntoMap: destinationWord. Tallies pixValues into a colorMap these old versions don't do bitwise dest clipping. Use 32 and 33 now. 24 alphaBlend: sourceWord with: destinationWord. 32-bit source and dest only 25 pixPaint: sourceWord with: destinationWord. Wherever the sourceForm is non-zero, it replaces the destination. Can be used with a 1-bit source color mapped to (0, FFFFFFFF), and a fillColor to fill the dest with that color wherever the source is 1. 26 pixMask: sourceWord with: destinationWord. Like pixPaint, but fills with 0. 27 rgbMax: sourceWord with: destinationWord. Max of each color component. 28 rgbMin: sourceWord with: destinationWord. Min of each color component. 29 rgbMin: sourceWord bitInvert32 with: destinationWord. Min with (max-source) 30 alphaBlendConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 31 alphaPaintConst: sourceWord with: destinationWord. alpha is an arg. works in 16 bits. 32 rgbDiff: sourceWord with: destinationWord. Sum of abs of differences in components 33 tallyIntoMap: destinationWord. Tallies pixValues into a colorMap 34 alphaBlendScaled: srcWord with: dstWord. Alpha blend of scaled srcWord and destWord. The color specified by halftoneForm may be either a Color or a Pattern. A Color is converted to a pixelValue for the depth of the destinationForm. If a Pattern, BitBlt will simply interpret its bitmap as an array of Color pixelValues. BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. Within each scan line the 32-bit value is repeated from left to right across the form. If the value repeats on pixels boudaries, the effect will be a constant color; if not, it will produce a halftone that repeats on 32-bit boundaries. Any transfer specified is further clipped by the specified rectangle (clipX, clipY, clipWidth, clipHeight), and also by the bounds of the source and destination forms. To make a small Form repeat and fill a big form, use an InfiniteForm as the source. To write on a form and leave with both transparent and opapue areas, use a MaskedForm as the source. Pixels from a source to a destination whose pixels have a different depth are converted based on the optional colorMap. If colorMap is nil, then conversion to more bits is done by filling the new high-order bits with zero, and conversion to fewer bits is done by truncating the lost high-order bits. The colorMap, if specified, must be a 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' stamp: 'ar 5/17/2000 18:58'! clipHeight ^clipHeight! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipWidth ^clipWidth! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipX ^clipX! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipY ^clipY! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:43'! colorMap: map "See last part of BitBlt comment. 6/18/96 tk" (map notNil and:[map isColormap]) ifTrue:[colorMap _ map colors] ifFalse:[colorMap _ map]! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'! tallyMap "Return the map used for tallying pixels" ^colorMap! ! !BitBlt methodsFor: 'accessing' stamp: 'ar 5/25/2000 19:39'! tallyMap: aBitmap "Install the map used for tallying pixels" colorMap _ aBitmap! ! !BitBlt methodsFor: 'copying' stamp: 'di 12/26/1998 15:04'! copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule "Specify a Color to fill, not a Form. 6/18/96 tk" | destOrigin | sourceForm _ srcForm. self fillColor: hf. "sets halftoneForm" combinationRule _ rule. destOrigin _ destRectangle origin. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourcePt x. sourceY _ sourcePt y. width _ destRectangle width. height _ destRectangle height. srcForm == nil ifFalse: [colorMap _ srcForm colormapIfNeededForDepth: destForm depth]. ^ self copyBits! ! !BitBlt methodsFor: 'copying' stamp: 'di 12/31/1998 14:38'! copyBits "Primitive. Perform the movement of bits from the source form to the destination form. Fail if any variables are not of the right type (Integer, Float, or Form) or if the combination rule is not implemented. In addition to the original 16 combination rules, this BitBlt supports 16 fail (to simulate paint) 17 fail (to simulate mask) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 rgbDiff: sourceWord with: destinationWord 23 tallyIntoMap: destinationWord 24 alphaBlend: sourceWord with: destinationWord 25 pixPaint: sourceWord with: destinationWord 26 pixMask: sourceWord with: destinationWord 27 rgbMax: sourceWord with: destinationWord 28 rgbMin: sourceWord with: destinationWord 29 rgbMin: sourceWord bitInvert32 with: destinationWord " "Check for compressed source, destination or halftone forms" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: ["No alpha specified -- re-run with alpha = 1.0" ^ self copyBitsTranslucent: 255]. ((sourceForm 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 error: '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 1/4/1999 01:14'! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." "Check for compressed source, destination or halftone forms" ((sourceForm isKindOf: Form) and: [sourceForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((destForm isKindOf: Form) and: [destForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate]) ifTrue: [^ self copyBitsTranslucent: factor]. self primitiveFailed "Later do nicer error recovery -- share copyBits recovery"! ! !BitBlt methodsFor: 'copying' stamp: 'ar 5/19/2000 15:08'! displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: font kern: kernDelta destY _ aPoint y. destX _ aPoint x. ^self primDisplayString: aString from: startIndex to: stopIndex map: font characterToGlyphMap xTable: font xTable kern: kernDelta.! ! !BitBlt methodsFor: 'private' stamp: 'ar 10/25/1998 17:30'! copyBitsFrom: x0 to: x1 at: y destX _ x0. destY _ y. sourceX _ x0. width _ (x1 - x0). self copyBits.! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/23/2000 15:27'! installStrikeFont: aStrikeFont foregroundColor: foregroundColor backgroundColor: backgroundColor | lastSourceDepth | sourceForm ifNotNil:[lastSourceDepth _ sourceForm depth]. sourceForm _ aStrikeFont glyphs. (colorMap notNil and:[lastSourceDepth = sourceForm depth]) ifFalse: ["Set up color map for a different source depth (color font)" "Note this may need some caching for reasonable efficiency" colorMap _ (Color cachedColormapFrom: sourceForm depth to: destForm depth) copy. colorMap at: 1 put: (backgroundColor pixelValueForDepth: destForm depth)]. sourceForm depth = 1 ifTrue: [colorMap at: 2 put: (foregroundColor pixelValueForDepth: destForm depth). "Ignore any halftone pattern since we use a color map approach here" halftoneForm _ nil]. sourceY _ 0. height _ aStrikeFont height. ! ! !BitBlt methodsFor: 'private' stamp: 'ar 5/18/2000 21:49'! primDisplayString: aString from: startIndex to: stopIndex map: glyphMap xTable: xTable kern: kernDelta | ascii glyph | startIndex to: stopIndex do:[:charIndex| ascii _ (aString at: charIndex) asciiValue. glyph _ glyphMap at: ascii + 1. sourceX _ xTable at: glyph + 1. width _ (xTable at: glyph + 2) - sourceX. self copyBits. destX _ destX + width + kernDelta. ].! ! !BitBlt methodsFor: 'private' stamp: 'di 9/11/1998 13:07'! setDestForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect | aPoint | destForm _ df. sourceForm _ sf. self fillColor: hf. "sets halftoneForm" combinationRule _ cr. destX _ destOrigin x. destY _ destOrigin y. sourceX _ sourceOrigin x. sourceY _ sourceOrigin y. width _ extent x. height _ extent y. aPoint _ clipRect origin. clipX _ aPoint x. clipY _ aPoint y. aPoint _ clipRect corner. clipWidth _ aPoint x - clipX. clipHeight _ aPoint y - clipY. sourceForm == nil ifFalse: [colorMap _ sourceForm colormapIfNeededForDepth: destForm depth]! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 10/28/1999 23:38'! benchDiffsFrom: before to: afterwards "Given two outputs of BitBlt>>benchmark show the relative improvements." | old new log oldLine newLine oldVal newVal improvement | log _ WriteStream on: String new. old _ ReadStream on: before. new _ ReadStream on: afterwards. [old atEnd or:[new atEnd]] whileFalse:[ oldLine _ old upTo: Character cr. newLine _ new upTo: Character cr. (oldLine includes: Character tab) ifTrue:[ oldLine _ ReadStream on: oldLine. newLine _ ReadStream on: newLine. Transcript cr; show: (oldLine upTo: Character tab); tab. log cr; nextPutAll: (newLine upTo: Character tab); tab. [oldLine skipSeparators. newLine skipSeparators. oldLine atEnd] whileFalse:[ oldVal _ Integer readFrom: oldLine. newVal _ Integer readFrom: newLine. improvement _ oldVal asFloat / newVal asFloat roundTo: 0.1. Transcript show: improvement printString; tab. log print: improvement; tab]. ] ifFalse:[ Transcript cr; show: oldLine. log cr; nextPutAll: oldLine. ]. ]. ^log contents! ! !BitBlt class methodsFor: 'benchmarks' stamp: 'ar 5/25/2000 17:58'! benchmark "BitBlt benchmark" "Run a benchmark on different combinations rules, source/destination depths and BitBlt modes. Note: This benchmark doesn't give you any 'absolute' value - it is intended only for benchmarking improvements in the bitblt code and nothing else. Attention: *this*may*take*a*while*" | bb source dest destRect log t | log _ WriteStream on: String new. destRect _ 0@0 extent: 600@600. "Form paint/Form over - the most common rules" #( 25 3 ) do:[:rule| Transcript cr; show:'---- Combination rule: ', rule printString,' ----'. log cr; nextPutAll:'---- Combination rule: ', rule printString,' ----'. #(1 2 4 8 16 32) do:[:destDepth| dest _ nil. dest _ Form extent: destRect extent depth: destDepth. Transcript cr. log cr. #(1 2 4 8 16 32) do:[:sourceDepth| Transcript cr; show: sourceDepth printString, ' => ', destDepth printString. log cr; nextPutAll: sourceDepth printString, ' => ', destDepth printString. source _ nil. bb _ nil. source _ Form extent: destRect extent depth: sourceDepth. (source getCanvas) fillOval: dest boundingBox color: Color yellow borderWidth: 30 borderColor: Color black. bb _ WarpBlt toForm: dest. bb sourceForm: source. bb sourceRect: source boundingBox. bb destRect: dest boundingBox. bb colorMap: (source colormapIfNeededForDepth: dest depth). bb combinationRule: rule. "Measure speed of copyBits" t _ Time millisecondsToRun:[bb copyBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. bb sourceForm: source destRect: source boundingBox. "Measure speed of 1x1 warpBits" bb cellSize: 1. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 2x2 warpBits" bb cellSize: 2. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. "Measure speed of 3x3 warpBits" bb cellSize: 3. t _ Time millisecondsToRun:[bb warpBits]. Transcript tab; show: t printString. log tab; nextPutAll: t printString. ]. ]. ]. ^log contents! ! 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 (for old paint mode) 17 fail (for old mask mode) 18 sourceWord + destinationWord 19 sourceWord - destinationWord 20 rgbAdd: sourceWord with: destinationWord 21 rgbSub: sourceWord with: destinationWord 22 OLDrgbDiff: sourceWord with: destinationWord 23 OLDtallyIntoMap: destinationWord -- old vers doesn't clip to bit boundary 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 30 alphaBlendConst: sourceWord with: destinationWord -- alpha passed as an arg 31 alphaPaintConst: sourceWord with: destinationWord -- alpha passed as an arg 32 rgbDiff: sourceWord with: destinationWord 33 tallyIntoMap: destinationWord 34 alphaBlendScaled: sourceWord 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. To add a new rule to BitBlt... 1. add the new rule method or methods in the category 'combination rules' of BBSim 2. describe it in the class comment of BBSim and in the class comment for BitBlt 3. add refs to initializeRuleTable in proper positions 4. add refs to initBBOpTable, following the pattern ! !BitBltSimulation methodsFor: 'interpreter interface' stamp: 'jm 1/3/2004 12:00'! 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 * dy1. py _ xDelta * dx1. 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' stamp: 'ar 10/31/1998 22:05'! 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 > (OpTableSize - 2)]]) 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: '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' stamp: 'di 6/29/1998 12:19'! 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: [(dy = sy) & (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' stamp: 'ar 10/31/1998 20:50'! copyBits | done | self clipRange. (bbW <= 0 or: [bbH <= 0]) ifTrue: ["zero width or height; noop" affectedL _ affectedR _ affectedT _ affectedB _ 0. ^ nil]. "Try a shortcut for stuff that should be run as quickly as possible" done _ self tryCopyingBitsQuickly. done ifTrue:[^nil]. self destMaskAndPointerInit. bitCount _ 0. (combinationRule = 30) | (combinationRule = 31) ifTrue: ["Check and fetch source alpha parameter for alpha blend" interpreterProxy argCount = 1 ifTrue: [sourceAlpha _ interpreterProxy stackIntegerValue: 0. (interpreterProxy failed not and: [(sourceAlpha >= 0) & (sourceAlpha <= 255)]) ifTrue: [interpreterProxy pop: 1] ifFalse: [^ interpreterProxy primitiveFail]] ifFalse: [^ interpreterProxy primitiveFail]]. noSource ifTrue: [self copyLoopNoSource] ifFalse: [self checkSourceOverlap. (sourcePixSize ~= destPixSize or: [colorMap ~= interpreterProxy nilObject]) ifTrue: [self copyLoopPixMap] ifFalse: [self sourceSkewAndPointerInit. self copyLoop]]. (combinationRule = 22) | (combinationRule = 32) 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' stamp: 'ar 11/11/1998 22:29'! copyBitsFrom: startX to: stopX at: yValue "Support for the balloon engine." destX _ startX. destY _ yValue. sourceX _ startX. width _ (stopX - startX). self copyBits. ! ! !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' stamp: 'ar 11/14/1998 00:44'! tryCopyingBitsQuickly "Shortcut for stuff that's being run from the balloon engine. Since we do this at each scan line we should avoid the expensive setup for source and destination." self inline: true. "We need a source." noSource ifTrue:[^false]. "We handle only combinationRule 34" (combinationRule = 34) ifFalse:[^false]. "We handle only sourcePixSize 32" (sourcePixSize = 32) ifFalse:[^false]. "We don't handle overlaps" (sourceForm = destForm) ifTrue:[^false]. "We need at least 8bit deep dest forms" (destPixSize < 8) ifTrue:[^false]. "If 8bit, then we want a color map" (destPixSize = 8 and:[colorMap = interpreterProxy nilObject]) ifTrue:[^false]. destPixSize = 32 ifTrue:[self alphaSourceBlendBits32]. destPixSize = 16 ifTrue:[self alphaSourceBlendBits16]. destPixSize = 8 ifTrue:[self alphaSourceBlendBits8]. affectedL _ dx. affectedR _ dx + bbW. affectedT _ dy. affectedB _ dy + bbH. ^true! ! !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: 'ar 11/15/1998 02:37'! alphaSourceBlendBits16 "This version assumes combinationRule = 34 sourcePixSize = 32 destPixSize = 16 sourceForm ~= destForm. " | srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY dstMask srcShift adjust | self inline: false. "This particular method should be optimized in itself" deltaY _ bbH + 1. "So we can pre-decrement" srcY _ sy. dstY _ dy. (dx bitAnd: 1) = 0 ifTrue:[ mask1 _ 16r0000FFFF. srcShift _ 16. adjust _ 0] ifFalse:[mask1 _ 16rFFFF0000. srcShift _ 0. adjust _ 16r0F0F0F0F]. (dy bitAnd: 1) = 0 ifTrue:[adjust _ adjust bitXor: 16r0F0F0F0F]. "This is the outer loop" [(deltaY _ deltaY - 1) ~= 0] whileTrue:[ adjust _ adjust bitXor: 16r0F0F0F0F. srcIndex _ (sourceBits + 4) + ((srcY * sourceRaster + sx) * 4). dstIndex _ (destBits + 4) + ((dstY * destRaster + (dx // 2)) * 4). deltaX _ bbW + 1. "So we can pre-decrement" dstMask _ mask1. "This is the inner loop" [(deltaX _ deltaX - 1) ~= 0] whileTrue:[ sourceWord _ ((interpreterProxy longAt: srcIndex) bitAnd: (adjust bitInvert32)) + adjust. srcAlpha _ sourceWord >> 24. "Treat srcAlpha >= 240 as opaque" srcAlpha = 240 ifTrue:[ sourceWord _ self rgbMap: sourceWord from: 8 to: 5. sourceWord _ sourceWord << srcShift. destWord _ interpreterProxy longAt: dstIndex. destWord _ destWord bitAnd: dstMask. interpreterProxy longAt: dstIndex put: (sourceWord bitOr: destWord). ] ifFalse:[ "srcAlpha ~= 255" srcAlpha <= 15 ifTrue:[ "Treat srcAlpha <= 15 as transparent" ] ifFalse:[ "0 < srcAlpha < 255" "If we have to mix colors then just copy a single word" destWord _ interpreterProxy longAt: dstIndex. destWord _ destWord bitAnd: dstMask bitInvert32. destWord _ destWord >> srcShift. destWord _ self rgbMap: destWord from: 5 to: 8. destWord _ destWord bitOr: 16rFF000000. sourceWord _ self alphaBlendScaled: sourceWord with: destWord. sourceWord _ self rgbMap: sourceWord from: 8 to: 5. sourceWord _ sourceWord << srcShift. destWord _ interpreterProxy longAt: dstIndex. destWord _ destWord bitAnd: dstMask. interpreterProxy longAt: dstIndex put: (sourceWord bitOr: destWord). ]. ]. srcIndex _ srcIndex + 4. srcShift = 0 ifTrue:[dstIndex _ dstIndex + 4]. srcShift _ srcShift bitXor: 16. "Toggle between 0 and 16" dstMask _ dstMask bitInvert32. "Mask other half word" adjust _ adjust bitXor: 16r0F0F0F0F. ]. srcY _ srcY + 1. dstY _ dstY + 1. ].! ! !BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 11/2/1998 02:20'! alphaSourceBlendBits32 "This version assumes combinationRule = 34 sourcePixSize = destPixSize = 32 sourceForm ~= destForm. Note: The inner loop has been optimized for dealing with the special cases of srcAlpha = 0.0 and srcAlpha = 1.0 " | srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY | self inline: false. "This particular method should be optimized in itself" "Give the compile a couple of hints" self var: #sourceWord declareC:'register int sourceWord'. self var: #deltaX declareC:'register int deltaX'. "The following should be declared as pointers so the compiler will notice that they're used for accessing memory locations (good to know on an Intel architecture) but then the increments would be different between ST code and C code so must hope the compiler notices what happens (MS Visual C does)" self var: #srcIndex declareC:'register int srcIndex'. self var: #dstIndex declareC:'register int dstIndex'. deltaY _ bbH + 1. "So we can pre-decrement" srcY _ sy. dstY _ dy. "This is the outer loop" [(deltaY _ deltaY - 1) ~= 0] whileTrue:[ srcIndex _ (sourceBits + 4) + ((srcY * sourceRaster + sx) * 4). dstIndex _ (destBits + 4) + ((dstY * destRaster + dx) * 4). deltaX _ bbW + 1. "So we can pre-decrement" "This is the inner loop" [(deltaX _ deltaX - 1) ~= 0] whileTrue:[ sourceWord _ interpreterProxy longAt: srcIndex. srcAlpha _ sourceWord >> 24. srcAlpha = 255 ifTrue:[ interpreterProxy longAt: dstIndex put: sourceWord. srcIndex _ srcIndex + 4. dstIndex _ dstIndex + 4. "Now copy as many words as possible with alpha = 255" [(deltaX _ deltaX - 1) ~= 0 and:[ (sourceWord _ interpreterProxy longAt: srcIndex) >> 24 = 255]] whileTrue:[ interpreterProxy longAt: dstIndex put: sourceWord. srcIndex _ srcIndex + 4. dstIndex _ dstIndex + 4. ]. "Adjust deltaX" deltaX _ deltaX + 1. ] ifFalse:[ "srcAlpha ~= 255" srcAlpha = 0 ifTrue:[ srcIndex _ srcIndex + 4. dstIndex _ dstIndex + 4. "Now skip as many words as possible," [(deltaX _ deltaX - 1) ~= 0 and:[ (sourceWord _ interpreterProxy longAt: srcIndex) >> 24 = 0]] whileTrue:[ srcIndex _ srcIndex + 4. dstIndex _ dstIndex + 4. ]. "Adjust deltaX" deltaX _ deltaX + 1. ] ifFalse:[ "0 < srcAlpha < 255" "If we have to mix colors then just copy a single word" destWord _ interpreterProxy longAt: dstIndex. destWord _ self alphaBlendScaled: sourceWord with: destWord. interpreterProxy longAt: dstIndex put: destWord. srcIndex _ srcIndex + 4. dstIndex _ dstIndex + 4. ]. ]. ]. srcY _ srcY + 1. dstY _ dstY + 1. ].! ! !BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 11/15/1998 02:56'! alphaSourceBlendBits8 "This version assumes combinationRule = 34 sourcePixSize = 32 destPixSize = 8 sourceForm ~= destForm. Note: This is not real blending since we don't have the source colors available. " | srcIndex dstIndex sourceWord srcAlpha destWord deltaX deltaY srcY dstY dstMask srcShift adjust mappingTable | self inline: false. "This particular method should be optimized in itself" self var: #mappingTable declareC:'unsigned int *mappingTable'. mappingTable _ self default8To32Table. deltaY _ bbH + 1. "So we can pre-decrement" srcY _ sy. dstY _ dy. mask1 _ 24 - ((dx bitAnd: 3) * 8). mask2 _ AllOnes bitXor:(16rFF << mask1). (dx bitAnd: 1) = 0 ifTrue:[adjust _ 0] ifFalse:[adjust _ 16r1F1F1F1F]. (dy bitAnd: 1) = 0 ifTrue:[adjust _ adjust bitXor: 16r1F1F1F1F]. "This is the outer loop" [(deltaY _ deltaY - 1) ~= 0] whileTrue:[ adjust _ adjust bitXor: 16r1F1F1F1F. srcIndex _ (sourceBits + 4) + ((srcY * sourceRaster + sx) * 4). dstIndex _ (destBits + 4) + ((dstY * destRaster + (dx // 4)) * 4). deltaX _ bbW + 1. "So we can pre-decrement" srcShift _ mask1. dstMask _ mask2. "This is the inner loop" [(deltaX _ deltaX - 1) ~= 0] whileTrue:[ sourceWord _ ((interpreterProxy longAt: srcIndex) bitAnd: (adjust bitInvert32)) + adjust. srcAlpha _ sourceWord >> 24. srcAlpha > 31 ifTrue:["Everything below 31 is transparent" srcAlpha < 224 ifTrue:["Everything above 224 is opaque" destWord _ interpreterProxy longAt: dstIndex. destWord _ destWord bitAnd: dstMask bitInvert32. destWord _ destWord >> srcShift. destWord _ mappingTable at: destWord. sourceWord _ self alphaBlendScaled: sourceWord with: destWord. ]. sourceWord _ self rgbMap: sourceWord from: 8 to: cmBitsPerColor. sourceWord _ interpreterProxy fetchWord: sourceWord ofObject: colorMap. sourceWord _ sourceWord << srcShift. destWord _ interpreterProxy longAt: dstIndex. destWord _ destWord bitAnd: dstMask. interpreterProxy longAt: dstIndex put: (sourceWord bitOr: destWord). ]. srcIndex _ srcIndex + 4. srcShift = 0 ifTrue:[ dstIndex _ dstIndex + 4. srcShift _ 24. dstMask _ 16r00FFFFFF. ] ifFalse:[ srcShift _ srcShift - 8. dstMask _ (dstMask >> 8) bitOr: 16rFF000000. ]. adjust _ adjust bitXor: 16r1F1F1F1F. ]. srcY _ srcY + 1. dstY _ dstY + 1. ].! ! !BitBltSimulation methodsFor: 'inner loop' stamp: 'di 6/29/1998 12:27'! 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..." destMask _ mask1. thisWord _ interpreterProxy longAt: sourceIndex. "pick up next word" sourceIndex _ sourceIndex + hInc. skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew) bitOr: "32-bit rotate" ((thisWord bitAnd: skewMask) bitShift: skew). prevWord _ thisWord. mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord) with: (interpreterProxy longAt: destIndex). interpreterProxy longAt: destIndex put: ((destMask bitAnd: mergeWord) bitOr: (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))). destIndex _ destIndex + hInc. "This central horizontal loop requires no store masking" destMask _ AllOnes. combinationRule = 3 ifTrue: [noHalftone & (notSkewMask = 0) ifTrue: ["Very special inner loop for STORE mode with no skew -- just move words" 2 to: nWords-1 do: [ :word | thisWord _ interpreterProxy longAt: sourceIndex. sourceIndex _ sourceIndex + hInc. interpreterProxy longAt: destIndex put: thisWord. destIndex _ destIndex + hInc]] ifFalse: ["Special inner loop for STORE mode -- no need to call merge" 2 to: nWords-1 do: [ :word | thisWord _ interpreterProxy longAt: sourceIndex. sourceIndex _ sourceIndex + hInc. skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew) bitOr: "32-bit rotate" ((thisWord bitAnd: skewMask) bitShift: skew). prevWord _ thisWord. 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" sourceIndex _ sourceIndex + hInc. skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew) bitOr: "32-bit rotate" ((thisWord bitAnd: skewMask) bitShift: skew). prevWord _ thisWord. 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: [destMask _ mask2. thisWord _ interpreterProxy longAt: sourceIndex. "pick up next word" sourceIndex _ sourceIndex + hInc. skewWord _ ((prevWord bitAnd: notSkewMask) bitShift: unskew) bitOr: "32-bit rotate" ((thisWord bitAnd: skewMask) bitShift: skew). mergeWord _ self mergeFn: (skewWord bitAnd: halftoneWord) with: (interpreterProxy longAt: destIndex). interpreterProxy longAt: destIndex put: ((destMask bitAnd: mergeWord) bitOr: (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))). destIndex _ destIndex + hInc]. sourceIndex _ sourceIndex + sourceDelta. destIndex _ destIndex + destDelta]! ! !BitBltSimulation methodsFor: 'inner loop' stamp: 'di 6/8/1998 18:05'! 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..." destMask _ mask1. mergeWord _ self mergeFn: halftoneWord with: (interpreterProxy longAt: destIndex). interpreterProxy longAt: destIndex put: ((destMask bitAnd: mergeWord) bitOr: (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))). destIndex _ destIndex + 4. "This central horizontal loop requires no store masking" destMask _ AllOnes. 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: [destMask _ mask2. mergeWord _ self mergeFn: halftoneWord with: (interpreterProxy longAt: destIndex). interpreterProxy longAt: destIndex put: ((destMask bitAnd: mergeWord) bitOr: (destMask bitInvert32 bitAnd: (interpreterProxy longAt: destIndex))). destIndex _ destIndex + 4]. destIndex _ destIndex + destDelta]! ! !BitBltSimulation methodsFor: 'inner loop' stamp: 'ar 12/7/1998 21:12'! 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 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. sourcePixMask _ maskTable at: sourcePixSize. destPixMask _ maskTable at: destPixSize. 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' stamp: 'di 6/8/1998 17:44'! warpLoop | skewWord halftoneWord mergeWord 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' stamp: 'ar 12/7/1998 21:11'! OLDrgbDiff: 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 _ maskTable at: destPixSize. [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' stamp: 'ar 12/7/1998 21:33'! OLDtallyIntoMap: 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 _ maskTable at: destPixSize. shiftWord _ destinationWord. 1 to: pixPerWord do: [:i | mapIndex _ shiftWord bitAnd: pixMask. interpreterProxy storeWord: mapIndex ofObject: colorMap withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1. shiftWord _ shiftWord >> destPixSize]. ^ destinationWord]. destPixSize = 16 ifTrue: ["Two pixels Tally the right half..." mapIndex _ self rgbMap: (destinationWord bitAnd: 16rFFFF) from: 5 to: cmBitsPerColor. interpreterProxy storeWord: mapIndex ofObject: colorMap withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1. "... and then left half" mapIndex _ self rgbMap: destinationWord>>16 from: 5 to: cmBitsPerColor. interpreterProxy storeWord: mapIndex ofObject: colorMap withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1] ifFalse: ["Just one pixel." mapIndex _ self rgbMap: destinationWord from: 8 to: cmBitsPerColor. interpreterProxy storeWord: mapIndex ofObject: colorMap withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1]. ^ destinationWord "For no effect on dest"! ! !BitBltSimulation methodsFor: '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<>shift bitAnd: rgbMask) * sourceAlpha) + ((destPixVal>>shift bitAnd: rgbMask) * unAlpha)) + 254 // 255 bitAnd: rgbMask. pixBlend _ pixBlend bitOr: blend<> destPixSize. sourceShifted _ sourceShifted >> destPixSize. destShifted _ destShifted >> destPixSize]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 11/27/1998 23:56'! alphaBlendScaled: sourceWord with: destinationWord "Blend sourceWord with destinationWord using the alpha value from sourceWord. Alpha is encoded as 0 meaning 0.0, and 255 meaning 1.0. In contrast to alphaBlend:with: the color produced is srcColor + (1-srcAlpha) * dstColor e.g., it is assumed that the source color is already scaled." | unAlpha dstMask srcMask b g r a | self inline: false. "Do NOT inline this into optimized loops" unAlpha _ 255 - (sourceWord >> 24). "High 8 bits of source pixel" dstMask _ destinationWord. srcMask _ sourceWord. b _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255). b > 255 ifTrue:[b _ 255]. dstMask _ dstMask >> 8. srcMask _ srcMask >> 8. g _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255). g > 255 ifTrue:[g _ 255]. dstMask _ dstMask >> 8. srcMask _ srcMask >> 8. r _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255). r > 255 ifTrue:[r _ 255]. dstMask _ dstMask >> 8. srcMask _ srcMask >> 8. a _ (dstMask bitAnd: 255) * unAlpha >> 8 + (srcMask bitAnd: 255). a > 255 ifTrue:[a _ 255]. ^(((((a << 8) + r) << 8) + g) << 8) + b! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'di 6/29/1998 19:56'! alphaPaintConst: sourceWord with: destinationWord sourceWord = 0 ifTrue: [^ destinationWord "opt for all-transparent source"]. ^ self alphaBlendConst: sourceWord with: destinationWord paintMode: true! ! !BitBltSimulation methodsFor: 'combination rules'! bitAnd: sourceWord with: destinationWord ^sourceWord bitAnd: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! bitAndInvert: sourceWord with: destinationWord ^sourceWord bitAnd: destinationWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertAnd: sourceWord with: destinationWord ^sourceWord bitInvert32 bitAnd: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertAndInvert: sourceWord with: destinationWord ^sourceWord bitInvert32 bitAnd: destinationWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertDestination: sourceWord with: destinationWord ^destinationWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertOr: sourceWord with: destinationWord ^sourceWord bitInvert32 bitOr: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertOrInvert: sourceWord with: destinationWord ^sourceWord bitInvert32 bitOr: destinationWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertSource: sourceWord with: destinationWord ^sourceWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitInvertXor: sourceWord with: destinationWord ^sourceWord bitInvert32 bitXor: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! bitOr: sourceWord with: destinationWord ^sourceWord bitOr: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! bitOrInvert: sourceWord with: destinationWord ^sourceWord bitOr: destinationWord bitInvert32! ! !BitBltSimulation methodsFor: 'combination rules'! bitXor: sourceWord with: destinationWord ^sourceWord bitXor: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules'! clearWord: source with: destination ^ 0! ! !BitBltSimulation methodsFor: 'combination rules'! destinationWord: sourceWord with: destinationWord ^destinationWord! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/30/97 14:46'! merge: sourceWord with: destinationWord | mergeFnwith | "Sender warpLoop is too big to include this in-line" self var: #mergeFnwith declareC: 'int (*mergeFnwith)(int, int)'. mergeFnwith _ self cCoerce: (opTable at: combinationRule+1) to: 'int (*)(int, int)'. mergeFnwith. "null ref for compiler" ^ self mergeFn: sourceWord with: destinationWord! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:18'! partitionedAND: word1 to: word2 nBits: nBits nPartitions: nParts "AND word1 to word2 as nParts partitions of nBits each. Any field of word1 not all-ones is treated as all-zeroes. Used for erasing, eg, brush shapes prior to ORing in a color" | mask result | mask _ maskTable at: nBits. "partition mask starts at the right" result _ 0. 1 to: nParts do: [:i | (word1 bitAnd: mask) = mask ifTrue: [result _ result bitOr: (word2 bitAnd: mask)]. mask _ mask << nBits "slide left to next partition"]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:35'! partitionedAdd: word1 to: word2 nBits: nBits nPartitions: nParts "Add word1 to word2 as nParts partitions of nBits each. This is useful for packed pixels, or packed colors" | mask sum result | mask _ maskTable at: nBits. "partition mask starts at the right" result _ 0. 1 to: nParts do: [:i | sum _ (word1 bitAnd: mask) + (word2 bitAnd: mask). sum <= mask "result must not carry out of partition" ifTrue: [result _ result bitOr: sum] ifFalse: [result _ result bitOr: mask]. mask _ mask << nBits "slide left to next partition"]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:35'! partitionedMax: word1 with: word2 nBits: nBits nPartitions: nParts "Max word1 to word2 as nParts partitions of nBits each" | mask result | mask _ maskTable at: nBits. "partition mask starts at the right" result _ 0. 1 to: nParts do: [:i | result _ result bitOr: ((word2 bitAnd: mask) max: (word1 bitAnd: mask)). mask _ mask << nBits "slide left to next partition"]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:35'! partitionedMin: word1 with: word2 nBits: nBits nPartitions: nParts "Min word1 to word2 as nParts partitions of nBits each" | mask result | mask _ maskTable at: nBits. "partition mask starts at the right" result _ 0. 1 to: nParts do: [:i | result _ result bitOr: ((word2 bitAnd: mask) min: (word1 bitAnd: mask)). mask _ mask << nBits "slide left to next partition"]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:36'! partitionedSub: word1 from: word2 nBits: nBits nPartitions: nParts "Subtract word1 from word2 as nParts partitions of nBits each. This is useful for packed pixels, or packed colors" | mask result p1 p2 | mask _ maskTable at: nBits. "partition mask starts at the right" result _ 0. 1 to: nParts do: [:i | p1 _ word1 bitAnd: mask. p2 _ word2 bitAnd: mask. p1 < p2 "result is really abs value of thedifference" ifTrue: [result _ result bitOr: p2 - p1] ifFalse: [result _ result bitOr: p1 - p2]. mask _ mask << nBits "slide left to next partition"]. ^ result ! ! !BitBltSimulation methodsFor: 'combination rules'! pixMask: sourceWord with: destinationWord self inline: false. ^ self partitionedAND: sourceWord bitInvert32 to: destinationWord nBits: destPixSize nPartitions: pixPerWord! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'di 12/27/97 10:39'! pixPaint: sourceWord with: destinationWord self inline: false. sourceWord = 0 ifTrue: [^ destinationWord]. ^ sourceWord bitOr: (self partitionedAND: sourceWord bitInvert32 to: destinationWord nBits: destPixSize nPartitions: pixPerWord)! ! !BitBltSimulation methodsFor: 'combination rules'! rgbAdd: sourceWord with: destinationWord self inline: false. destPixSize < 16 ifTrue: ["Add each pixel separately" ^ self partitionedAdd: sourceWord to: destinationWord nBits: destPixSize nPartitions: pixPerWord]. destPixSize = 16 ifTrue: ["Add RGB components of each pixel separately" ^ (self partitionedAdd: sourceWord to: destinationWord nBits: 5 nPartitions: 3) + ((self partitionedAdd: sourceWord>>16 to: destinationWord>>16 nBits: 5 nPartitions: 3) << 16)] ifFalse: ["Add RGB components of the pixel separately" ^ self partitionedAdd: sourceWord to: destinationWord nBits: 8 nPartitions: 3]! ! !BitBltSimulation methodsFor: 'combination rules' stamp: 'ar 12/7/1998 21:12'! 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, return the number of differing pixels." | pixMask destShifted sourceShifted destPixVal bitsPerColor rgbMask sourcePixVal diff maskShifted | self inline: false. pixMask _ maskTable at: destPixSize. destPixSize = 16 ifTrue: [bitsPerColor _ 5. rgbMask _ 16r1F] ifFalse: [bitsPerColor _ 8. rgbMask _ 16rFF]. maskShifted _ destMask. destShifted _ destinationWord. sourceShifted _ sourceWord. 1 to: pixPerWord do: [:i | (maskShifted bitAnd: pixMask) > 0 ifTrue: ["Only tally pixels within the destination rectangle" destPixVal _ destShifted bitAnd: pixMask. sourcePixVal _ sourceShifted bitAnd: pixMask. destPixSize < 16 ifTrue: [sourcePixVal = destPixVal ifTrue: [diff _ 0] ifFalse: [diff _ 1]] ifFalse: [diff _ (self partitionedSub: sourcePixVal from: destPixVal nBits: bitsPerColor nPartitions: 3). diff _ (diff bitAnd: rgbMask) + (diff>>bitsPerColor bitAnd: rgbMask) + ((diff>>bitsPerColor)>>bitsPerColor bitAnd: rgbMask)]. bitCount _ bitCount + diff]. maskShifted _ maskShifted >> destPixSize. sourceShifted _ sourceShifted >> destPixSize. destShifted _ destShifted >> destPixSize]. ^ 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: 'ar 12/7/1998 22:27'! tallyIntoMap: sourceWord with: destinationWord "Tally pixels into the color map. Those tallied are exactly those in the destination rectangle. Note that the source should be specified == destination, in order for the proper color map checks to be performed at setup." | mapIndex pixMask destShifted maskShifted pixVal | self inline: false. colorMap = interpreterProxy nilObject ifTrue: [^ destinationWord "no op"]. pixMask _ maskTable at: destPixSize. destShifted _ destinationWord. maskShifted _ destMask. 1 to: pixPerWord do: [:i | (maskShifted bitAnd: pixMask) = 0 ifFalse: ["Only tally pixels within the destination rectangle" pixVal _ destShifted bitAnd: pixMask. destPixSize < 16 ifTrue: [mapIndex _ pixVal] ifFalse: [destPixSize = 16 ifTrue: [mapIndex _ self rgbMap: pixVal from: 5 to: cmBitsPerColor] ifFalse: [mapIndex _ self rgbMap: pixVal from: 8 to: cmBitsPerColor]]. interpreterProxy storeWord: mapIndex ofObject: colorMap withValue: (interpreterProxy fetchWord: mapIndex ofObject: colorMap) + 1]. maskShifted _ maskShifted >> destPixSize. destShifted _ destShifted >> destPixSize]. ^ destinationWord "For no effect on dest"! ! !BitBltSimulation methodsFor: 'pixel mapping' stamp: 'ar 11/16/1998 00:23'! default8To32Table "Return the default translation table from 1..8 bit indexed colors to 32bit" "The table has been generated by the following statements" "| pvs hex | String streamContents:[:s| s nextPutAll:'static unsigned int theTable[256] = { '. pvs _ (Color colorMapIfNeededFrom: 8 to: 32) asArray. 1 to: pvs size do:[:i| i > 1 ifTrue:[s nextPutAll:', ']. (i-1 \\ 8) = 0 ifTrue:[s cr]. s nextPutAll:'0x'. hex _ (pvs at: i) printStringBase: 16. s nextPutAll: (hex copyFrom: 4 to: hex size). ]. s nextPutAll:'};'. ]." | theTable | self returnTypeC:'unsigned int *'. self var: #theTable declareC:'static unsigned int theTable[256] = { 0x0, 0xFF000001, 0xFFFFFFFF, 0xFF808080, 0xFFFF0000, 0xFF00FF00, 0xFF0000FF, 0xFF00FFFF, 0xFFFFFF00, 0xFFFF00FF, 0xFF202020, 0xFF404040, 0xFF606060, 0xFF9F9F9F, 0xFFBFBFBF, 0xFFDFDFDF, 0xFF080808, 0xFF101010, 0xFF181818, 0xFF282828, 0xFF303030, 0xFF383838, 0xFF484848, 0xFF505050, 0xFF585858, 0xFF686868, 0xFF707070, 0xFF787878, 0xFF878787, 0xFF8F8F8F, 0xFF979797, 0xFFA7A7A7, 0xFFAFAFAF, 0xFFB7B7B7, 0xFFC7C7C7, 0xFFCFCFCF, 0xFFD7D7D7, 0xFFE7E7E7, 0xFFEFEFEF, 0xFFF7F7F7, 0xFF000001, 0xFF003300, 0xFF006600, 0xFF009900, 0xFF00CC00, 0xFF00FF00, 0xFF000033, 0xFF003333, 0xFF006633, 0xFF009933, 0xFF00CC33, 0xFF00FF33, 0xFF000066, 0xFF003366, 0xFF006666, 0xFF009966, 0xFF00CC66, 0xFF00FF66, 0xFF000099, 0xFF003399, 0xFF006699, 0xFF009999, 0xFF00CC99, 0xFF00FF99, 0xFF0000CC, 0xFF0033CC, 0xFF0066CC, 0xFF0099CC, 0xFF00CCCC, 0xFF00FFCC, 0xFF0000FF, 0xFF0033FF, 0xFF0066FF, 0xFF0099FF, 0xFF00CCFF, 0xFF00FFFF, 0xFF330000, 0xFF333300, 0xFF336600, 0xFF339900, 0xFF33CC00, 0xFF33FF00, 0xFF330033, 0xFF333333, 0xFF336633, 0xFF339933, 0xFF33CC33, 0xFF33FF33, 0xFF330066, 0xFF333366, 0xFF336666, 0xFF339966, 0xFF33CC66, 0xFF33FF66, 0xFF330099, 0xFF333399, 0xFF336699, 0xFF339999, 0xFF33CC99, 0xFF33FF99, 0xFF3300CC, 0xFF3333CC, 0xFF3366CC, 0xFF3399CC, 0xFF33CCCC, 0xFF33FFCC, 0xFF3300FF, 0xFF3333FF, 0xFF3366FF, 0xFF3399FF, 0xFF33CCFF, 0xFF33FFFF, 0xFF660000, 0xFF663300, 0xFF666600, 0xFF669900, 0xFF66CC00, 0xFF66FF00, 0xFF660033, 0xFF663333, 0xFF666633, 0xFF669933, 0xFF66CC33, 0xFF66FF33, 0xFF660066, 0xFF663366, 0xFF666666, 0xFF669966, 0xFF66CC66, 0xFF66FF66, 0xFF660099, 0xFF663399, 0xFF666699, 0xFF669999, 0xFF66CC99, 0xFF66FF99, 0xFF6600CC, 0xFF6633CC, 0xFF6666CC, 0xFF6699CC, 0xFF66CCCC, 0xFF66FFCC, 0xFF6600FF, 0xFF6633FF, 0xFF6666FF, 0xFF6699FF, 0xFF66CCFF, 0xFF66FFFF, 0xFF990000, 0xFF993300, 0xFF996600, 0xFF999900, 0xFF99CC00, 0xFF99FF00, 0xFF990033, 0xFF993333, 0xFF996633, 0xFF999933, 0xFF99CC33, 0xFF99FF33, 0xFF990066, 0xFF993366, 0xFF996666, 0xFF999966, 0xFF99CC66, 0xFF99FF66, 0xFF990099, 0xFF993399, 0xFF996699, 0xFF999999, 0xFF99CC99, 0xFF99FF99, 0xFF9900CC, 0xFF9933CC, 0xFF9966CC, 0xFF9999CC, 0xFF99CCCC, 0xFF99FFCC, 0xFF9900FF, 0xFF9933FF, 0xFF9966FF, 0xFF9999FF, 0xFF99CCFF, 0xFF99FFFF, 0xFFCC0000, 0xFFCC3300, 0xFFCC6600, 0xFFCC9900, 0xFFCCCC00, 0xFFCCFF00, 0xFFCC0033, 0xFFCC3333, 0xFFCC6633, 0xFFCC9933, 0xFFCCCC33, 0xFFCCFF33, 0xFFCC0066, 0xFFCC3366, 0xFFCC6666, 0xFFCC9966, 0xFFCCCC66, 0xFFCCFF66, 0xFFCC0099, 0xFFCC3399, 0xFFCC6699, 0xFFCC9999, 0xFFCCCC99, 0xFFCCFF99, 0xFFCC00CC, 0xFFCC33CC, 0xFFCC66CC, 0xFFCC99CC, 0xFFCCCCCC, 0xFFCCFFCC, 0xFFCC00FF, 0xFFCC33FF, 0xFFCC66FF, 0xFFCC99FF, 0xFFCCCCFF, 0xFFCCFFFF, 0xFFFF0000, 0xFFFF3300, 0xFFFF6600, 0xFFFF9900, 0xFFFFCC00, 0xFFFFFF00, 0xFFFF0033, 0xFFFF3333, 0xFFFF6633, 0xFFFF9933, 0xFFFFCC33, 0xFFFFFF33, 0xFFFF0066, 0xFFFF3366, 0xFFFF6666, 0xFFFF9966, 0xFFFFCC66, 0xFFFFFF66, 0xFFFF0099, 0xFFFF3399, 0xFFFF6699, 0xFFFF9999, 0xFFFFCC99, 0xFFFFFF99, 0xFFFF00CC, 0xFFFF33CC, 0xFFFF66CC, 0xFFFF99CC, 0xFFFFCCCC, 0xFFFFFFCC, 0xFFFF00FF, 0xFFFF33FF, 0xFFFF66FF, 0xFFFF99FF, 0xFFFFCCFF, 0xFFFFFFFF};'. ^theTable! ! !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: 'ar 12/7/1998 21:15'! 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. destPixSize = 32 ifTrue:[destWord _ destPix] ifFalse:[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: 'ar 12/7/1998 21:18'! 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. destPixSize = 32 ifTrue:[destWord _ sourcePix] ifFalse:[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: 'ar 12/7/1998 21:20'! 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]. destPixSize = 32 ifTrue:[destWord _ destPix] ifFalse:[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: 'ar 12/7/1998 21:14'! 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. sourcePixMask _ maskTable at: sourcePixSize. destPixMask _ maskTable at: destPixSize. 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]]. destPixSize = 32 ifTrue:[destWord _ destPix] ifFalse:[destWord _ (destWord << destPixSize) bitOr: destPix]. sx _ sx + xDeltah. sy _ sy + yDeltah. ]. ^ destWord! ! !BitBltSimulation methodsFor: 'translation support' stamp: 'ar 10/12/1998 17:43'! 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)OLDrgbDiffwith'. self cCode: 'opTable[23+1] = (int)OLDtallyIntoMapwith'. 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)alphaBlendConstwith'. self cCode: 'opTable[31+1] = (int)alphaPaintConstwith'. self cCode: 'opTable[32+1] = (int)rgbDiffwith'. self cCode: 'opTable[33+1] = (int)tallyIntoMapwith'. self cCode: 'opTable[34+1] = (int)alphaBlendScaledwith'.! ! !BitBltSimulation class methodsFor: 'initialization' stamp: 'di 6/29/1998 23:24'! 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: 'ar 10/12/1998 17:42'! initializeRuleTable "BitBltSimulation initializeRuleTable" "**WARNING** You MUST change initBBOpTable if you change this" 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: "unused - was old paint" "17" destinationWord:with: "unused - was old mask" "18" addWord:with: "19" subWord:with: "20" rgbAdd:with: "21" rgbSub:with: "22" OLDrgbDiff:with: "23" OLDtallyIntoMap:with: "24" alphaBlend:with: "25" pixPaint:with: "26" pixMask:with: "27" rgbMax:with: "28" rgbMin:with: "29" rgbMinInvert:with: "30" alphaBlendConst:with: "31" alphaPaintConst:with: "32" rgbDiff:with: "33" tallyIntoMap:with: "34" alphaBlendScaled: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' stamp: 'jm 11/15/2003 07:38'! 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 fillColor: 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: 'ar 12/7/1998 21:27'! declareCVarsIn: aCCodeGenerator aCCodeGenerator var: 'opTable' declareC: 'int opTable[' , OpTableSize printString , ']'. aCCodeGenerator var: 'maskTable' declareC:'int maskTable[33] = { 0, 1, 3, 0, 15, 0, 0, 0, 255, 0, 0, 0, 0, 0, 0, 0, 65535, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, -1 }'.! ! !BitBltSimulator methodsFor: 'all' stamp: 'ar 12/7/1998 21:10'! initBBOpTable opTable _ OpTable. maskTable _ Array new: 32. #(1 2 4 8 16 32) do:[:i| maskTable at: i put: (1 << i)-1].! ! !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 methodsFor: 'all' stamp: 'jm 12/29/2003 22:01'! 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. ! ! This class is a stub for BitBlt for virtual machines that don't support BitBlt. ! !BitBltStub methodsFor: 'as yet unclassified' stamp: 'jm 12/20/2003 20:33'! initBBOpTable "Do nothing. Called by the VM at startup." ! ! 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: 'control defaults' stamp: 'sma 3/11/2000 14:52'! isControlActive ^ super isControlActive and: [sensor keyboardPressed not]! ! !BitEditor methodsFor: 'menu messages' stamp: 'sma 3/15/2000 21:10'! setTransparentColor squareForm fillColor: Color gray. color _ Color transparent! ! !BitEditor methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:04'! getPluggableYellowButtonMenu: shiftKeyState ^ YellowButtonMenu! ! !BitEditor class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 14:48'! 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 _ SelectionMenu labels: 'cancel accept file out test' lines: #(2 3) selections: #(cancel accept fileOut test) "BitEditor initialize"! ! !BitEditor class methodsFor: 'instance creation' stamp: 'jm 6/1/2003 06:00'! openOnForm: aForm "Create and schedule a BitEditor on the form aForm at its top left corner. Show the normal-sized and a magnified view of aForm." | scaleFactor | scaleFactor _ 4@4. ^ self openOnForm: aForm at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft scale: scaleFactor ! ! !BitEditor class methodsFor: 'instance creation' stamp: 'sma 3/11/2000 11:29'! 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. 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."! ! 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' stamp: 'ar 12/23/1999 14:35'! fromByteStream: aStream "Initialize the array of bits by reading integers from the argument, aStream." aStream nextWordsInto: self! ! !Bitmap methodsFor: 'filing' stamp: 'di 8/5/1998 11:41'! 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 | f unhibernate. b _ f bits. n _ n + 1. rawBytes _ rawBytes + (b size*4). myBytes _ myBytes + (b compressToByteArray size). f hibernate]. Array with: n with: rawBytes with: myBytes ColorForms: (116 230324 160318 ) Forms: (113 1887808 1325055 ) Integerity check: Form allInstances do: [:f | f unhibernate. f bits = (Bitmap decompressFromByteArray: f bits compressToByteArray) ifFalse: [self halt]. f hibernate] Speed test: MessageTally spyOn: [Form allInstances do: [:f | Bitmap decompressFromByteArray: f bits compressToByteArray]] "! ! !Bitmap methodsFor: 'filing' stamp: 'di 8/5/1998 11:31'! 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 1984 (7936//4) or more (for which M jumps from 2 to 5) to add any extra overhead. Therefore the worst case is a series of runs of 1984 or more, with single interspersed words of equal bytes. At each break we save 2 bytes, but add 5. Thus the overhead would be no more than 5 (encoded size) + 2 (first run len) + (S//1984*3)." "NOTE: This code is copied in Form hibernate for reasons given there." byteArray _ ByteArray new: (self size*4) + 7 + (self size//1984*3). lastByte _ self compress: self toByteArray: byteArray. ^ byteArray copyFrom: 1 to: lastByte! ! !Bitmap methodsFor: 'filing' stamp: 'tk 1/24/2000 22:37'! restoreEndianness "This word object was just read in from a stream. Bitmaps are always compressed and serialized in a machine-independent way. Do not correct the Endianness." "^ self" ! ! !Bitmap methodsFor: 'filing' stamp: 'tk 2/19/1999 07:36'! writeUncompressedOn: aStream "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed)." aStream nextInt32Put: self size. aStream nextPutAll: self ! ! !Bitmap methodsFor: 'printing' stamp: 'sma 6/1/2000 09:42'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' of length '; print: self size! ! !Bitmap methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !Bitmap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:42'! isColormap "Bitmaps were used as color maps for BitBlt. This method allows to recognize real color maps." ^false! ! !Bitmap class methodsFor: 'instance creation' stamp: 'ar 12/23/1999 14:35'! 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 nextWordsInto: (self new: len)]! ! My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution. My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity. BlockContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a BlockContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! !BlockContext methodsFor: 'evaluating' stamp: 'jm 5/22/2003 20:25'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver. If an error occurs the given handler block is evaluated. The handler block can be either a zero- or two-argument block; if the latter, then the error message and receiver are supplied to it as parameters. Answer the value returned by the handler block if the receiver gets an error." "Warning: The receiver should not contain an explicit return since that would leave an obsolete error handler hanging around." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?']. [1 whatsUpDoc] ifError: ['huh']. [1 / 0] ifError: [:err :rcvr | 'division by 0' = err ifTrue: [^ Float infinity] ifFalse: [self error: err]] " | activeProcess lastHandler val | activeProcess _ Processor activeProcess. lastHandler _ activeProcess errorHandler. activeProcess errorHandler: [:aString :aReceiver | activeProcess errorHandler: lastHandler. errorHandlerBlock numArgs = 0 ifTrue: [^ errorHandlerBlock value]. ^ errorHandlerBlock value: aString value: aReceiver]. val _ self value. activeProcess errorHandler: lastHandler. ^ val ! ! !BlockContext methodsFor: 'evaluating' stamp: 'jm 6/10/2003 12:26'! msecs "Answer the number of milliseconds taken to execute this block. For typing convenience (shorter than 'timeToRun')." ^ Time millisecondsToRun: self ! ! !BlockContext methodsFor: 'evaluating' stamp: 'jm 6/3/1998 14:25'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !BlockContext methodsFor: 'scheduling' stamp: 'jm 5/23/2003 12:30'! bg "Create and schedule a Process running the code in the receiver at background priority. For conviently running a computation in the background from an expression." "Example: [(Delay forSeconds: 2) wait. self beep] bg" ^ self forkAt: Processor userBackgroundPriority ! ! !BlockContext methodsFor: 'scheduling' stamp: 'di 9/12/1998 11:53'! fork "Create and schedule a Process running the code in the receiver." ^ self newProcess resume! ! !BlockContext methodsFor: 'scheduling' stamp: 'jm 11/9/1998 10:16'! forkAt: priority "Create and schedule a Process running the code in the receiver at the given priority. Answer the newly created process." | forkedProcess | forkedProcess _ self newProcess. forkedProcess priority: priority. ^ forkedProcess resume ! ! !BlockContext methodsFor: 'scheduling' stamp: 'ar 6/5/1998 21:44'! newProcess "Answer a Process running the code in the receiver. The process is not scheduled." "Simulation guard" ^Process forContext: [self value. Processor terminateActive] priority: Processor activePriority! ! !BlockContext methodsFor: 'private' stamp: 'jm 5/15/2003 20:52'! 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' stamp: 'di 1/14/1999 22:28'! instVarAt: index put: value index = 3 ifTrue: [self stackp: value. ^ value]. ^ super instVarAt: index put: value! ! !BlockContext methodsFor: 'system simulation' stamp: 'di 1/11/1999 10:24'! pushArgs: args from: sendr "Simulates action of the value primitive." args size ~= nargs ifTrue: [^self error: 'incorrect number of args']. self stackp: 0. args do: [:arg | self push: arg]. sender _ sendr. pc _ startpc! ! 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' stamp: 'sma 3/3/2000 13:38'! statements: statementsCollection returns: returnBool "Decompile." | returnLast | returnLast _ returnBool. returns _ false. statements _ (statementsCollection size > 1 and: [(statementsCollection at: statementsCollection size - 1) isReturningIf]) ifTrue: [returnLast _ false. statementsCollection allButLast] ifFalse: [statementsCollection size = 0 ifTrue: [Array with: NodeNil] ifFalse: [statementsCollection]]. arguments _ #(). temporaries _ #(). returnLast ifTrue: [self returnLast]! ! !BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'! block ^ self! ! !BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'! temporaries: aCollection temporaries _ aCollection! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:32'! emitExceptLast: stack on: aStream | nextToLast | nextToLast _ statements size - 1. nextToLast < 1 ifTrue: [^ self]. "Only one statement" 1 to: nextToLast do: [:i | (statements at: i) emitForEffect: stack on: aStream]. ! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:44'! emitForEvaluatedValue: stack on: aStream self emitExceptLast: stack on: aStream. statements last emitForValue: stack on: aStream. ! ! !BlockNode methodsFor: 'code generation' stamp: 'di 11/19/1999 19:33'! sizeExceptLast: encoder | codeSize nextToLast | nextToLast _ statements size - 1. nextToLast < 1 ifTrue: [^ 0]. "Only one statement" codeSize _ 0. 1 to: nextToLast do: [:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)]. ^ codeSize! ! !BlockNode methodsFor: 'printing' stamp: 'sw 11/17/1999 13:56'! printArgumentsOn: aStream indent: level arguments size = 0 ifFalse: [arguments do: [:arg | aStream nextPut: $:. aStream withAttributes: (Preferences syntaxAttributesFor: #blockArgument) do: [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' stamp: 'sma 2/27/2000 22:42'! printOn: aStream indent: level statements size <= 1 ifFalse: [aStream crtab: level]. aStream nextPut: $[. self printArgumentsOn: aStream indent: level. self printTemporariesOn: aStream indent: level. self printStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode methodsFor: 'printing' stamp: 'di 4/3/1999 23:25'! 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 ~~ nil and: [thisStatement comment size > 0]) ifTrue: [i = shown ifTrue: [aStream crtab: level]. thisStatement printCommentOn: aStream indent: level. i < shown ifTrue: [aStream crtab: level]]]! ! !BlockNode methodsFor: 'printing' stamp: 'di 3/6/2000 20:52'! printTemporariesOn: aStream indent: level (temporaries == nil or: [temporaries size = 0]) ifFalse: [aStream nextPut: $|. temporaries do: [:arg | aStream space; withAttributes: (Preferences syntaxAttributesFor: #temporaryVariable) do: [aStream nextPutAll: arg key]]. aStream nextPutAll: ' | '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! ! !BlockNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:53'! 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 methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'! statements: statements returns: returns ^ self new statements: statements returns: returns! ! !BlockNode class methodsFor: 'instance creation' stamp: 'sma 3/3/2000 13:34'! withJust: aNode ^ self statements: (Array with: aNode) returns: false! ! A collection of pages, each of which is a place to put morphs. Allows one or another page to show; orchestrates the page transitions; offers control panel for navigating among pages and for adding and deleting pages. To write a book out to the disk or to a file server, decide what folder it goes in. Construct a url to a typical page: file://myDisk/folder/myBook1.sp or ftp://aServer/folder/myBook1.sp Choose "send all pages to server" from the book's menu (press the <> part of the controls). Choose "use page numbers". Paste in the url. To load an existing book, find its ".bo" file in the file list browser. Choose "load as book". To load an existing book from its url, execute: Ã(URLMorph grabURL: 'ftp://aServer/folder/myBook1.sp') book: true. Multiple people may modify a book. If other people may have changed a book you have on your screen, choose "reload all from server". Add or modify a page, and choose "send this page to server". The polite thing to do is to reload before changing a book. Then write one or all pages soon after making your changes. If you store a stale book, it will wipe out changes that other people made in the mean time. Pages may be linked to each other. To create a named link to a new page, type the name of the page in a text area in a page. Select it and do Cmd-6. Choose 'link to'. A new page of that name will be added at the back of the book. Clicking on the blue text flips to that page. To create a link to an existing page, first name the page. Go to that page and Cmd-click on it. The name of the page is below the page. Click in it and backspace and type. Return to the page you are linking from. Type the name. Cmd-6, 'link to'. Text search: Search for a set of fragments. allStrings collects text of fields. Turn to page with all fragments on it and highlight the first one. Save the container and offset in properties: #searchContainer, #searchOffset, #searchKey. Search again from there. Clear those at each page turn, or change of search key. [rules about book indexes and pages: Index and pages must live in the same directory. They have the same file prefix, followed by .bo for the index or 4.sp for a page (or x4.sp). When a book is moved to a new directory, the load routine gets the new urls for all pages and saves those in the index. Book stores index url in property #url. Allow mulitple indexes (books) on the same shared set of pages. If book has a url in same directory as pages, allow them to have different prefixes. save all pages first time, save one page first time, fromRemoteStream: (first time) save all pages normal , save one page normal, reload where I check if same dir] URLMorph holds url of both page and book.! !BookMorph methodsFor: 'initialization' stamp: 'sw 7/4/1998 16:43'! initialize super initialize. self setInitialState. pages _ OrderedCollection new. self showPageControls. self class turnOffSoundWhile: [self insertPage]. ! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 6/24/1998 09:23'! newPages: pageList "Replace all my pages with the given list of BookPageMorphs. After this call, currentPage may be invalid." pages _ pages species new. pages addAll: pageList! ! !BookMorph methodsFor: 'initialization' stamp: 'sw 7/4/1998 16:45'! removeEverything currentPage _ nil. pages _ OrderedCollection new. self removeAllMorphs! ! !BookMorph methodsFor: 'initialization' stamp: 'jm 2/4/2003 13:30'! setInitialState orientation _ #vertical. centering _ #topLeft. hResizing _ #shrinkWrap. vResizing _ #shrinkWrap. inset _ 5. color _ Color white. pageSize _ 160@300. self enableDragNDrop: true. ! ! !BookMorph methodsFor: 'sorting' stamp: 'jm 10/13/2002 18:59'! acceptSortedContentsFrom: aHolder "Update my page list from the given page sorter." | goodPages rejects toAdd | goodPages _ OrderedCollection new. rejects _ OrderedCollection new. aHolder submorphs doWithIndex: [:m :i | toAdd _ nil. (m isKindOf: PasteUpMorph) ifTrue: [toAdd _ m]. toAdd ifNil: [rejects add: m] ifNotNil: [goodPages add: toAdd]]. self newPages: goodPages. goodPages size = 0 ifTrue: [self insertPage]. rejects size > 0 ifTrue: [self inform: rejects size printString, ' objects vanished in this process.'] ! ! !BookMorph methodsFor: 'sorting' stamp: 'sw 3/5/1999 17:38'! morphsForPageSorter | i thumbnails | 'Assembling thumbnail images...' displayProgressAt: self cursorPoint from: 0 to: pages size during: [:bar | i _ 0. thumbnails _ pages collect: [:p | bar value: (i_ i+1). pages size > 40 ifTrue: [p smallThumbnailForPageSorter inBook: self] ifFalse: [p thumbnailForPageSorter inBook: self]]]. ^ thumbnails! ! !BookMorph methodsFor: 'sorting' stamp: 'di 1/4/1999 13:52'! sortPages currentPage ifNotNil: [currentPage updateCachedThumbnail]. ^ super sortPages! ! !BookMorph methodsFor: 'sorting' stamp: 'di 1/4/1999 12:12'! sortPages: evt ^ self sortPages! ! !BookMorph methodsFor: 'accessing' stamp: 'sw 10/16/1998 22:39'! currentPage (submorphs includes: currentPage) ifFalse: [currentPage _ nil]. ^ currentPage! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 12/24/1998 07:27'! pageNumberOf: aMorph "Modified so that if the page IS in memory, other pages don't have to be brought in. (This method may wrongly say a page is not here if pages has a tombstone (MorphObjectOut) and that tombstone would resolve to an object already in this image. This is an unlikely case, and callers just have to tolerate it.)" ^ pages identityIndexOf: aMorph ifAbsent: [0] ! ! !BookMorph methodsFor: 'accessing' stamp: 'tk 10/22/1998 15:47'! pages: aMorphList pages _ aMorphList asOrderedCollection. "It is tempting to force the first page to be the current page. But then, two pages might be shown at once!! Just trust the copying mechanism and let currentPage be copied correctly. --Ted."! ! !BookMorph methodsFor: 'accessing' stamp: 'mjg 9/28/1999 11:57'! setAllPagesColor: aColor "Set the color of all the pages to a new color" self pages do: [:page | page color: aColor].! ! !BookMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:47'! rootForGrabOf: aMorph | root | self dragNDropEnabled ifFalse: [^ super rootForGrabOf: aMorph]. (aMorph = currentPage or: [aMorph owner = self]) ifTrue: [^ self rootForGrabOf: self]. root _ aMorph. [root = self] whileFalse: [root owner == currentPage ifTrue: [^ root]. root _ root owner]. ^ super rootForGrabOf: aMorph! ! !BookMorph methodsFor: 'dropping/grabbing' stamp: 'di 9/30/1998 10:38'! wantsDroppedMorph: aMorph event: evt (currentPage bounds containsPoint: (self pointFromWorld: evt cursorPoint)) ifFalse: [^ false]. ^ super wantsDroppedMorph: aMorph event: evt! ! !BookMorph methodsFor: 'insert and delete' stamp: 'sw 6/24/1998 18:50'! deletePage | message | message _ 'Are you certain that you want to delete this page and everything that is on it? '. (self confirm: message) ifTrue: [self deletePageBasic]. ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'di 9/7/1999 21:57'! deletePageBasic | thisPage | thisPage _ self pageNumberOf: currentPage. pages remove: currentPage. currentPage delete. currentPage _ nil. pages isEmpty ifTrue: [^ self insertPage]. self goToPage: (thisPage min: pages size) ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'jm 10/7/2002 06:41'! 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: [Cursor wait showWhile: [newPage _ newPagePrototype fullCopy]]. newPage setNameTo: 'page'. newPage resizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage _ newPage)] ifFalse: [pages add: newPage after: currentPage]. self nextPage. ! ! !BookMorph methodsFor: 'insert and delete' stamp: 'jm 10/7/2002 06:41'! insertPageSilentlyAtEnd "Create a new page at the end of the book. Do not turn to it." | sz newPage bw bc cc | currentPage == nil ifTrue: [sz _ pageSize. bw _ 0. bc _ Color blue muchLighter. cc _ color] ifFalse: [sz _ currentPage extent. bw _ currentPage borderWidth. bc _ currentPage borderColor. cc _ currentPage color]. newPagePrototype ifNil: [newPage _ PasteUpMorph new extent: sz; color: cc. newPage borderWidth: bw; borderColor: bc] ifNotNil: [Cursor wait showWhile: [newPage _ newPagePrototype fullCopy]]. newPage setNameTo: 'page'. newPage resizeToFit: false. pages isEmpty ifTrue: [pages add: (currentPage _ newPage)] "was none" ifFalse: [pages add: newPage after: pages last]. ^ newPage! ! !BookMorph methodsFor: 'navigation' stamp: 'di 12/20/1998 10:18'! goToPage: pageNumber ^ self goToPage: pageNumber transitionSpec: nil! ! !BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:07'! goToPage: pageNumber transitionSpec: transitionSpec | pageMorph | pages isEmpty ifTrue: [^ self]. pageMorph _ (self hasProperty: #dontWrapAtEnd) ifTrue: [pages atPin: pageNumber] ifFalse: [pages atWrap: pageNumber]. ^ self goToPageMorph: pageMorph transitionSpec: transitionSpec! ! !BookMorph methodsFor: 'navigation' stamp: 'tk 12/24/1998 07:17'! goToPageMorph: aMorph self goToPage: (pages identityIndexOf: aMorph ifAbsent: [^ self "abort"]). ! ! !BookMorph methodsFor: 'navigation' stamp: 'di 1/4/1999 12:37'! goToPageMorph: aMorph fromBookmark: aBookmark "This protocol enables sensitivity to a transitionSpec on the bookmark" self goToPageMorph: aMorph transitionSpec: (aBookmark valueOfProperty: #transitionSpec). ! ! !BookMorph methodsFor: 'navigation' stamp: 'jm 7/17/2003 22:57'! goToPageMorph: newPage transitionSpec: transitionSpec | pageIndex aWorld oldPageIndex ascending tSpec | pages isEmpty ifTrue: [^ self]. self setProperty: #searchContainer toValue: nil. "forget previous search" self setProperty: #searchOffset toValue: nil. self setProperty: #searchKey toValue: nil. pageIndex _ pages identityIndexOf: newPage ifAbsent: [^ self "abort"]. oldPageIndex _ pages identityIndexOf: currentPage ifAbsent: [nil]. ascending _ ((oldPageIndex == nil) or: [newPage == currentPage]) ifTrue: [nil] ifFalse: [oldPageIndex < pageIndex]. tSpec _ transitionSpec ifNil: "If transition not specified by requestor..." [newPage valueOfProperty: #transitionSpec " ... then consult new page" ifAbsent: [self transitionSpecFor: self " ... otherwise this is the default"]]. (aWorld _ self world) ifNotNil: [self primaryHand newKeyboardFocus: nil]. currentPage ifNotNil: [currentPage updateCachedThumbnail]. self currentPage ~~ nil ifTrue: [(((pages at: pageIndex) owner isKindOf: TransitionMorph) and: [(pages at: pageIndex) isInWorld]) ifTrue: [^ self "In the process of a prior pageTurn"]. ascending ifNotNil: ["Show appropriate page transition and start new page when done" currentPage stopStepping. (pages at: pageIndex) position: currentPage position. ^ (TransitionMorph effect: tSpec second direction: tSpec third inverse: (ascending or: [transitionSpec notNil]) not) showTransitionFrom: currentPage to: (pages at: pageIndex) in: self whenStart: [self playPageFlipSound: tSpec first] whenDone: [currentPage delete. currentPage allMorphsDo: [:m | m releaseCachedState]. self addMorphBack: (currentPage _ pages at: pageIndex). self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. (aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld]. ]]. "No transition, but at least decommission current page" currentPage delete. currentPage allMorphsDo: [:m | m releaseCachedState]]. self addMorphBack: (currentPage _ pages at: pageIndex). self snapToEdgeIfAppropriate. aWorld ifNotNil: [self world startSteppingSubmorphsOf: currentPage]. (aWorld _ self world) ifNotNil: ["WHY??" aWorld displayWorld]. ! ! !BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:01'! nextPage currentPage == nil ifTrue: [^ self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) + 1. ! ! !BookMorph methodsFor: 'navigation' stamp: 'tk 12/24/1998 07:19'! pageNumber ^ self pageNumberOf: currentPage! ! !BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:01'! previousPage currentPage == nil ifTrue: [^ self goToPage: 1]. self goToPage: (self pageNumberOf: currentPage) - 1. ! ! !BookMorph methodsFor: 'navigation' stamp: 'di 1/14/1999 12:20'! setWrapPages: doWrap doWrap ifTrue: [self removeProperty: #dontWrapAtEnd] ifFalse: [self setProperty: #dontWrapAtEnd toValue: true]. ! ! !BookMorph methodsFor: 'navigation' stamp: 'sw 5/23/2000 13:11'! showMoreControls self currentEvent shiftPressed ifTrue: [self hidePageControls] ifFalse: [self showPageControls: self fullControlSpecs]! ! !BookMorph methodsFor: 'navigation' stamp: 'di 12/21/1998 11:15'! transitionSpecFor: aMorph ^ aMorph valueOfProperty: #transitionSpec " check for special propety" ifAbsent: [Array with: 'camera' " ... otherwise this is the default" with: #none with: #none]! ! !BookMorph methodsFor: 'menu' stamp: 'jm 10/13/2002 19:30'! addBookMenuItemsTo: aMenu hand: aHandMorph | subMenu | subMenu _ MenuMorph new defaultTarget: self. subMenu add: 'previous page' action: #previousPage. subMenu add: 'next page' action: #nextPage. subMenu add: 'goto page' action: #goToPage. subMenu add: 'insert a page' action: #insertPage. subMenu add: 'delete this page' action: #deletePage. self pageControlsVisible ifTrue: [ subMenu add: 'hide page controls' action: #hidePageControls. subMenu add: 'fewer page controls' action: #fewerPageControls] ifFalse: [ subMenu add: 'show page controls' action: #showPageControls]. subMenu addLine. subMenu add: 'sound effect for all pages' action: #menuPageSoundForAll:. subMenu add: 'sound effect this page only' action: #menuPageSoundForThisPage:. subMenu add: 'visual effect for all pages' action: #menuPageVisualForAll:. subMenu add: 'visual effect this page only' action: #menuPageVisualForThisPage:. subMenu addLine. subMenu add: 'sort pages' action: #sortPages:. subMenu add: 'uncache page sorter' action: #uncachePageSorter. (self hasProperty: #dontWrapAtEnd) ifTrue: [subMenu add: 'wrap after last page' selector: #setWrapPages: argument: true] ifFalse: [subMenu add: 'stop at last page' selector: #setWrapPages: argument: false]. subMenu addLine. (aHandMorph classOfPasteBuffer isKindOf: PasteUpMorph class) ifTrue: [ subMenu add: 'paste book page' action: #pasteBookPage]. subMenu add: 'keep in one file' action: #keepTogether. subMenu add: 'save as new-page prototype' action: #setNewPagePrototype. newPagePrototype ifNotNil: [ subMenu add: 'clear new-page prototype' action: #clearNewPagePrototype]. aMenu add: 'book...' subMenu: subMenu. ! ! !BookMorph methodsFor: 'menu' stamp: 'sge 2/13/2000 05:33'! goToPage | pageNum | pageNum _ FillInTheBlank request: 'Page?' initialAnswer: '0'. pageNum isEmptyOrNil ifTrue: [^true]. self goToPage: pageNum asNumber. ! ! !BookMorph methodsFor: 'menu' stamp: 'jm 10/13/2002 19:30'! invokeBookMenu "Invoke the book's control panel menu." | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. aMenu add: 'go to page...' action: #goToPage. aMenu addLine. aMenu addList: #(('sort pages' sortPages) ('uncache page sorter' uncachePageSorter)). (self hasProperty: #dontWrapAtEnd) ifTrue: [aMenu add: 'wrap after last page' selector: #setWrapPages: argument: true] ifFalse: [aMenu add: 'stop at last page' selector: #setWrapPages: argument: false]. aMenu addList: #(('make thumbnail' thumbnailForThisPage)). aMenu addUpdating: #showingPageControlsString action: #toggleShowingOfPageControls. aMenu addLine. aMenu add: 'sound effect for all pages' action: #menuPageSoundForAll:. aMenu add: 'sound effect this page only' action: #menuPageSoundForThisPage:. aMenu add: 'visual effect for all pages' action: #menuPageVisualForAll:. aMenu add: 'visual effect this page only' action: #menuPageVisualForThisPage:. aMenu addLine. (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: ((self dragNDropEnabled ifTrue: ['close'] ifFalse: ['open']), ' dragNdrop') action: #toggleDragNDrop. aMenu add: 'make all pages this size' action: #makeUniformPageSize. aMenu add: 'keep in one file' action: #keepTogether. aMenu addLine. aMenu add: 'background color for all pages...' action: #setPageColor. aMenu popUpEvent: self world activeHand lastEvent! ! !BookMorph methodsFor: 'menu' stamp: 'tk 12/2/1998 19:31'! keepTogether "Mark this book so that each page will not go into a separate file. Do this when pages share referenes to a common Player. Don't want many copies of that Player when bring in. Do not write pages of book out. Write the PasteUpMorph that the entire book lives in." self setProperty: #keepTogether toValue: true.! ! !BookMorph methodsFor: 'menu' stamp: 'sw 1/25/1999 16:15'! makeUniformPageSize "Make all pages be of the same size as the current page." currentPage ifNil: [^ self beep]. self resizePagesTo: currentPage extent. newPagePrototype ifNotNil: [newPagePrototype extent: currentPage extent]! ! !BookMorph methodsFor: 'menu' stamp: 'sma 6/5/2000 13:44'! menuPageSoundFor: target event: evt | tSpec menu | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: 'Choose a sound (it is now ' , tSpec first , ')') defaultTarget: target. SampledSound soundNames do: [:soundName | menu add: soundName target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (tSpec copy at: 1 put: soundName; yourself))]. menu popUpEvent: evt! ! !BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:53'! menuPageSoundForAll: evt ^ self menuPageSoundFor: self event: evt! ! !BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:55'! menuPageSoundForThisPage: evt currentPage ifNotNil: [^ self menuPageSoundFor: currentPage event: evt]! ! !BookMorph methodsFor: 'menu' stamp: 'sma 6/5/2000 13:44'! menuPageVisualFor: target event: evt | tSpec menu subMenu directionChoices | tSpec _ self transitionSpecFor: target. menu _ (MenuMorph entitled: 'Choose an effect (it is now ' , tSpec second , ')') defaultTarget: target. TransitionMorph allEffects do: [:effect | directionChoices _ TransitionMorph directionsForEffect: effect. directionChoices isEmpty ifTrue: [menu add: effect target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: #none))] ifFalse: [subMenu _ MenuMorph new. directionChoices do: [:dir | subMenu add: dir target: target selector: #setProperty:toValue: argumentList: (Array with: #transitionSpec with: (Array with: tSpec first with: effect with: dir))]. menu add: effect subMenu: subMenu]]. menu popUpEvent: evt! ! !BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 17:16'! menuPageVisualForAll: evt ^ self menuPageVisualFor: self event: evt! ! !BookMorph methodsFor: 'menu' stamp: 'di 12/20/1998 13:55'! menuPageVisualForThisPage: evt currentPage ifNotNil: [^ self menuPageVisualFor: currentPage event: evt]! ! !BookMorph methodsFor: 'menu' stamp: 'jm 10/7/2002 06:41'! setNewPagePrototype "Record the current page as the prototype to be copied when inserting new pages." currentPage ifNotNil: [newPagePrototype _ currentPage fullCopy]. ! ! !BookMorph methodsFor: 'menu' stamp: 'mjg 9/28/1999 11:58'! setPageColor "Get a color from the user, then set all the pages to that color" self currentPage ifNil: [^ self]. ColorPickerMorph new sourceHand: self activeHand; target: self; selector: #setAllPagesColor:; originalColor: self currentPage color; addToWorld: self world near: self fullBounds! ! !BookMorph methodsFor: 'menu' stamp: 'di 1/4/1999 12:49'! thumbnailForThisPage self primaryHand attachMorph: (currentPage thumbnailForPageSorter pageMorph: currentPage inBook: self) ! ! !BookMorph methodsFor: 'menu' stamp: 'sw 5/23/2000 02:18'! toggleShowingOfPageControls self pageControlsVisible ifTrue: [self hidePageControls] ifFalse: [self showPageControls]! ! !BookMorph methodsFor: 'menu' stamp: 'di 12/23/1998 14:55'! uncachePageSorter pages do: [:aPage | aPage removeProperty: #cachedThumbnail].! ! !BookMorph methodsFor: 'other' stamp: 'sw 1/11/2000 13:07'! defersHaloOnClickTo: aSubMorph "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" ^ currentPage notNil and: [aSubMorph hasInOwnerChain: currentPage] ! ! !BookMorph methodsFor: 'other' stamp: 'tk 8/13/1998 12:49'! 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 addTransparentSpacerOfSize: 40@0. aRow addMorphBack: (but _ aButton fullCopy label: ' < ' ; actionSelector: #previousPage). "fullCopy is OK, since we just made it and it can't own any Players" but setBalloonText: 'Go to previous page'. aRow addTransparentSpacerOfSize: 82@0. aRow addMorphBack: (StringMorph contents: aString) lock. aRow addTransparentSpacerOfSize: 82@0. aRow addMorphBack: (but _ aButton fullCopy label: ' > ' ; actionSelector: #nextPage). but setBalloonText: 'Go to next page'. aRow addTransparentSpacerOfSize: 40@0. aColumn addMorphBack: aRow. aColumn setNameTo: 'Page Controls'. ^ aColumn! ! !BookMorph methodsFor: 'other' stamp: 'jm 7/17/2003 22:56'! releaseCachedState "Release the cached state of all my pages." super releaseCachedState. pages do: [:page | page allMorphsDo: [:m | m releaseCachedState]]. ! ! !BookMorph methodsFor: 'other' stamp: 'sw 10/1/1998 13:40'! resizePagesTo: anExtent pages do: [:aPage | aPage extent: anExtent]! ! !BookMorph methodsFor: 'other' stamp: 'sw 12/30/1999 19:51'! seeksOutHalo "Answer whether the receiver is an eager recipient of the halo" ^ false! ! I am used to sort the pages of a book, sort of like sorting 35mm slider on a light table. ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 6/17/1998 21:27'! acceptSort book acceptSortedContentsFrom: pageHolder. self delete. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 6/17/1998 21:39'! 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: #delete). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'di 1/9/1999 11:41'! book: aBookMorph morphsToSort: morphList | innerBounds | book _ aBookMorph. pageHolder removeAllMorphs. pageHolder addAllMorphs: morphList. pageHolder extent: pageHolder width@pageHolder fullBounds height. innerBounds _ Rectangle merging: (morphList collect: [:m | m bounds]). pageHolder extent: innerBounds extent + pageHolder borderWidth + 6. self resizeIfNeeded! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'jm 6/17/1998 21:42'! closeButtonOnly "Replace my default control panel with one that has only a close button." | b r | self firstSubmorph delete. "remove old control panel" 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: 'Close'; actionSelector: #delete). self addMorphFront: r. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'di 1/8/1999 16:27'! forBook: aBookMorph ^ self book: aBookMorph morphsToSort: (aBookMorph pages collect: [:p | p thumbnailForPageSorter])! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'di 1/9/1999 11:44'! initialize super initialize. self extent: Display extent - 100; orientation: #vertical; centering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; inset: 3; color: Color lightGray; borderWidth: 2. pageHolder _ PasteUpMorph new behaveLikeHolder extent: self extent - borderWidth. pageHolder cursor: 0. self addControls. self addMorphBack: pageHolder. ! ! !BookPageSorterMorph methodsFor: 'as yet unclassified' stamp: 'sw 5/9/2000 03:15'! willingToBeEmbeddedUponLanding ^ false! ! A small picture representing a page of a BookMorph here or somewhere else. When clicked, make that book turn to the page and do a visual effect and a noise. page either the morph of the page, or a url pageNumber bookMorph either the book, or a url flipOnClick! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/8/2002 18:02'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. flipOnClick ifTrue: [aCustomMenu add: 'disable bookmark action' action: #toggleBookmark] ifFalse: [aCustomMenu add: 'enable bookmark action' action: #toggleBookmark]. (bookMorph isKindOf: BookMorph) ifTrue: [aCustomMenu add: 'set page sound' action: #setPageSound:. aCustomMenu add: 'set page visual' action: #setPageVisual:] ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/2/2002 12:21'! 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: 'as yet unclassified' stamp: 'jm 10/2/2002 12:21'! doPageFlip "Flip to this page" bookMorph ifNil: [^ self]. bookMorph goToPageMorph: page transitionSpec: (self valueOfProperty: #transitionSpec). (owner isKindOf: PasteUpMorph) ifTrue: [owner cursor: (owner submorphs indexOf: self ifAbsent: [1])]. ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:57'! encounteredAtTime: ticks inScorePlayer: scorePlayer atIndex: index inEventTrack: track secsPerTick: secsPerTick "Flip to this page with no extra sound" BookMorph turnOffSoundWhile: [self doPageFlip]! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:19'! handlesMouseDown: event ^ event shiftPressed or: [flipOnClick and: [event controlKeyPressed not]]! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:52'! inBook: book bookMorph _ book! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:45'! initialize | f | super initialize. flipOnClick _ false. color _ Color lightGray. "background color" f _ Form extent: 60@80 depth: Display depth. f fill: f boundingBox fillColor: color. self form: f. ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'tk 3/10/1999 11:25'! mouseDown: event "turn the book to that page" event setButtons: 0. "Lie to it. So mouseUp won't go to menu that may come up during fetch of a page in doPageFlip" self doPageFlip. ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'jm 7/17/2003 22:56'! page: aMorph page _ aMorph. self computeThumbnail. self setNameTo: aMorph externalName. page allMorphsDo: [:m | m releaseCachedState]. ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 1/4/1999 12:48'! pageMorph: pageMorph inBook: book page _ pageMorph. bookMorph _ book! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 8/6/1998 23:45'! pageNumber: n inBook: b pageNumber _ n. bookMorph _ b! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/20/1998 17:29'! setPageSound: event ^ bookMorph menuPageSoundFor: self event: event! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/20/1998 17:29'! setPageVisual: event ^ bookMorph menuPageVisualFor: self event: event! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 8/8/1998 14:06'! smaller self form: (self form copy: (0@0 extent: self form extent//2)). ! ! !BookPageThumbnailMorph methodsFor: 'as yet unclassified' stamp: 'di 12/23/1998 15:53'! toggleBookmark "Enable or disable sensitivity as a bookmark enabled means that a normal click will cause a pageFlip disabled means this morph can be picked up normally by the hand." flipOnClick _ flipOnClick not! ! A common superclass for BookMorph and WebBookMorph! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 5/23/2000 13:07'! fewerPageControls self currentEvent shiftPressed ifTrue: [self hidePageControls] ifFalse: [self showPageControls: self shortControlSpecs]! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/8/1999 10:22'! fullControlSpecs ^ #( spacer variableSpacer ('-' deletePage 'Delete this page') spacer ( 'Ç' firstPage 'First page') spacer ( '<' previousPage 'Previous page') spacer ('¥' invokeBookMenu 'Click here to get a menu of options for this book.') spacer ('>' nextPage 'Next page') spacer ( 'È' lastPage 'Final page') spacer ('+' insertPage 'Add a new page after this one') variableSpacer ('×' fewerPageControls 'Fewer controls') )! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'jm 10/11/2002 06:50'! hidePageControls "Delete all submorphs answering to the property #pageControl" (self submorphs select: [:m | m hasProperty: #pageControl]) do: [:m | m delete]. ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'jm 6/5/2003 18:31'! makePageControlsFrom: controlSpecs | c aButton col row b | c _ (color saturation > 0.1) ifTrue: [color slightlyLighter] ifFalse: [color slightlyDarker]. aButton _ SimpleButtonMorph new target: self; borderWidth: 1; borderColor: Color veryLightGray; color: c. col _ AlignmentMorph newColumn. col color: c; borderWidth: 0; inset: 0. col hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. row _ AlignmentMorph newRow. row color: c; borderWidth: 0; inset: 0. row hResizing: #spaceFill; vResizing: #shrinkWrap; extent: 5@5. controlSpecs do: [:spec | spec == #spacer ifTrue: [row addTransparentSpacerOfSize: (10 @ 0)] ifFalse: [spec == #variableSpacer ifTrue: [row addMorphBack: (AlignmentMorph newSpacer: row color)] ifFalse: [b _ aButton fullCopy label: spec first; actionSelector: spec second; borderWidth: 0; setBalloonText: spec third. row addMorphBack: b. (spec last asLowercase includesSubString: 'menu') ifTrue: [b actWhen: #buttonDown]]]]. "pop up menu on mouseDown" col addMorphBack: row. ^ col! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'jm 10/11/2002 06:55'! pageControlsVisible "Answer true if my page controls are showing." self submorphs detect: [:m | m hasProperty: #pageControl] ifNone: [^ false]. ^ true ! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/8/1999 10:22'! shortControlSpecs ^ #( spacer variableSpacer ( '<' previousPage 'Previous page') spacer ('¥' invokeBookMenu 'Click here to get a menu of options for this book.') spacer ('>' nextPage 'Next page') variableSpacer ('×' showMoreControls 'More controls'))! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'sw 3/2/1999 15:01'! showPageControls self showPageControls: self shortControlSpecs! ! !BooklikeMorph methodsFor: 'page controls' stamp: 'jm 10/13/2002 18:05'! showPageControls: controlSpecs | spacer pageControls anIndex | self hidePageControls. anIndex _ (submorphs size > 0 and: [submorphs first hasProperty: #header]) ifTrue: [2] ifFalse: [1]. spacer _ Morph new color: color; extent: 0@10. spacer setProperty: #pageControl toValue: true. self privateAddMorph: spacer atIndex: anIndex. pageControls _ self makePageControlsFrom: controlSpecs. pageControls borderWidth: 0; inset: 4. pageControls setProperty: #pageControl toValue: true. pageControls setNameTo: 'Page Controls'. self privateAddMorph: (pageControls isSticky: true) atIndex: anIndex. ! ! !BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 17:36'! addCustomMenuItems: aCustomMenu hand: aHandMorph "This factoring allows subclasses to have different menu yet still use the super call for the rest of the metamenu." super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addBookMenuItemsTo: aCustomMenu hand: aHandMorph! ! !BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 15:39'! clearNewPagePrototype newPagePrototype _ nil ! ! !BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 15:40'! firstPage self goToPage: 1! ! !BooklikeMorph methodsFor: 'menu commands' stamp: 'sw 7/4/1998 17:18'! insertPage self insertPageColored: self color! ! !BooklikeMorph methodsFor: 'menu commands' stamp: 'tk 2/25/1999 11:04'! sortPages | sorter | sorter _ BookPageSorterMorph new book: self morphsToSort: self morphsForPageSorter. sorter pageHolder cursor: self pageNumber. "Align at bottom right of screen, but leave 20-pix margin." self bottom + sorter height < Display height ifTrue: "Place it below if it fits" [^ self world addMorphFront: (sorter align: sorter topLeft with: self bottomLeft)]. self right + sorter width < Display width ifTrue: "Place it below if it fits" [^ self world addMorphFront: (sorter align: sorter bottomLeft with: self bottomRight)]. "Otherwise, place it at lower right of screen" self world addMorphFront: (sorter position: Display extent - (20@20) - sorter extent). ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'jm 10/11/2002 06:56'! addBookMenuItemsTo: aCustomMenu hand: aHandMorph self pageControlsVisible ifTrue: [aCustomMenu add: 'hide page controls' action: #hidePageControls] ifFalse: [aCustomMenu add: 'show page controls' action: #showPageControls]. ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'kfr 5/16/2000 12:14'! move owner isWorldMorph ifTrue: [self activeHand grabMorph: self]! ! !BooklikeMorph methodsFor: 'misc' stamp: 'sw 7/4/1998 15:36'! pageSize ^ pageSize ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'sw 7/4/1998 16:51'! pageSize: aPoint pageSize _ aPoint! ! !BooklikeMorph methodsFor: 'misc' stamp: 'jm 10/4/2002 08:29'! playPageFlipSound: soundName self isInWorld ifFalse: [^ self]. (Preferences soundsEnabled "user-controllable" and: [PageFlipSoundOn]) "mechanism to suppress sounds at init time" ifTrue: [self playSoundNamed: soundName]. ! ! !BooklikeMorph methodsFor: 'misc' stamp: 'sw 5/23/2000 02:16'! showingPageControlsString ^ self pageControlsVisible ifTrue: ['hide page controls'] ifFalse: ['show page controls']! ! !BooklikeMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/4/1998 15:59'! initialize "BooklikeMorph initialize" PageFlipSoundOn _ true ! ! !BooklikeMorph class methodsFor: 'as yet unclassified' stamp: 'sw 7/4/1998 16:43'! turnOffSoundWhile: aBlock "Turn off page flip sound during the given block." | old | old _ PageFlipSoundOn. PageFlipSoundOn _ false. aBlock value. PageFlipSoundOn _ old! ! Boolean is an abstract class defining the protocol for logic testing operations and conditional control structures for the logical values represented by the instances of its subclasses True and False. Boolean redefines #new so no instances of Boolean can be created. It also redefines several messages in the 'copying' protocol to ensure that only one instance of each of its subclasses True (the global true, logical assertion) and False (the global false, logical negation) ever exist in the system.! !Boolean methodsFor: 'copying' stamp: 'tk 6/26/1998 11:32'! clone "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! I can have a border of zero or more pixels and a fill color. I have many subclasses. ! !BorderedMorph methodsFor: 'initialization' stamp: 'sw 11/29/1999 17:35'! initialize super initialize. borderColor _ Color black. borderWidth _ 2! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/4/1999 09:42'! borderWidth: anInteger borderColor ifNil: [borderColor _ Color black]. borderWidth _ anInteger max: 0. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:52'! cornerStyle ^ self valueOfProperty: #cornerStyle ifAbsent: [#square]! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:32'! cornerStyle: aSymbol aSymbol == #square ifTrue: [self removeProperty: #cornerStyle] ifFalse: [self setProperty: #cornerStyle toValue: aSymbol]. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'jm 10/14/2002 07:54'! doesBevels "Return true if this object can show bevelled borders (i.e., can have #raised or #inset as valid borderColors). This method should be overridden to return false by subclasses that do not support bevelled borders, such as EllipseMorph." ^ true ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:24'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." (color isColor and: [color isTranslucentColor]) ifTrue: [^ true]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true]. ^ false ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'jm 10/14/2002 07:53'! isRectangular "Return true if this morph is rectangular. Rectangular morphs may or may not have rounded corners. This method should be overridden to return false by non-rectangular subclasses such as EllipseMorph." ^ true ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'! toggleCornerRounding self cornerStyle == #rounded ifTrue: [self useSquareCorners] ifFalse: [self useRoundedCorners]. self changed! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'! useRoundedCorners self cornerStyle: #rounded! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'! useSquareCorners self cornerStyle: #square! ! !BorderedMorph methodsFor: 'drawing' stamp: 'jm 10/9/2002 07:34'! areasRemainingToFill: aRectangle (color isColor and: [color isTranslucent]) ifTrue: [^ Array with: aRectangle]. self isRectangular ifFalse: [^ Array with: aRectangle]. self wantsRoundedCorners ifTrue: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: (self innerBounds intersect: self boundsWithinCorners)] ifFalse: [^ aRectangle areasOutside: self boundsWithinCorners]] ifFalse: [(borderWidth > 0 and: [borderColor isColor and: [borderColor isTranslucent]]) ifTrue: [^ aRectangle areasOutside: self innerBounds] ifFalse: [^ aRectangle areasOutside: self bounds]]! ! !BorderedMorph methodsFor: 'drawing' stamp: 'di 3/25/2000 11:13'! boundsWithinCorners ^ CornerRounder rectWithinCornersOf: self bounds! ! !BorderedMorph methodsFor: 'drawing' stamp: 'jm 11/24/2002 10:34'! 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" "Note: This is the hook for border styles. When converting to the new borders we'll just put 0 into the borderWidth" super drawOn: aCanvas. ^ self]. borderColor == #raised ifTrue: [ "Use a hack for now" aCanvas fillRectangle: self bounds color: color. ^ aCanvas frameAndFillRectangle: bounds fillColor: Color transparent borderWidth: borderWidth topLeftColor: (borderWidth = 1 ifTrue: [color twiceLighter] ifFalse: [color lighter]) bottomRightColor: (borderWidth = 1 ifTrue: [color twiceDarker] ifFalse: [color darker])]. borderColor == #inset ifTrue: [ insetColor _ owner colorForInsets. aCanvas fillRectangle: self bounds color: color. ^ aCanvas frameAndFillRectangle: bounds fillColor: Color transparent borderWidth: borderWidth topLeftColor: (borderWidth = 1 ifTrue: [insetColor twiceDarker] ifFalse: [insetColor darker]) bottomRightColor: (borderWidth = 1 ifTrue: [insetColor twiceLighter] ifFalse: [insetColor lighter])]. "solid color border" aCanvas fillRectangle: (self bounds insetBy: borderWidth) color: color. aCanvas frameAndFillRectangle: bounds fillColor: Color transparent borderWidth: borderWidth borderColor: borderColor.! ! !BorderedMorph methodsFor: 'drawing' stamp: 'jm 11/25/2002 15:47'! fullDrawOn: aCanvas (self wantsRoundedCorners and: [self width > 15]) ifTrue: [self fullDrawWithRoundedCornersOn: aCanvas] ifFalse: [super fullDrawOn: aCanvas]. ! ! !BorderedMorph methodsFor: 'drawing' stamp: 'sw 11/6/1999 11:04'! fullDrawWithRoundedCornersOn: aCanvas CornerRounder roundCornersOf: self on: aCanvas displayBlock: [super fullDrawOn: aCanvas] borderWidth: borderWidth! ! !BorderedMorph methodsFor: 'drawing' stamp: 'sw 11/29/1999 17:34'! wantsRoundedCorners ^ self cornerStyle == #rounded! ! !BorderedMorph methodsFor: 'menu' stamp: 'jm 10/9/2002 07:30'! 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]. ((borderColor == #raised) or: [borderColor == #inset]) ifTrue: [ aCustomMenu add: 'no bevel...' action: #changeBorderColor:]]. self isRectangular ifTrue: [ aCustomMenu addUpdating: #roundedCornersString target: self action: #toggleCornerRounding]. ! ! !BorderedMorph methodsFor: 'menu' stamp: 'di 9/3/1999 09:17'! changeBorderColor: evt | aHand | aHand _ evt ifNotNil: [evt hand] ifNil: [self primaryHand]. aHand changeColorTarget: self selector: #borderColor: originalColor: self borderColor. ! ! !BorderedMorph methodsFor: 'menu' stamp: 'sw 11/29/1999 17:34'! roundedCornersString "Answer the string to put in a menu that will invite the user to switch to the opposite corner-rounding mode" ^ self cornerStyle == #rounded ifTrue: ['stop rounding corners'] ifFalse: ['start rounding corners'] ! ! !BorderedMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! 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: 'initialization' 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: 'menu' stamp: 'jm 6/28/1998 18:17'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'startInfection' action: #startInfection. aCustomMenu add: 'set atom count' action: #setAtomCount. aCustomMenu add: 'show infection history' action: #showInfectionHistory:. ! ! !BouncingAtomsMorph methodsFor: 'menu' stamp: 'jm 6/28/1998 18:04'! setAtomCount | countString count | countString _ FillInTheBlank request: 'Number of atoms?' initialAnswer: self submorphCount printString. countString isEmpty ifTrue: [^ self]. count _ Integer readFrom: (ReadStream on: countString). self removeAllMorphs. self addAtoms: count. ! ! !BouncingAtomsMorph methodsFor: 'menu'! startInfection self submorphsDo: [:m | m infected: false]. self firstSubmorph infected: true. infectionHistory _ OrderedCollection new: 500. transmitInfection _ true. self startStepping. ! ! !BouncingAtomsMorph methodsFor: 'stepping' stamp: 'sw 7/15/1999 07:32'! step "Bounce those atoms!!" | r bounces | super step. bounces _ 0. r _ bounds origin corner: (bounds corner - (8@8)). self submorphsDo: [ :m | (m isMemberOf: AtomMorph) ifTrue: [ (m bounceIn: r) ifTrue: [bounces _ bounces + 1]]]. "compute a 'temperature' that is proportional to the number of bounces divided by the circumference of the enclosing rectangle" self updateTemperature: (10000.0 * bounces) / (r width + r height). transmitInfection ifTrue: [self transmitInfection]. ! ! !BouncingAtomsMorph methodsFor: 'stepping' stamp: 'jm 6/28/1998 18:10'! stepTime "As fast as possible." ^ 0 ! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 6/28/1998 18:10'! 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: 'other'! 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: 'other' stamp: 'di 1/4/1999 20:22'! areasRemainingToFill: aRectangle color isTranslucent ifTrue: [^ Array with: aRectangle] ifFalse: [^ aRectangle areasOutside: self bounds]! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'ls 10/10/1999 13:59'! 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 m1 m2 | count _ submorphs size. sortedAtoms _ submorphs asSortedCollection: [ :mt1 :mt2 | mt1 position x < mt2 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: 'other'! drawOn: aCanvas "Clear the damageReported flag when redrawn." super drawOn: aCanvas. damageReported _ false.! ! !BouncingAtomsMorph methodsFor: 'other'! 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: 'other' stamp: 'jm 6/28/1998 18:31'! showInfectionHistory: evt "Place a graph of the infection history in the world." | graph | infectionHistory isEmpty ifTrue: [^ self]. graph _ GraphMorph new data: infectionHistory. graph extent: ((infectionHistory size + (2 * graph borderWidth) + 5)@(infectionHistory last max: 50)). evt hand attachMorph: graph. ! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 6/28/1998 18:20'! transmitInfection | infected count | 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: [ transmitInfection _ false. self stopStepping]. ! ! !BouncingAtomsMorph methodsFor: 'other' stamp: 'jm 8/10/1998 18:32'! updateTemperature: currentTemperature "Record the current temperature, which is taken to be the number of atoms that have bounced in the last cycle. To avoid too much jitter in the reading, the last several readings are averaged." recentTemperatures == nil ifTrue: [ recentTemperatures _ OrderedCollection new. 20 timesRepeat: [recentTemperatures add: 0]]. recentTemperatures removeLast. recentTemperatures addFirst: currentTemperature. temperature _ recentTemperatures sum asFloat / recentTemperatures size. ! ! !BouncingAtomsMorph class methodsFor: 'instance creation' stamp: 'jm 6/1/2003 20:48'! includeInNewMorphMenu ^ true ! ! Used for compiling and decompiling brace constructs. These now compile into either a fast short form for 4 elements or less: Array braceWith: a with: b ... or a long form of indefinfite length: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray. The erstwhile brace assignment form is no longer supported.! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:06'! matchBraceStreamReceiver: receiver messages: messages ((receiver isMessage: #braceStream: receiver: nil arguments: [:arg | arg isConstantNumber]) and: [messages last isMessage: #braceArray receiver: nil arguments: nil]) ifFalse: [^ nil "no match"]. "Appears to be a long form brace construct" self elements: (messages allButLast collect: [:msg | (msg isMessage: #nextPut: receiver: nil arguments: nil) ifFalse: [^ nil "not a brace element"]. msg arguments first])! ! !BraceNode methodsFor: 'initialize-release' stamp: 'di 11/19/1999 11:19'! matchBraceWithReceiver: receiver selector: selector arguments: arguments selector = (self selectorForShortForm: arguments size) ifFalse: [^ nil "no match"]. "Appears to be a short form brace construct" self elements: arguments! ! !BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 08:58'! emitForValue: stack on: aStream ^ emitNode emitForValue: stack on: aStream! ! !BraceNode methodsFor: 'code generation' stamp: 'di 1/4/2000 11:24'! selectorForShortForm: nElements nElements > 4 ifTrue: [^ nil]. ^ #(braceWithNone braceWith: braceWith:with: braceWith:with:with: braceWith:with:with:with:) at: nElements + 1! ! !BraceNode methodsFor: 'code generation' stamp: 'di 11/19/1999 11:13'! sizeForValue: encoder emitNode _ elements size <= 4 ifTrue: ["Short form: Array braceWith: a with: b ... " MessageNode new receiver: (encoder encodeVariable: #Array) selector: (self selectorForShortForm: elements size) arguments: elements precedence: 3 from: encoder] ifFalse: ["Long form: (Array braceStream: N) nextPut: a; nextPut: b; ...; braceArray" CascadeNode new receiver: (MessageNode new receiver: (encoder encodeVariable: #Array) selector: #braceStream: arguments: (Array with: (encoder encodeLiteral: elements size)) precedence: 3 from: encoder) messages: ((elements collect: [:elt | MessageNode new receiver: nil selector: #nextPut: arguments: (Array with: elt) precedence: 3 from: encoder]) copyWith: (MessageNode new receiver: nil selector: #braceArray arguments: (Array new) precedence: 1 from: encoder))]. ^ emitNode sizeForValue: encoder! ! !BraceNode methodsFor: 'printing' stamp: 'di 11/19/1999 09:17'! printOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !BraceNode class methodsFor: 'examples' stamp: 'di 11/19/1999 09:05'! example "Test the {a. b. c} syntax." | x | x _ {1. {2. 3}. 4}. ^ {x first. x second first. x second last. x last. 5} as: Set "BraceNode example Set (0 1 2 3 4 5 )" ! ! I represent a query path into the class descriptions, the software of the system.! !Browser methodsFor: 'initialize-release' stamp: 'di 4/13/1999 13:54'! buildCommentSwitchView | aSwitchView | aSwitchView _ PluggableButtonView on: self getState: #classCommentIndicated action: #plusButtonHit. aSwitchView label: '?' asText allBold; borderWidthLeft: 0 right: 1 top: 0 bottom: 0; window: (0@0 extent: 10@8); askBeforeChanging: true. ^ aSwitchView ! ! !Browser methodsFor: 'initialize-release' stamp: 'di 4/13/1999 14:05'! buildMorphicSwitches | instanceSwitch commentSwitch classSwitch row aColor | instanceSwitch _ PluggableButtonMorph on: self getState: #instanceMessagesIndicated action: #indicateInstanceMessages. instanceSwitch label: 'instance'; askBeforeChanging: true. commentSwitch _ PluggableButtonMorph on: self getState: #classCommentIndicated action: #plusButtonHit. commentSwitch label: '?' asText allBold; askBeforeChanging: true; setBalloonText: 'class comment'. 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. aColor _ Color colorFrom: self defaultBackgroundColor. row submorphs do: [:m | m color: aColor. m onColor: aColor darker offColor: aColor]. ^ row ! ! !Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:32'! buildOptionalButtonsView | aView buttonView offset bWidth bHeight first previousView | aView _ View new model: self. bHeight _ self optionalButtonHeight. aView window: (0 @ 0 extent: 200 @ bHeight). offset _ 0. first _ true. previousView _ nil. self optionalButtonPairs do: [:pair | buttonView _ PluggableButtonView on: self getState: nil action: pair last. buttonView label: pair first asParagraph. bWidth _ buttonView label boundingBox width // 2. "Need something more deterministic." buttonView window: (offset@0 extent: bWidth@bHeight). offset _ offset + bWidth + 0. first ifTrue: [aView addSubView: buttonView. first _ false] ifFalse: [buttonView borderWidthLeft: 1 right: 0 top: 0 bottom: 0. aView addSubView: buttonView toRightOf: previousView]. previousView _ buttonView]. ^ aView! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 1/13/2000 16:45'! defaultBrowserTitle ^ 'System Browser'! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 9/22/1999 17:13'! methodCategoryChanged self changed: #messageCategoryList. self changed: #messageList. self changed: #annotation. self messageListIndex: 0! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/11/2002 08:42'! openAsMorphClassEditing: editString "Create a pluggable version a Browser on just a single class." | window switches codePane baseline aTextMorph | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #classListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #classListMenu: keystroke: #classListKey:from:) frame: (0@0 extent: 0.5@0.06). switches _ self buildMorphicSwitches. window addMorph: switches frame: (0.5@0 extent: 0.5@0.06). switches borderWidth: 0. window addMorph: (PluggableMessageCategoryListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList) frame: (0@0.06 extent: 0.5@0.30). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:) frame: (0.5@0.06 extent: 0.5@0.30). Preferences useAnnotationPanes ifFalse: [baseline _ 0.36] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.36 corner: 1@0.41). baseline _ 0.41]. Preferences optionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. 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@baseline corner: 1@1). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/11/2002 08:43'! openAsMorphEditing: editString "Create a pluggable version of all the morphs for a Browser in Morphic" | window switches codePane aListMorph baseline aTextMorph | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #systemCategoryMenu: keystroke: #systemCatListKey:from:) frame: (0@0 extent: 0.25@0.4). window addMorph: (PluggableListMorph on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:) frame: (0.25@0 extent: 0.25@0.3). switches _ self buildMorphicSwitches. window addMorph: switches frame: (0.25@0.3 extent: 0.25@0.1). switches borderWidth: 0. window addMorph: (PluggableMessageCategoryListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList) frame: (0.5@0 extent: 0.25@0.4). aListMorph _ PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0.75@0 extent: 0.25@0.4). Preferences useAnnotationPanes ifFalse: [baseline _ 0.4] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.4 corner: 1@0.45). baseline _ 0.45]. Preferences optionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. 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 @ baseline corner: 1 @ 1). window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/11/2002 08:45'! openAsMorphMessageEditing: editString "Create a pluggable version a Browser that shows just one message" | window codePane baseline aTextMorph | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:) frame: (0@0 extent: 1.0@0.06). Preferences useAnnotationPanes ifFalse: [baseline _ 0.06] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.06 corner: 1@0.11). baseline _ 0.11]. Preferences optionalButtons ifTrue: [ window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. 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@baseline corner: 1@1). ^ window ! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/11/2002 08:45'! openAsMorphMsgCatEditing: editString "Create a pluggable version a Browser on just a messageCategory." | window codePane baseline aTextMorph | 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: keystroke: #messageListKey:from:) frame: (0@0.06 extent: 1.0@0.30). Preferences useAnnotationPanes ifFalse: [baseline _ 0.30] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.30 corner: 1@0.35). baseline _ 0.35]. Preferences optionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. 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@baseline corner: 1@1). window setUpdatablePanesFrom: #(messageCatListSingleton messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/11/2002 08:46'! openAsMorphSysCatEditing: editString "Create a pluggable version of all the views for a Browser, including views and controllers." | window switches codePane baseline aTextMorph | window _ (SystemWindow labelled: 'later') model: self. window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:) frame: (0@0 extent: 1.0@0.06). window addMorph: (PluggableListMorph on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:) frame: (0@0.06 extent: 0.3333@0.24). switches _ self buildMorphicSwitches. window addMorph: switches frame: (0@0.3 extent: 0.3333@0.06). switches borderWidth: 0. window addMorph: (PluggableMessageCategoryListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu: keystroke: #arrowKey:from: getRawListSelector: #rawMessageCategoryList) frame: (0.3333@0.06 extent: 0.3333@0.30). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:) frame: (0.6666@0.06 extent: 0.3333@0.30). Preferences useAnnotationPanes ifFalse: [baseline _ 0.36] ifTrue: [baseline _ 0.41. aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.36 corner: 1@baseline)]. Preferences optionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. 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@baseline corner: 1@1). window setUpdatablePanesFrom: #( classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 09:20'! openEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | systemCategoryListView classListView messageCategoryListView messageListView browserCodeView topView switchView underPane y optionalButtonsView annotationPane | Smalltalk isMorphic ifTrue: [^ self openAsMorphEditing: aString]. "Sensor leftShiftDown ifTrue: [^ self openAsMorphEditing: aString]. uncomment-out for testing morphic browser embedded in mvc project" 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: keystroke: #systemCatListKey:from:. systemCategoryListView window: (0 @ 0 extent: 50 @ 70). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:. 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). messageListView menuTitleSelector: #messageListSelectorTitle. topView addSubView: messageListView toRightOf: messageCategoryListView. Preferences useAnnotationPanes ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: systemCategoryListView. underPane _ annotationPane. y _ 110 - self optionalAnnotationHeight] ifFalse: [ underPane _ systemCategoryListView. y _ 110]. Preferences optionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 09:20'! openMessageCatEditString: aString "Create a pluggable version of the views for a Browser that just shows one message category." | messageCategoryListView messageListView browserCodeView topView annotationPane underPane y optionalButtonsView | Smalltalk isMorphic ifTrue: [^ 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 menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 200 @ 70). topView addSubView: messageListView below: messageCategoryListView. Preferences useAnnotationPanes ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageListView. underPane _ annotationPane. y _ (200 - 12 - 70) - self optionalAnnotationHeight] ifFalse: [underPane _ messageListView. y _ (200 - 12 - 70)]. Preferences optionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(messageCatListSingleton messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 09:21'! openMessageEditString: aString "Create a pluggable version of the views for a Browser that just shows one message." | messageListView browserCodeView topView annotationPane underPane y | Smalltalk isMorphic ifTrue: [^ 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. Preferences useAnnotationPanes ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageListView. underPane _ annotationPane. y _ (200 - 12) - self optionalAnnotationHeight] ifFalse: [underPane _ messageListView. y _ 200 - 12]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 09:21'! openOnClassWithEditString: aString "Create a pluggable version of all the views for a Browser, including views and controllers." | classListView messageCategoryListView messageListView browserCodeView topView switchView annotationPane underPane y optionalButtonsView | Smalltalk isMorphic ifTrue: [^ 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: keystroke: #classListKey:from:. 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 menuTitleSelector: #messageListSelectorTitle. 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. Preferences useAnnotationPanes ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: messageCategoryListView. underPane _ annotationPane. y _ (200-12-70) - self optionalAnnotationHeight] ifFalse: [underPane _ messageCategoryListView. y _ (200-12-70)]. Preferences optionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(messageCategoryList messageList). ^ topView ! ! !Browser methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 09:21'! 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 y annotationPane underPane optionalButtonsView | Smalltalk isMorphic ifTrue: [^ 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: #systemCatSingletonMenu: keystroke: #systemCatSingletonKey:from:. systemCategoryListView window: (0 @ 0 extent: 200 @ 12). topView addSubView: systemCategoryListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:. 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 menuTitleSelector: #messageListSelectorTitle. messageListView window: (0 @ 0 extent: 67 @ 70). topView addSubView: messageListView toRightOf: messageCategoryListView. Preferences useAnnotationPanes ifTrue: [ annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 200@self optionalAnnotationHeight). topView addSubView: annotationPane below: switchView. y _ 110 - 12 - self optionalAnnotationHeight. underPane _ annotationPane] ifFalse: [ y _ 110 - 12. underPane _ switchView]. Preferences optionalButtons ifTrue: [optionalButtonsView _ self buildOptionalButtonsView. optionalButtonsView borderWidth: 1. topView addSubView: optionalButtonsView below: underPane. underPane _ optionalButtonsView. y _ y - self optionalButtonHeight]. browserCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. browserCodeView window: (0@0 extent: 200@y). topView addSubView: browserCodeView below: underPane. aString ifNotNil: [browserCodeView editString: aString. browserCodeView hasUnacceptedEdits: true]. topView setUpdatablePanesFrom: #(classList messageCategoryList messageList). ^ topView! ! !Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:37'! optionalAnnotationHeight ^ 10! ! !Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 12:23'! optionalButtonHeight ^ 10! ! !Browser methodsFor: 'initialize-release' stamp: 'sbw 12/8/1999 06:49'! optionalButtonPairs ^#(('senders' browseSendersOfMessages) ('implementors' browseMessages) ('versions' browseVersions) ('inheritance' methodHierarchy) ('hierarchy' classHierarchy) ('inst vars' browseInstVarRefs) ('class vars' browseClassVarRefs))! ! !Browser methodsFor: 'initialize-release' stamp: 'jm 10/13/2002 18:05'! optionalButtonRow | aRow aButton | aRow _ AlignmentMorph newRow. aRow isSticky: true. aRow hResizing: #spaceFill. aRow centering: #center. aRow setProperty: #clipToOwnerWidth toValue: true. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonPairs do: [:pair | aButton _ PluggableButtonMorph on: self getState: nil action: pair second. aButton useRoundedCorners; label: pair first asString; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. aRow addMorphBack: self diffButton. ^ aRow! ! !Browser methodsFor: 'initialize-release' stamp: 'm3r 3/5/1999 22:58'! 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 + 1. "<- FIXED offset" messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 5/26/1999 23:46'! setSelector: aSymbol "Make the receiver point at the given selector, in the currently chosen class" | aClass messageCatIndex | aSymbol ifNil: [^ self]. (aClass _ self selectedClassOrMetaClass) ifNil: [^ self]. messageCatIndex _ aClass organization numberOfCategoryOfElement: aSymbol. self messageCategoryListIndex: messageCatIndex + 1. messageCatIndex = 0 ifTrue: [^ self]. self messageListIndex: ((aClass organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)! ! !Browser methodsFor: 'initialize-release' stamp: 'sw 11/8/1999 13:36'! systemCatSingletonKey: aChar from: aView ^ self messageListKey: aChar from: aView! ! !Browser methodsFor: 'accessing' stamp: 'sw 5/4/2000 20:22'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method of the currently selected class and message." | comment theClass latestCompiledMethod | latestCompiledMethod _ currentCompiledMethod. currentCompiledMethod _ nil. editSelection == #none ifTrue: [^ '']. editSelection == #editSystemCategories ifTrue: [^ systemOrganizer printString]. editSelection == #newClass ifTrue: [^ (theClass _ self selectedClassOrMetaClass) ifNil: [Class template: self selectedSystemCategoryName] ifNotNil: [Class templateForSubclassOf: theClass category: 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: [currentCompiledMethod _ latestCompiledMethod. ^ self selectedMessage]. editSelection == #byteCodes ifTrue: [^ (self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) symbolic asText]. self error: 'Browser internal error: unknown edit selection.'! ! !Browser methodsFor: 'accessing' stamp: 'sw 9/30/1999 13:19'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | self changed: #annotation. aString _ input asString. aText _ input asText. editSelection == #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 stamp: Utilities changeStamp. ^ true]. editSelection == #hierarchy ifTrue: [^ true]. editSelection == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. editSelection == #editMessage | (editSelection == #newMessage) ifTrue: [^ self okayToAccept ifFalse: [false] ifTrue: [self compileMessage: aText notifying: aController]]. editSelection == #none ifTrue: [PopUpMenu notify: 'This text cannot be accepted in this part of the browser.'. ^ false]. self error: 'unacceptable accept'! ! !Browser methodsFor: 'accessing' stamp: 'di 6/21/1998 22:20'! couldBrowseAnyClass "Answer whether the receiver is equipped to browse any class. This is in support of the system-brower feature that allows the browser to be redirected at the selected class name. This implementation is clearly ugly, but the feature it enables is handsome enough. 3/1/96 sw" self dependents detect: [:d | ((d isKindOf: PluggableListView) or: [d isKindOf: PluggableListMorph]) and: [d getListSelector == #systemCategoryList]] ifNone: [^ false]. ^ true ! ! !Browser methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:28'! doItReceiver "This class's classPool has been jimmied to be the classPool of the class being browsed. A doIt in the code pane will let the user see the value of the class variables." ^ self selectedClass ifNil: [FakeClassPool new]! ! !Browser methodsFor: 'accessing' stamp: 'sw 10/30/1999 22:59'! noteSelectionIndex: anInteger for: aSymbol aSymbol == #systemCategoryList ifTrue: [systemCategoryListIndex _ anInteger]. aSymbol == #classList ifTrue: [classListIndex _ anInteger]. aSymbol == #messageCategoryList ifTrue: [messageCategoryListIndex _ anInteger]. aSymbol == #messageList ifTrue: [messageListIndex _ anInteger].! ! !Browser methodsFor: 'system category list' stamp: 'stp 01/13/2000 12:25'! selectCategoryForClass: theClass self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category) ! ! !Browser methodsFor: 'system category list' stamp: 'di 12/6/1999 20:11'! selectedEnvironment "Answer the name of the selected system category or nil." systemCategoryListIndex = 0 ifTrue: [^nil]. ^ Smalltalk environmentForCategory: self selectedSystemCategoryName! ! !Browser methodsFor: 'system category list' stamp: 'sw 1/28/1999 12:30'! 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 contentsChanged. ! ! !Browser methodsFor: 'system category functions' stamp: 'sw 1/28/1999 12:30'! 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 contentsChanged! ! !Browser methodsFor: 'system category functions' stamp: 'stp 01/13/2000 12:26'! findClass "Search for a class by name." | pattern foundClass classNames index toMatch exactMatch potentialClassNames | self okToChange ifFalse: [^ self classNotFound]. pattern _ FillInTheBlank request: 'Class name or fragment?'. pattern isEmpty ifTrue: [^ self classNotFound]. toMatch _ (pattern copyWithout: $.) asLowercase. potentialClassNames _ self potentialClassNames asOrderedCollection. classNames _ pattern last = $. ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. classNames isEmpty ifTrue: [^ self classNotFound]. exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil]. index _ classNames size = 1 ifTrue: [1] ifFalse: [exactMatch ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUp] ifNotNil: [classNames addFirst: exactMatch. (PopUpMenu labelArray: classNames lines: #(1)) startUp]]. index = 0 ifTrue: [^ self classNotFound]. foundClass _ Smalltalk at: (classNames at: index) asSymbol. self selectCategoryForClass: foundClass. self selectClass: foundClass ! ! !Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 10:04'! potentialClassNames "Answer the names of all the classes that could be viewed in this browser. This hook is provided so that HierarchyBrowsers can indicate their restricted subset. For generic Browsers, the entire list of classes known to Smalltalk is provided, though of course that really only is accurate in the case of full system browsers." ^ Smalltalk classNames! ! !Browser methodsFor: 'system category functions' stamp: 'sw 11/8/1999 14:07'! systemCatSingletonMenu: aMenu ^ aMenu labels: 'browse all browse printOut fileOut update rename... remove' lines: #(2 4) selections: #(browseAllClasses buildSystemCategoryBrowser printOutSystemCategory fileOutSystemCategory updateSystemCategories renameSystemCategory removeSystemCategory) ! ! !Browser methodsFor: 'system category functions' stamp: 'sma 2/5/2000 13:24'! systemCategoryMenu: aMenu ^ aMenu labels: 'find class... (f) recent classes... (r) 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: 'class list' stamp: 'sw 4/5/2000 10:54'! 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 | (systemCategoryListIndex == 0) ifTrue: [#none] ifFalse: [#newClass]] ifFalse: [#editClass]]. contents _ nil. self selectedClass isNil ifFalse: [className _ self selectedClass name. (RecentClasses includes: className) ifTrue: [RecentClasses remove: className]. RecentClasses addFirst: className. RecentClasses size > 16 ifTrue: [RecentClasses removeLast]]. self changed: #classSelectionChanged. self changed: #classListIndex. "update my selection" self changed: #messageCategoryList. self changed: #messageList. self contentsChanged! ! !Browser methodsFor: 'class list' stamp: 'stp 01/13/2000 12:57'! 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 selectCategoryForClass: class. self classListIndex: (self classList indexOf: class name)! ! !Browser methodsFor: 'class list' stamp: 'sr 10/29/1999 20:28'! selectClass: classNotMeta self classListIndex: (self classList indexOf: classNotMeta name)! ! !Browser methodsFor: 'class list' stamp: 'di 12/6/1999 20:41'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." | name envt | (name _ self selectedClassName) ifNil: [^ nil]. (envt _ self selectedEnvironment) ifNil: [^ nil]. ^ envt at: name! ! !Browser methodsFor: 'class list' stamp: 'sw 11/24/1999 14:48'! selectedClassName | aClassList | "Answer the name of the current class. Answer nil if no selection exists." (classListIndex = 0 or: [classListIndex > (aClassList _ self classList) size]) ifTrue: [^ nil]. ^ aClassList at: classListIndex! ! !Browser methodsFor: 'class functions' stamp: 'jm 9/25/2006 21:58'! classListMenu: aMenu ^ aMenu addList: #( - ('browse full (b)' browseMethodFull) ('browse hierarchy' spawnHierarchy) ('browse protocol' spawnProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('show hierarchy' hierarchy) ('show definition' editClass) ('show comment' editComment) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) - ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('rename class ...' renameClass) ('copy class' copyClass) ('remove class (x)' removeClass) - ('unsent methods' browseUnusedMethods) ('unreferenced inst vars' showUnreferencedInstVars) ('subclass template' makeNewSubclass) - ('find method...' findMethod)) ! ! !Browser methodsFor: 'class functions' stamp: 'dwh 11/23/1999 00:09'! copyClass | originalName copysName class oldDefinition newDefinition | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. originalName _ self selectedClass name. copysName _ self request: 'Please type new class name' initialAnswer: originalName. copysName = '' ifTrue: [^ self]. " Cancel returns '' " copysName _ copysName asSymbol. copysName = originalName ifTrue: [^ self]. (Smalltalk includesKey: copysName) ifTrue: [^ self error: copysName , ' already exists']. oldDefinition _ self selectedClass definition. newDefinition _ oldDefinition copyReplaceAll: '#' , originalName asString with: '#' , copysName asString. Cursor wait showWhile: [class _ Compiler evaluate: newDefinition logged: true. class copyAllCategoriesFrom: (Smalltalk at: originalName). class class copyAllCategoriesFrom: (Smalltalk at: originalName) class]. self classListIndex: 0. self changed: #classList! ! !Browser methodsFor: 'class functions' stamp: 'di 12/23/1999 11:53'! defineClass: defString notifying: aController "The receiver's textual content is a request to define a new class. The source code is defString. If any errors occur in compilation, notify aController." | oldClass class newClassName defTokens keywdIx envt | oldClass _ self selectedClassOrMetaClass. defTokens _ defString findTokens: Character separators. keywdIx _ defTokens indexOf: 'category:'. envt _ Smalltalk environmentForCategory: ((defTokens at: keywdIx+1) copyWithout: $'). keywdIx _ defTokens findFirst: [:x | x endsWith: 'ubclass:']. newClassName _ (defTokens at: keywdIx+1) copyWithout: $#. ((oldClass isNil or: [oldClass name asString ~= newClassName]) and: [envt includesKeyOrAbove: newClassName asSymbol]) ifTrue: ["Attempting to define new class over existing one when not looking at the original one in this browser..." (self confirm: ((newClassName , ' is an existing class in this system. Redefining it might cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: newClassName size)) ifFalse: [^ false]]. "ar 8/29/1999: Use oldClass superclass for defining oldClass since oldClass superclass knows the definerClass of oldClass." oldClass ifNotNil:[oldClass _ oldClass superclass]. class _ oldClass subclassDefinerClass evaluate: defString notifying: aController logged: true. (class isKindOf: Behavior) ifTrue: [self changed: #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: 'sw 1/28/1999 22:56'! 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 contentsChanged ! ! !Browser methodsFor: 'class functions' stamp: 'jm 5/29/2003 19:01'! 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 copy asArray sort. 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: 'sw 1/28/1999 12:30'! 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 contentsChanged. ^ self! ! !Browser methodsFor: 'class functions' stamp: 'sw 5/4/2000 20:19'! makeNewSubclass self selectedClassOrMetaClass ifNil: [^ self]. self okToChange ifFalse: [^ self]. editSelection _ #newClass. self contentsChanged! ! !Browser methodsFor: 'class functions' stamp: 'sw 1/28/1999 18:27'! plusButtonHit "Cycle between definition, comment, and hierachy" editSelection == #editComment ifTrue: [self hierarchy. ^ self]. editSelection == #hierarchy ifTrue: [editSelection := #editClass. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self changed: #editComment. self contentsChanged. ^self]. classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self messageCategoryListIndex: 0. editSelection := #editComment. self changed: #classSelectionChanged. self contentsChanged.! ! !Browser methodsFor: 'class functions' stamp: 'jm 10/8/2002 05:30'! removeClass "The selected class should be removed from the system. Make certain the user intends this irrevocable command to be carried out." | c n | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. c _ self selectedClass. (self confirm: 'Really delete ', c name, '?') ifFalse: [^ self]. c subclasses size > 0 ifTrue: [ (self confirm: c name, ' has subclasses. Proceed?') ifFalse: [^ self]]. n _ c instanceCount. n > 0 ifTrue: [ (self confirm: c name, ' has ', n printString, ' instances. Proceed?') ifFalse: [^ self]]. ((Smalltalk includesKey: c name) and: [(Smalltalk allCallsOn: (Smalltalk associationAt: c name)) size > 0]) ifTrue: [ (self confirm: c name, ' is referenced. Proceed?') ifFalse: [^ self]]. "okay, really remove it" c removeFromSystem. self classListIndex: 0. self changed: #classList. ! ! !Browser methodsFor: 'class functions' stamp: 'dwh 11/23/1999 00:25'! renameClass | oldName newName obs | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ self request: 'Please type new class name' initialAnswer: oldName. newName = '' ifTrue: [^ self]. " Cancel returns '' " newName _ newName asSymbol. newName = oldName ifTrue: [^ self]. (Smalltalk includesKey: newName) ifTrue: [^ self error: newName , ' already exists']. self selectedClass rename: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). obs _ Smalltalk allCallsOn: (Smalltalk associationAt: newName). obs isEmpty ifFalse: [Smalltalk browseMessageList: obs name: 'Obsolete References to ' , oldName autoSelect: oldName]. ! ! !Browser methodsFor: 'message category list' stamp: 'ccn 2/22/1999 18:45'! categoryOfCurrentMethod "Determine the category that owns the current method. Return the category name." ^ self selectedClassOrMetaClass whichCategoryIncludesSelector: self selectedMessageName! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:56'! messageCategoryList "Answer the selected category of messages." classListIndex = 0 ifTrue: [^ Array new] ifFalse: [^ (Array with: ClassOrganizer allCategory), self classOrMetaClassOrganizer categories]! ! !Browser methodsFor: 'message category list' stamp: 'sw 5/16/2000 11:29'! 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 contentsChanged ! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/24/1999 11:02'! messageCategoryListSelection "Return the selected category name or nil." ^ ((self messageCategoryList size = 0 or: [self messageCategoryListIndex = 0]) or: [self messageCategoryList size < self messageCategoryListIndex]) ifTrue: [nil] ifFalse: [self messageCategoryList at: (self messageCategoryListIndex max: 1)]! ! !Browser methodsFor: 'message category list' stamp: 'sw 10/16/1999 22:56'! rawMessageCategoryList ^ classListIndex = 0 ifTrue: [Array new] ifFalse: [self classOrMetaClassOrganizer categories]! ! !Browser methodsFor: 'message category list' stamp: 'ccn+ceg 2/9/1999 20:25'! selectMessageCategoryNamed: aSymbol "Given aSymbol, select the category with that name. Do nothing if aSymbol doesn't exist." (self messageCategoryList includes: aSymbol) ifFalse: [^ self]. self messageCategoryListIndex: (self messageCategoryList indexOf: aSymbol)! ! !Browser methodsFor: 'message category list' stamp: 'ccn 3/22/1999 17:57'! selectOriginalCategoryForCurrentMethod "private - Select the message category for the current method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected. Returns: true on success, false on failure." | aSymbol | aSymbol _ self categoryOfCurrentMethod. (aSymbol notNil and: [aSymbol ~= ClassOrganizer allCategory]) ifTrue: [self selectMessageCategoryNamed: aSymbol. ^ true]. ^ false! ! !Browser methodsFor: 'message category list' stamp: 'ccn+ceg 5/13/1999 19:54'! setOriginalCategoryIndexForCurrentMethod "private - Set the message category index for the currently selected method. Note: This should only be called when somebody tries to save a method that they are modifying while ALL is selected." messageCategoryListIndex _ self messageCategoryList indexOf: self categoryOfCurrentMethod ! ! !Browser methodsFor: 'message category functions' stamp: 'mir 5/5/2000 16:02'! addCategory "Present a choice of categories or prompt for a new category name and add it before the current selection, or at the end if no current selection" | labels reject lines cats menuIndex oldIndex newName | self okToChange ifFalse: [^ self]. classListIndex = 0 ifTrue: [^ self]. labels _ OrderedCollection with: 'new...'. reject _ Set new. reject addAll: self selectedClassOrMetaClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines _ OrderedCollection new. self selectedClassOrMetaClass allSuperclasses do: [:cls | cls = Object ifFalse: [ cats _ cls organization categories reject: [:cat | reject includes: cat]. cats isEmpty ifFalse: [ lines add: labels size. labels addAll: cats asSortedCollection. reject addAll: cats]]]. newName _ (labels size = 1 or: [ menuIndex _ (PopUpMenu labelArray: labels lines: lines) startUpWithCaption: 'Add Category'. menuIndex = 0 ifTrue: [^ self]. menuIndex = 1]) ifTrue: [ self request: 'Please type new category name' initialAnswer: 'category name'] ifFalse: [ labels at: menuIndex]. oldIndex _ messageCategoryListIndex. newName 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 + 1] ifFalse: [oldIndex]). self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message category functions' stamp: 'di 3/28/2000 15:55'! alphabetizeMessageCategories classListIndex = 0 ifTrue: [^ false]. self okToChange ifFalse: [^ false]. Smalltalk changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer categories: self rawMessageCategoryList asSortedCollection asArray. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'wod 6/24/1998 02:10'! buildMessageCategoryBrowserEditString: aString "Create and schedule a message category browser for the currently selected message category. The initial text view contains the characters in aString." "wod 6/24/1998: set newBrowser classListIndex so that it works whether the receiver is a standard or a Hierarchy Browser." | newBrowser | messageCategoryListIndex ~= 0 ifTrue: [newBrowser _ Browser new. newBrowser systemCategoryListIndex: systemCategoryListIndex. newBrowser classListIndex: (newBrowser classList indexOf: self selectedClassName). newBrowser metaClassIndicated: metaClassIndicated. newBrowser messageCategoryListIndex: messageCategoryListIndex. newBrowser messageListIndex: messageListIndex. Browser openBrowserView: (newBrowser openMessageCatEditString: aString) label: 'Message Category Browser (' , newBrowser selectedClassOrMetaClassName , ')']! ! !Browser methodsFor: 'message category functions' stamp: 'di 3/28/2000 15:56'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." Smalltalk changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer changeFromString: aString. self clearUserEditFlag. self editClass. self classListIndex: classListIndex. ^ true! ! !Browser methodsFor: 'message category functions' stamp: 'sw 1/28/1999 12:30'! 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 contentsChanged]! ! !Browser methodsFor: 'message category functions' stamp: 'sw 10/14/1999 16:53'! messageCategoryMenu: aMenu ^ aMenu labels: 'browse printOut fileOut reorganize alphabetize remove empty categories new category... rename... remove' lines: #(3 7) selections: #(buildMessageCategoryBrowser printOutMessageCategories fileOutMessageCategories editMessageCategories alphabetizeMessageCategories removeEmptyCategories addCategory renameCategory removeMessageCategory) ! ! !Browser methodsFor: 'message category functions' stamp: 'sma 2/27/2000 10:14'! removeEmptyCategories messageCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'message category functions' stamp: 'di 3/28/2000 15:56'! 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]. Smalltalk changes reorganizeClass: self selectedClassOrMetaClass. self classOrMetaClassOrganizer renameCategory: oldName toBe: newName. self classListIndex: classListIndex. self messageCategoryListIndex: oldIndex. self changed: #messageCategoryList. ! ! !Browser methodsFor: 'message list' stamp: 'ccn 3/24/1999 10:48'! messageList "Answer an Array of the message selectors of the currently selected message category, provided that the messageCategoryListIndex is in proper range. Otherwise, answer an empty Array If messageCategoryListIndex is found to be larger than the number of categories (it happens!!), it is reset to zero." | sel | (sel _ self messageCategoryListSelection) ifNil: [^ Array new]. ^ sel = ClassOrganizer allCategory ifTrue: [self classOrMetaClassOrganizer ifNil: [Array new] ifNotNil: [self classOrMetaClassOrganizer allMethodSelectors]] ifFalse: [(self classOrMetaClassOrganizer listAtCategoryNumber: messageCategoryListIndex - 1) ifNil: [messageCategoryListIndex _ 0. Array new]]! ! !Browser methodsFor: 'message list' stamp: 'sw 9/22/1999 17:17'! 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 contentsChanged! ! !Browser methodsFor: 'message list' stamp: 'hg 3/13/2000 11:49'! 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 ifAbsent: [ ^ '']. "method deleted while in another project" currentCompiledMethod _ method. (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 _ contents asText makeSelectorBoldIn: class. ^ 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: class. ^ contents copy]. contents _ class sourceCodeAt: selector. self validateMessageSource: selector. Preferences browseWithPrettyPrint ifTrue: [contents _ class compilerClass new format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. self showDiffs ifTrue: [contents _ self diffFromPriorSourceFor: contents]. contents _ contents asText makeSelectorBoldIn: class. ^ contents copy! ! !Browser methodsFor: 'message list' stamp: 'sw 10/19/1999 17:39'! selectedMessageName | aList | "Answer the message selector of the currently selected message, if any. Answer nil otherwise." messageListIndex = 0 ifTrue: [^ nil]. ^ (aList _ self messageList) size >= messageListIndex ifTrue: [aList at: messageListIndex] ifFalse: [nil]! ! !Browser methodsFor: 'message list' stamp: 'hg 3/13/2000 12:07'! validateMessageSource: selector (self selectedClass compilerClass == Object compilerClass and: [(contents asString findString: selector keywords first ) ~= 1]) ifTrue: [ PopUpMenu notify: 'Possible problem with source file!! The method source should start with the method selector but this is not the case!! You may proceed with caution but it is recommended that you get a new source file. This can happen if you download the "SqueakV2.sources" file, or the ".changes" file you use, as TEXT. It must be transfered in BINARY mode, even if it looks like a text file, to preserve the CR line ends. Mac users: This may have been caused by Stuffit Expander. To prevent the files above to be converted to Mac line ends when they are expanded, do this: Start the program, then from Preferences... in the File menu, choose the Cross Platform panel, then select "Never" and press OK. Then expand the compressed archive again.'].! ! !Browser methodsFor: 'message functions' stamp: 'di 11/24/1999 13:40'! defineMessageFrom: aString notifying: aController "Compile the expressions in aString. Notify aController if a syntax error occurs. Install the compiled method in the selected class classified under the currently selected message category name. Answer the selector obtained if compilation succeeds, nil otherwise." | selectedMessageName selector category oldMessageList | selectedMessageName _ self selectedMessageName. oldMessageList _ self messageList. contents _ nil. selector _ (Parser new parseSelector: aString). (self metaClassIndicated and: [(self selectedClassOrMetaClass includesSelector: selector) not and: [Metaclass isScarySelector: selector]]) ifTrue: ["A frist-time definition overlaps the protocol of Metaclasses" (self confirm: ((selector , ' is used in the existing class system. Overriding it could cause serious problems. Is this really what you want to do?') asText makeBoldFrom: 1 to: selector size)) ifFalse: [^nil]]. selector _ self selectedClassOrMetaClass compile: aString classified: (category _ self selectedMessageCategoryName) notifying: aController. selector == nil ifTrue: [^ nil]. contents _ aString copy. selector ~~ selectedMessageName ifTrue: [category = ClassOrganizer nullCategory ifTrue: [self changed: #classSelectionChanged. self changed: #classList. self messageCategoryListIndex: 1]. self setClassOrganizer. "In case organization not cached" (oldMessageList includes: selector) ifFalse: [self changed: #messageList]. self messageListIndex: (self messageList indexOf: selector)]. ^ selector! ! !Browser methodsFor: 'message functions' stamp: 'jm 9/25/2006 21:59'! messageListMenu: aMenu shifted: shifted | aList | aList _ shifted ifFalse: [#( ('browse full (b)' browseMethodFull) ('browse hierarchy' classHierarchy) ('browse method (O)' openSingleMessageBrowser) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class variables' browseClassVariables) ('class refs (N)' browseClassRefs) - ('remove method (x)' removeMessage) - ('more...' shiftedYellowButtonActivity))] ifTrue: [#( ('toggle diffing' toggleDiffing) ('implementors of sent messages' browseAllMessages) - ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('remove from this browser' removeMessageFromBrowser) ('change category...' changeCategory) - ('change sets with this method' findMethodInChangeSets) ('revert to previous version' revertToPreviousVersion) ('remove from current change set' removeFromCurrentChanges) ('revert and forget' revertAndForget) - ('more...' unshiftedYellowButtonActivity))]. ^ aMenu addList: aList ! ! !Browser methodsFor: 'message functions' stamp: 'di 5/27/1998 15:45'! 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 messageListIndex: 0. self changed: #messageList. self setClassOrganizer. "In case organization not cached" confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName] ! ! !Browser methodsFor: 'code pane' stamp: 'sw 5/26/1999 23:43'! compileMessage: aText notifying: aController "Compile the code that was accepted by the user, placing the compiled method into an appropriate message category. Return true if the compilation succeeded, else false." | fallBackCategoryIndex fallBackMethodIndex originalSelectorName result | self selectedMessageCategoryName asSymbol = ClassOrganizer allCategory ifTrue: [ "User tried to save a method while the ALL category was selected" fallBackCategoryIndex _ messageCategoryListIndex. fallBackMethodIndex _ messageListIndex. editSelection == #newMessage ifTrue: [ "Select the 'as yet unclassified' category" messageCategoryListIndex _ 0. (result _ self defineMessageFrom: aText notifying: aController) ifNil: ["Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex] ifNotNil: [self setSelector: result]] ifFalse: [originalSelectorName _ self selectedMessageName. self setOriginalCategoryIndexForCurrentMethod. messageListIndex _ fallBackMethodIndex _ self messageList indexOf: originalSelectorName. (result _ self defineMessageFrom: aText notifying: aController) ifNotNil: [self setSelector: result] ifNil: [ "Compilation failure: reselect the original category & method" messageCategoryListIndex _ fallBackCategoryIndex. messageListIndex _ fallBackMethodIndex. ^ result notNil]]. self changed: #messageCategoryList. ^ result notNil] ifFalse: [ "User tried to save a method while the ALL category was NOT selected" ^ (self defineMessageFrom: aText notifying: aController) notNil]! ! !Browser methodsFor: 'code pane' stamp: 'sma 5/28/2000 11:03'! showBytecodes "Show or hide the bytecodes of the selected method." (messageListIndex = 0 or: [self okToChange not]) ifTrue: [^ self changed: #flash]. editSelection == #byteCodes ifTrue: [editSelection _ #editMessage] ifFalse: [editSelection _ #byteCodes]. self contentsChanged! ! !Browser class methodsFor: 'instance creation' stamp: 'sw 1/13/2000 16:45'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow classToUse | classToUse _ Preferences browseToolClass. brow _ classToUse new. brow setClass: aClass selector: aSelector. classToUse openBrowserView: (brow openEditString: nil) label: brow defaultBrowserTitle! ! !Browser class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:03'! new ^super new systemOrganizer: SystemOrganization! ! !Browser class methodsFor: 'instance creation' stamp: 'sw 1/13/2000 16:46'! 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' ! ! I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.! I represent an ArrayedCollection whose elements are integers between 0 and 255. ! !ByteArray methodsFor: 'accessing' stamp: 'RAA 6/21/1999 15:53'! asExplorerString ^self printString ! ! !ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! atAllPut: value "Fill the receiver with the given value" super atAllPut: value! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index ^self at: index! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index put: value ^self at: index put: value! ! !ByteArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! bytesPerElement "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." ^ 1! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:44'! longAt: index bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 w h | aBool ifTrue:[ b0 _ self at: index. b1 _ self at: index+1. b2 _ self at: index+2. w _ self at: index+3. ] ifFalse:[ w _ self at: index. b2 _ self at: index+1. b1 _ self at: index+2. b0 _ self at: index+3. ]. "Minimize LargeInteger arithmetic" h _ ((b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80) bitShift: 8) + b1. b2 = 0 ifFalse:[w _ (b2 bitShift: 8) + w]. h = 0 ifFalse:[w _ (h bitShift: 16) + w]. ^w! ! !ByteArray methodsFor: 'platform independent access' stamp: 'ar 11/1/1998 20:47'! longAt: index put: value bigEndian: aBool "Return a 32bit integer quantity starting from the given byte index" | b0 b1 b2 b3 | b0 _ value bitShift: -24. b0 _ (b0 bitAnd: 16r7F) - (b0 bitAnd: 16r80). b1 _ (value bitShift: -16) bitAnd: 255. b2 _ (value bitShift: -8) bitAnd: 255. b3 _ value bitAnd: 255. aBool ifTrue:[ self at: index put: b0. self at: index+1 put: b1. self at: index+2 put: b2. self at: index+3 put: b3. ] ifFalse:[ self at: index put: b3. self at: index+1 put: b2. self at: index+2 put: b1. self at: index+3 put: b0. ]. ^value! ! !ByteArray methodsFor: 'converting' stamp: 'sma 5/12/2000 17:35'! asByteArray ^ self! ! !ByteArray methodsFor: 'comparing' stamp: 'jm 8/3/1999 09:33'! hash "Make sure that equal (=) ByteArrays hash equally." self size = 0 ifTrue: [^ 2001]. ^ ((self at: 1) bitShift: 8) + (self at: self size) ! ! 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: 'interp.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' stamp: 'jm 12/13/1998 10:03'! initialize translationDict _ Dictionary new. inlineList _ Array new. constants _ Dictionary new: 100. variables _ OrderedCollection new: 100. variableDeclarations _ Dictionary new: 100. methods _ Dictionary new: 500. self initializeCTranslationDictionary. ! ! !CCodeGenerator methodsFor: 'public' stamp: 'jm 12/20/2003 19:24'! storeCodeOnFile: fileName doInlining: inlineFlag "Store C code for this code base on the given file." self storeCodeOnFile: fileName doInlining: inlineFlag doAssertions: false! ! !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' stamp: 'jm 12/10/1998 16:18'! 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." | pass progress | inlineFlag ifFalse: [ self inlineDispatchesInMethodNamed: #interpret localizingVars: #(). ^ self]. self collectInlineList. 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 localHomeContext localCP localTP). bar value: 1. self removeMethodsReferingToGlobals: #( currentBytecode localIP localSP localHomeContext localCP localTP) except: #interpret. bar value: 2]. ! ! !CCodeGenerator methodsFor: 'inlining'! inlineDispatchesInMethodNamed: selector localizingVars: varsList "Inline dispatches (case statements) in the method with the given name." | m | m _ self methodNamed: selector. m = nil ifFalse: [ m inlineCaseStatementBranchesIn: self localizingVars: varsList. m parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n customizeShortCasesForDispatchVar: #currentBytecode. ]. ]. ]. variables _ variables asOrderedCollection. varsList do: [ :v | variables remove: v asString ifAbsent: []. (variableDeclarations includesKey: v asString) ifTrue: [ m declarations at: v asString put: (variableDeclarations at: v asString). variableDeclarations removeKey: v asString. ]. ]. ! ! !CCodeGenerator methodsFor: 'inlining'! mayInline: sel "Answer true if the method with the given selector may be inlined." ^ inlineList includes: sel! ! !CCodeGenerator methodsFor: 'inlining'! methodStatsString "Return a string describing the size, # of locals, and # of senders of each method. Note methods that have inline C code or C declarations." | methodsWithCCode sizesOf callsOf hasCCode nodeCount senderCount s calls registers selr | methodsWithCCode _ Set new: methods size. sizesOf _ Dictionary new: methods size * 2. "selector -> nodeCount" callsOf _ Dictionary new: methods size * 2. "selector -> senderCount" "For each method, scan its parse tree once to: 1. determine if the method contains C code or declarations 2. determine how many nodes it has 3. increment the sender counts of the methods it calls 4. determine if it includes any C declarations or code" methods do: [ :m | (translationDict includesKey: m selector) ifTrue: [ hasCCode _ true. ] ifFalse: [ hasCCode _ m declarations size > 0. nodeCount _ 0. m parseTree nodesDo: [ :node | node isSend ifTrue: [ selr _ node selector. selr = #cCode: ifTrue: [ hasCCode _ true ]. senderCount _ callsOf at: selr ifAbsent: [ 0 ]. callsOf at: selr put: senderCount + 1. ]. nodeCount _ nodeCount + 1. ]. ]. hasCCode ifTrue: [ methodsWithCCode add: m selector ]. sizesOf at: m selector put: nodeCount. ]. s _ WriteStream on: (String new: 5000). methods keys asSortedCollection do: [ :sel | m _ methods at: sel. registers _ m locals size + m args size. calls _ callsOf at: sel ifAbsent: [0]. registers > 11 ifTrue: [ s nextPutAll: sel; tab. s nextPutAll: (sizesOf at: sel) printString; tab. s nextPutAll: calls printString; tab. s nextPutAll: registers printString; tab. (methodsWithCCode includes: sel) ifTrue: [ s nextPutAll: 'CCode' ]. s cr. ]. ]. ^ s contents! ! !CCodeGenerator methodsFor: 'inlining' 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' stamp: 'ar 10/7/1998 17:53'! isGeneratingPluginCode ^false! ! !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' stamp: 'jm 11/25/1998 19:02'! nilOrBooleanConstantReceiverOf: sendNode "Answer nil or the boolean constant that is the receiver of the given message send. Used to suppress conditional code when the condition is a translation-time constant." | rcvr val | rcvr _ sendNode receiver. rcvr isConstant ifTrue: [ val _ rcvr value. ((val == true) or: [val == false]) ifTrue: [^ val]]. ^ nil ! ! !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' stamp: 'jm 12/20/2003 19:07'! removeMethodNamed: aSymbol "Remove the given method from the code base." methods removeKey: aSymbol ifAbsent: []. ! ! !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' stamp: 'jm 12/20/2003 19:44'! 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 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' stamp: 'jm 11/24/1998 09:09'! emitCFunctionPrototypesOn: aStream "Store prototype declarations for all non-inlined methods on the given stream." | exporting | aStream nextPutAll: '/*** Function Prototypes ***/'; cr. exporting _ false. methods do: [:m | m export ifTrue: [ exporting ifFalse: [ aStream nextPutAll: '#pragma export on'; cr. exporting _ true]] ifFalse: [ exporting ifTrue: [ aStream nextPutAll: '#pragma export off'; cr. exporting _ false]]. m emitCFunctionPrototype: aStream generator: self. aStream nextPutAll: ';'; cr]. exporting ifTrue: [ aStream nextPutAll: '#pragma export off'; cr]. ! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 12/22/2003 14:12'! 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 "msq.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; /* allows accessing Strings in both C and Smalltalk */ #define asciiValue(c) c '. aStream cr.! ! !CCodeGenerator methodsFor: 'C code generator' stamp: 'jm 9/24/2006 16:17'! 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. aStream nextPutAll: ' #include "msq.h" /* 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) '. 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' stamp: 'ar 10/3/1998 13:45'! generateAsFloat: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." aStream nextPutAll:'((double) '. self emitCExpression: msgNode receiver on: aStream. aStream nextPutAll: ' )'.! ! !CCodeGenerator methodsFor: 'C translation' stamp: 'ar 10/3/1998 13:45'! generateAsInteger: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." aStream nextPutAll:'((int) '. self emitCExpression: msgNode receiver on: aStream. aStream nextPutAll: ' )'.! ! !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' stamp: 'jm 7/5/1998 18:17'! generateDivide: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." | rcvr arg divisor | rcvr _ msgNode receiver. arg _ msgNode args first. (arg isConstant and: [UseRightShiftForDivide and: [(divisor _ arg value) isPowerOfTwo and: [divisor > 0 and: [divisor <= (1 bitShift: 31)]]]]) ifTrue: [ "use signed (arithmetic) right shift instead of divide" aStream nextPutAll: '((int) '. self emitCExpression: rcvr on: aStream. aStream nextPutAll: ' >> ', (divisor log: 2) asInteger printString. aStream nextPutAll: ')'. ] ifFalse: [ self emitCExpression: rcvr on: aStream. aStream nextPutAll: ' / '. self emitCExpression: arg 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' stamp: 'jm 11/25/1998 19:04'! 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." | const | const _ self nilOrBooleanConstantReceiverOf: msgNode. const ifNotNil: [ const ifFalse: [msgNode args first emitCCodeOn: aStream level: level generator: self]. ^ self]. 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' stamp: 'jm 11/25/1998 19:06'! 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. Squeak's compiler does not reverse the blocks, but you may need to fix this method if you wish to cross-compile using VisualWorks." | const | const _ self nilOrBooleanConstantReceiverOf: msgNode. const ifNotNil: [ const ifTrue: [msgNode args last emitCCodeOn: aStream level: level generator: self] ifFalse: [msgNode args first emitCCodeOn: aStream level: level generator: self]. ^ self]. 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' stamp: 'jm 11/25/1998 19:04'! generateIfTrue: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." | const | const _ self nilOrBooleanConstantReceiverOf: msgNode. const ifNotNil: [ const ifTrue: [msgNode args first emitCCodeOn: aStream level: level generator: self]. ^ self]. 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' stamp: 'jm 11/25/1998 19:04'! generateIfTrueIfFalse: msgNode on: aStream indent: level "Generate the C code for this message onto the given stream." | const | const _ self nilOrBooleanConstantReceiverOf: msgNode. const ifNotNil: [ const ifTrue: [msgNode args first emitCCodeOn: aStream level: level generator: self] ifFalse: [msgNode args last emitCCodeOn: aStream level: level generator: self]. ^ self]. 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' stamp: 'jm 10/14/2006 21:26'! generateIsObjectOop: 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) == 0)'.! ! !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 10/14/2006 21:23'! 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: #// #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: #~~ #generateNotEqual: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: #isIntegerOop: #generateIsIntegerObject:on:indent: #isObjectOop: #generateIsObjectOop: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: #asFloat #generateAsFloat:on:indent: #asInteger #generateAsInteger:on:indent: ). 1 to: pairs size by: 2 do: [:i | translationDict at: (pairs at: i) put: (pairs at: i + 1)]. ! ! !CCodeGenerator class methodsFor: 'removing from system' 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']. ! ! !CCodeGenerator class methodsFor: 'class initialization' stamp: 'jm 8/19/1998 10:03'! initialize "CCodeGenerator initialize" UseRightShiftForDivide _ true. "If UseRightShiftForDivide is true, the translator will generate a right-shift when it encounters a division by a constant that is a small power of two. For example, 'x / 8' will generate '((int) x >> 3)'. The coercion to int is done to make it clear that the C compiler should generate a signed shift." "Note: The Kernighan and Ritchie 2nd Edition C manual, p. 49, leaves the semantics of right-shifting a negative number open to the discretion of the compiler implementor. However, it strongly suggests that most compilers should generate an arithmetic right shift (i.e., shifting in the sign bit), which is the same as dividing by a power of two. If your compiler does not generate or simulate an arithmetic shift, then make this class variable false and re-translate." ! ! 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. Subclasses must implement (at least) the following methods: * Drawing: #fillOval:color:borderWidth:borderColor: #frameAndFillRectangle:fillColor:borderWidth:borderColor: #image:at:sourceRect:rule: #stencil:at:sourceRect:color: #line:to:width:color: #paragraph:bounds:color: #text:bounds:font:color: * Support #clipBy:during: #translateBy:during: #translateBy:clippingTo:during: #transformBy:clippingTo:during:smoothing: ! !Canvas methodsFor: 'initialization' stamp: 'jm 10/30/2002 20:55'! reset "Reset the canvas. This default implementation does nothing." ! ! !Canvas methodsFor: 'copying' stamp: 'jm 11/24/2002 10:40'! copy ^ self clone ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:07'! clipRect "Return the currently active clipping rectangle" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'! extent "Return the physical extent of the output device" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'! form ^ Display ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'! origin "Return the current origin for drawing operations" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'jm 11/24/2002 11:16'! shadowColor "Return the current override color or nil if not drawing shadows." ^ nil ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:46'! shadowColor: aColor "Set a shadow color. If set this color overrides any client-supplied color."! ! !Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 19:03'! isShadowDrawing ^false! ! !Canvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:10'! isVisible: aRectangle "Return true if the given rectangle is (partially) visible" ^self clipRect intersects: aRectangle ! ! !Canvas methodsFor: 'converting' stamp: 'jm 11/24/2002 10:54'! asShadowDrawingCanvas "Answer a canvas like me for drawing translucent shadows." ^ self asShadowDrawingCanvas: (Color black alpha: 0.5) ! ! !Canvas methodsFor: 'converting' stamp: 'jm 1/8/2003 11:01'! asShadowDrawingCanvas: aColor "Answer a copy of me for drawing drop-shadows." ^ self copy shadowColor: aColor ! ! !Canvas methodsFor: 'transforms' stamp: 'ar 6/17/1999 02:53'! clipBy: aRectangle during: aBlock "Set a clipping rectangle active only during the execution of aBlock. Note: In the future we may want to have more general clip shapes - not just rectangles" ^self subclassResponsibility! ! !Canvas methodsFor: 'transforms' stamp: 'di 10/16/1999 15:56'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Transform the receiver by the given display transformation during the execution of aBlock. The given clip rectangle defines the *global* (e.g., outer) rectangle against which the receiver should clip (which would be equivalent to 'self clipRect: aClipRect; transformBy: aDisplayTransform')." ^ self subclassResponsibility! ! !Canvas methodsFor: 'transforms'! translateBy:aPoint clippingTo:aRect during:aBlock ^aBlock value:(self copyOffset:aPoint clipRect:aRect).! ! !Canvas methodsFor: 'transforms' stamp: 'ar 6/17/1999 03:00'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." ^self subclassResponsibility! ! !Canvas methodsFor: 'transforms' stamp: 'ar 6/22/1999 14:08'! translateTo: newOrigin clippingTo: aRectangle during: aBlock "Set a new origin and clipping rectangle only during the execution of aBlock." self translateBy: newOrigin - self origin clippingTo: (aRectangle translateBy: self origin negated) during: aBlock! ! !Canvas methodsFor: 'drawing-morphs' stamp: 'jm 11/24/2002 11:51'! drawMorph: aMorph (self isVisible: aMorph bounds) ifTrue: [aMorph drawOn: self]. ! ! !Canvas methodsFor: 'drawing-morphs' stamp: 'jm 11/24/2002 11:50'! fullDrawMorph: aMorph (self isVisible: aMorph fullBounds) ifTrue: [aMorph fullDrawOn: self]. ! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! fillRectangle: r color: c "Fill the rectangle using the given color" ^self frameAndFillRectangle: r fillColor: c borderWidth: 0 borderColor: Color transparent! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor "Draw the rectangle using the given attributes" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:32'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor "Draw the rectangle using the given attributes. Note: This is a *very* simple implementation" | bw pt | self frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: bottomRightColor. bw _ borderWidth asPoint. pt _ r topLeft + (bw // 2). self line: pt to: pt + ((r extent x - bw x)@0) width: borderWidth color: topLeftColor. self line: pt to: pt + (0@(r extent y - bw y)) width: borderWidth color: topLeftColor.! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'! frameRectangle: r color: c self frameRectangle: r width: 1 color: c. ! ! !Canvas methodsFor: 'drawing-rectangles' stamp: 'ar 6/18/1999 07:33'! frameRectangle: r width: w color: c ^self frameAndFillRectangle: r fillColor: Color transparent borderWidth: w borderColor: c.! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'jm 11/24/2002 11:05'! fillOval: r color: c self fillOval: r color: c borderWidth: 0 borderColor: Color black. ! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'jm 11/24/2002 11:05'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Fill the given oval." ^ self subclassResponsibility ! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! frameOval: r color: c self fillOval: r color: Color transparent borderWidth: 1 borderColor: c. ! ! !Canvas methodsFor: 'drawing-ovals' stamp: 'ar 6/18/1999 08:45'! frameOval: r width: w color: c self fillOval: r color: Color transparent borderWidth: w borderColor: c. ! ! !Canvas methodsFor: 'drawing-lines and fills' stamp: 'ar 6/17/1999 01:18'! fillColor: aColor "Fill the receiver with the given color. Note: This method should be named differently since it is intended to fill the background and thus fills even if the color is transparent" ^self fillRectangle: self clipRect color: (aColor alpha: 1.0).! ! !Canvas methodsFor: 'drawing-lines and fills' stamp: 'ar 6/17/1999 01:30'! line: pt1 to: pt2 brushForm: brush "Obsolete - will be removed in the future"! ! !Canvas methodsFor: 'drawing-lines and fills' stamp: 'ar 6/17/1999 01:31'! line: pt1 to: pt2 width: w color: c "Draw a line using the given width and color" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:45'! drawImage: aForm at: aPoint "Draw the given Form, which is assumed to be a Form or ColorForm" self drawImage: aForm at: aPoint sourceRect: aForm boundingBox! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:47'! drawImage: aForm at: aPoint sourceRect: sourceRect "Draw the given form." self shadowColor ifNotNil:[ ^self fillRectangle: ((aForm boundingBox intersect: sourceRect) translateBy: aPoint) color: self shadowColor]. ^self image: aForm at: aPoint sourceRect: sourceRect rule: Form over! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/16/2000 23:48'! paintImage: aForm at: aPoint "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." self paintImage: aForm at: aPoint sourceRect: aForm boundingBox ! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'! paintImage: aForm at: aPoint sourceRect: sourceRect "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." self shadowColor ifNotNil:[ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. ^self image: aForm at: aPoint sourceRect: sourceRect rule: Form paint! ! !Canvas methodsFor: 'drawing-images' stamp: 'jm 3/18/2003 11:19'! paintImage: aForm at: aPoint sourceRect: sourceRect alpha: alpha "Draw the given Form, which is assumed to be a Form or ColorForm following the convention that zero is the transparent pixel value." self shadowColor ifNotNil:[ ^ self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. ^ self image: aForm at: aPoint sourceRect: sourceRect rule: 31 alpha: alpha ! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! stencil: stencilForm at: aPoint color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" ^self stencil: stencilForm at: aPoint sourceRect: stencilForm boundingBox color: aColor! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 6/25/1999 12:17'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 14:05'! translucentImage: aForm at: aPoint "Draw a translucent image using the best available way of representing translucency." self translucentImage: aForm at: aPoint sourceRect: aForm boundingBox! ! !Canvas methodsFor: 'drawing-images' stamp: 'ar 2/17/2000 01:48'! translucentImage: aForm at: aPoint sourceRect: sourceRect "Draw a translucent image using the best available way of representing translucency. Note: This will be fixed in the future." self shadowColor ifNotNil:[ ^self stencil: aForm at: aPoint sourceRect: sourceRect color: self shadowColor]. (self depth < 32 or:[aForm depth < 32]) ifTrue:[^self paintImage: aForm at: aPoint sourceRect: sourceRect]. self image: aForm at: aPoint sourceRect: sourceRect rule: Form blend! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 6/17/1999 01:31'! paragraph: paragraph bounds: bounds color: c "Draw the given paragraph" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing-text' stamp: 'ar 6/17/1999 01:32'! 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." ^self subclassResponsibility! ! !Canvas methodsFor: 'other' stamp: 'jm 6/15/2003 18:40'! contentsOfArea: aRectangle "Return the contents of the given area" ^ self contentsOfArea: aRectangle into: (Form extent: aRectangle extent depth: self depth) ! ! !Canvas methodsFor: 'other' stamp: 'jm 6/15/2003 18:40'! contentsOfArea: aRectangle into: aForm "Return a Form containing the contents of the given area." ^ self subclassResponsibility ! ! !Canvas methodsFor: 'other'! forceToScreen:rect " dummy " ! ! !Canvas methodsFor: 'private' stamp: 'ar 2/12/2000 18:12'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Note: The public use of this protocol is deprecated. It will become private. Nobody in the outside world must assume that a thing like a combination rule has any specific effect." ^self subclassResponsibility! ! The first message has the common receiver, the rest have receiver == nil, which signifies cascading.! !CascadeNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:52'! asTranslatorNode ^ TStmtListNode new setArguments: #() statements: (messages collect: [:msg | msg asTranslatorNode receiver: receiver asTranslatorNode]) ! ! I provide a page of controls or settings for each of my categories. Initially created to provide a muliple category editor for the system preferences. ! !CategorizedControlPanel methodsFor: 'initialization' stamp: 'jm 7/7/2003 23:15'! addCategorySelector | r categoryBar menuIcon menuIconPopUp | categoryBar _ AlignmentMorph new. categoryBar inset:0; color: (Color transparent); centering: #right; hResizing: #shrinkWrap; vResizing: #shrinkWrap. menuIcon _ ImageMorph new form: ArrowIcon. menuIconPopUp _ PopUpChoiceMorph new addMorph: menuIcon; extent: 16@16; contentsClipped: ''; target: self; actionSelector: #currentCategory:; getItemsSelector: #categories. chooser _ StringMorph new. chooser contents: #currentCategory asString. r _ AlignmentMorph newRow color: color; inset: 4; centering: #right; hResizing: #shrinkWrap; vResizing: #shrinkWrap. r addMorphBack: (StringMorph contents: 'Category: ' font: TextStyle default defaultFont emphasis: 1). r addMorphBack: chooser; addMorphBack: ((AlignmentMorph new) extent: 16@16; color: (Color transparent)); addMorphBack: menuIconPopUp. categoryBar addMorphBack: (AlignmentMorph newSpacer: (Color transparent)); addMorphBack: r. self addMorphFront: categoryBar. ! ! !CategorizedControlPanel methodsFor: 'initialization' stamp: 'jm 6/15/2003 10:28'! initialize | r tmp | super initialize. self orientation: #vertical; borderWidth: 2; inset: 0; color: Color lightGray; centering: #center. self addCategorySelector. tmp _ Dictionary new. #(red green blue) collect: [:cName | r _ BorderedMorph newBounds: (0@0 extent: 120@160) color: (Color perform: cName). tmp at: cName put: r]. self panels: tmp. ! ! !CategorizedControlPanel methodsFor: 'accessing' stamp: 'jm 10/16/2002 11:25'! categories "Answer a sorted list of my category names." ^ panels keys asArray sort ! ! !CategorizedControlPanel methodsFor: 'accessing' stamp: 'jm 10/16/2002 11:25'! currentCategory "Return the name of the currently display category." ^ currentCategory ! ! !CategorizedControlPanel methodsFor: 'accessing' stamp: 'jm 10/16/2002 11:45'! currentCategory: aString "Display the panel morph associated with the given category. Do nothing if there is no category of that name in my panels dictionary." | newPanel | currentCategory _ aString. newPanel _ panels at: currentCategory ifAbsent: [^ self]. chooser contents: aString; fitContents. currentPanel ifNotNil: [currentPanel delete]. currentPanel _ newPanel. self addMorphBack: newPanel. self world ifNotNil: [self world startSteppingSubmorphsOf: newPanel]. ! ! !CategorizedControlPanel methodsFor: 'accessing' stamp: 'jm 10/16/2002 11:25'! panels "Answer my panels dictionary." ^ panels ! ! !CategorizedControlPanel methodsFor: 'accessing' stamp: 'jm 10/16/2002 11:30'! panels: aDictionary "Set my panels to the given dictionary. The keys of this dictionary are my categories; its values are morphs, typically pages full of controls." panels _ aDictionary. self currentCategory: panels keys asArray sort first. ! ! !CategorizedControlPanel class methodsFor: 'class variables' stamp: 'jm 7/7/2003 23:16'! readIconFrom: aDirectory "Read my icon from the given directory and save them in class variables." "self readIconFrom: (FileDirectory default directoryNamed: 'ScratchSkin')" ArrowIcon _ Form fromFileNamed: (aDirectory fullNameFor: 'arrowDOWN.gif'). ! ! A model for a morphic world view which will ask for confirmation before being closed, unless the corresponding preference is set to false. ! !CautiousModel methodsFor: 'as yet unclassified' stamp: 'sw 9/15/1998 16:45'! okToChange Preferences 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"! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/7/2000 12:42'! changeListButtonSpecs ^#( ('select all' selectAll 'select all entries') ('deselect all' deselectAll 'deselect all entries') ('select conflicts' selectAllConflicts 'select all methods that occur in any change set') ('file in selections' fileInSelections 'file in all selected entries') )! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/13/2000 10:50'! initialize showDiffs _ Preferences diffsInChangeList. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. super initialize! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sbw 12/30/1999 11:02'! optionalButtonHeight ^ 15! ! !ChangeList methodsFor: 'initialization-release' stamp: 'sw 1/7/2000 15:43'! optionalButtonsView | view bHeight vWidth offset specs previousView button wid buttonCount | view _ View new model: self. bHeight _ self optionalButtonHeight. vWidth _ 180. view window: (0@0 extent: vWidth@bHeight). offset _ 0. specs _ self changeListButtonSpecs. buttonCount _ specs size + 1. previousView _ nil. wid _ vWidth // buttonCount. specs do: [:triplet | button _ PluggableButtonView on: self getState: nil action: triplet second. button label: triplet first asParagraph; insideColor: Color lightBlue; borderWidthLeft: 0 right: 1 top: 0 bottom: 0; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. triplet last = specs first last ifTrue: [view addSubView: button] ifFalse: [view addSubView: button toRightOf: previousView]. previousView _ button]. button _ PluggableButtonView on: self getState: #showDiffs action: #toggleDiff. button label: 'toggle diff' asParagraph; insideColor: Color lightBlue; window: (offset@0 extent: (vWidth - offset)@bHeight). view addSubView: button toRightOf: previousView. ^view! ! !ChangeList methodsFor: 'scanning' stamp: 'sw 10/19/1999 15:13'! scanFile: aFile from: startPosition to: stopPosition | itemPosition item prevChar | file _ aFile. changeList _ OrderedCollection new. list _ OrderedCollection new. listIndex _ 0. file position: startPosition. 'Scanning ', aFile localName, '...' 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 or: [prevChar = Character lf]) 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: 'menu actions' stamp: 'sw 1/7/2000 12:59'! browseCurrentVersionsOfSelections "Opens a message-list browser on the current in-memory versions of all methods that are currently seleted" | aClass aChange aList | aList _ OrderedCollection new. Cursor read showWhile: [1 to: changeList size do: [:i | (listSelections at: i) ifTrue: [aChange _ changeList at: i. (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [aClass includesSelector: aChange methodSelector]]) ifTrue: [aList add: aClass name, ' ', aChange methodSelector]]]]. aList size == 0 ifTrue: [^ self inform: 'no selected methods have in-memory counterparts']. MessageSet openMessageList: aList name: 'Current versions of selected methods in ', file localName! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 5/6/2000 02:54'! buttonRowForChangeList | aRow aButton | aRow _ AlignmentMorph newRow. aRow setProperty: #clipToOwnerWidth toValue: true. aRow addTransparentSpacerOfSize: (5@0). aRow centering: #center. self changeListButtonSpecs do: [:triplet | aButton _ PluggableButtonMorph on: self getState: nil action: triplet second. aButton useRoundedCorners; label: triplet first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0). aButton setBalloonText: triplet third. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0). aButton setBalloonText: triplet third. aRow addTransparentSpacerOfSize: (3 @ 0)]. aRow addMorphBack: self diffButton. ^ aRow! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 1/7/2000 13:25'! changeListMenu: aMenu ^ aMenu labels: 'fileIn selections fileOut selections... compare to current toggle diffing select conflicts with any changeset select conflicts with current changeset select conflicts with... select unchanged methods select methods for this class select all deselect all browse current versions of selections remove doIts remove older versions remove selections' lines: #(2 4 6 9 11 12) selections: #(fileInSelections fileOutSelections compareToCurrentVersion toggleDiffing selectAllConflicts selectConflicts selectConflictsWith selectUnchangedMethods selectMethodsForThisClass selectAll deselectAll browseCurrentVersionsOfSelections removeDoIts removeOlderMethodVersions removeSelections) "select such that... selectSuchThat" ! ! !ChangeList methodsFor: 'menu actions' stamp: 'di 1/13/1999 14:34'! compareToCurrentVersion "If the current selection corresponds to a method in the system, then spawn a window showing the diffs as text" | change class s1 s2 | listIndex = 0 ifTrue: [^ self]. change _ changeList at: listIndex. ((class _ change methodClass) notNil and: [class includesSelector: change methodSelector]) ifTrue: [s1 _ (class sourceCodeAt: change methodSelector) asString. s2 _ change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2)) openLabel: 'Comparison to Current Version'] ifFalse: [self flash]. ! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 10/11/1999 17:10'! fileInSelections | any | any _ false. listSelections with: changeList do: [:selected :item | selected ifTrue: [any _ true. item fileIn]]. any ifFalse: [self inform: 'nothing selected, so nothing done']! ! !ChangeList methodsFor: 'menu actions' stamp: 'sma 2/5/2000 19:13'! fileOutSelections | f | f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st'). f ifNil: [^ self]. f header; timeStamp. listSelections with: changeList do: [:selected :item | selected ifTrue: [item fileOutOn: f]]. f close! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 10/11/1999 17:18'! 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: [otherTarget isMorph ifFalse: [^ self acceptFrom: otherTarget view]]. "weird special case just for mvc changlist" ^ super perform: selector orSendTo: otherTarget! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 12/27/1999 12:24'! selectAllConflicts "Selects all method definitions in the receiver which are also in any existing change set in the system. This makes no statement about whether the content of the methods differ, only whether there is a change represented. " | aClass aChange | Cursor read showWhile: [1 to: changeList size do: [:i | aChange _ changeList at: i. listSelections at: i put: (aChange type = #method and: [(aClass _ aChange methodClass) notNil and: [(ChangeSorter allChangeSetsWithClass: aClass selector: aChange methodSelector) size > 0]])]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'tk 6/24/1999 07:22'! 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 allSubInstances asOrderedCollection. all do: [:sel | aStream nextPutAll: (sel name contractTo: 40); cr]. ChangeList allSubInstancesDo: [: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: 'ls 11/14/1998 14:30'! selectMethodsForThisClass | name | self currentChange ifNil: [ ^self ]. name _ self currentChange methodClassName. name ifNil: [ ^self ]. ^self selectSuchThat: [ :change | change methodClassName = name ].! ! !ChangeList methodsFor: 'menu actions' stamp: 'sw 1/7/2000 15:04'! selectSuchThat "query the user for a selection criterio. By Lex Spoon. NB: the UI for invoking this from a changelist browser is currently commented out; to reenfranchise it, you'll need to mild editing to ChangeList method #changeListMenu:" | code block | code _ FillInTheBlank request: 'selection criteria for a change named aChangeRecord?\For instance, ''aChangeRecord category = ''System-Network''''' withCRs. code isEmpty ifTrue: [^ self ]. block _ Compiler evaluate: '[:aChangeRecord | ', code, ']'. self selectSuchThat: block! ! !ChangeList methodsFor: 'menu actions' stamp: 'ls 5/12/1999 07:56'! selectSuchThat: aBlock "select all changes for which block returns true" listSelections _ changeList collect: [ :change | aBlock value: change ]. self changed: #allSelections! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 9/27/1999 16:01'! contents ^ self showDiffs ifFalse: [self undiffedContents] ifTrue: [self showsVersions ifTrue: [self diffedVersionContents] ifFalse: [self contentsDiffedFromCurrent]]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 1/12/1999 12:40'! contentsDiffedFromCurrent | aChange aClass | listIndex = 0 ifTrue: [^ '']. aChange _ changeList at: listIndex. ^ ((aChange type == #method and: [(aClass _ aChange methodClass) notNil]) and: [aClass includesSelector: aChange methodSelector]) ifTrue: [Utilities methodDiffFor: aChange text class: aClass selector: aChange methodSelector] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 2/7/2000 01:32'! diffedVersionContents | thisText | (listIndex = 0 or: [changeList size < listIndex]) ifTrue: [^ '']. thisText _ (changeList at: listIndex) text. ^ listIndex == changeList size ifTrue: [thisText] ifFalse: [TextDiffBuilder buildDisplayPatchFrom: (changeList at: (listIndex + 1)) text to: thisText]! ! !ChangeList methodsFor: 'viewing access' stamp: 'di 1/13/1999 14:59'! listSelectionAt: index put: value ^ 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: 'sma 2/5/2000 19:09'! selectedClassOrMetaClass | c | ^ (c _ self currentChange) ifNotNil: [c methodClass]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sma 2/5/2000 19:10'! selectedMessageName | c | ^ (c _ self currentChange) ifNotNil: [c methodSelector]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 1/28/1999 12:30'! toggleListIndex: newListIndex listIndex ~= 0 ifTrue: [listSelections at: listIndex put: false]. newListIndex ~= 0 ifTrue: [listSelections at: newListIndex put: true]. listIndex _ newListIndex. self changed: #listIndex. self contentsChanged! ! !ChangeList methodsFor: 'viewing access' stamp: 'sw 1/25/1999 14:45'! undiffedContents ^ listIndex = 0 ifTrue: [''] ifFalse: [(changeList at: listIndex) text]! ! !ChangeList methodsFor: 'accessing' stamp: 'ls 5/12/1999 07:55'! currentChange "return the current change being viewed, or nil if none" listIndex = 0 ifTrue: [ ^nil ]. ^changeList at: listIndex! ! !ChangeList methodsFor: 'accessing' stamp: 'TPR 11/28/1998 17:38'! listHasSingleEntry "does the list of changes have only a single item?" ^list size = 1! ! !ChangeList methodsFor: 'accessing' stamp: 'tk 6/21/1999 20:43'! listSelections listSelections ifNil: [ list ifNotNil: [ listSelections _ Array new: list size withAll: false]]. ^ listSelections! ! !ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'! showsVersions ^ false! ! !ChangeList class methodsFor: 'public access' stamp: 'di 6/12/1998 16:33'! 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 selections: positions) startUpWithCaption: 'Browse as far back as...'. pos == nil ifTrue: [^ self]. self browseRecent: end-pos! ! !ChangeList class methodsFor: 'public access' stamp: 'sw 2/3/2000 16:16'! getRecentLocatorWithPrompt: aPrompt "Prompt with a menu of how far back to go. Return nil if user backs out. Otherwise return the number of characters back from the end of the .changes file the user wishes to include" "ChangeList getRecentPosition" | 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 selections: positions) startUpWithCaption: aPrompt. pos == nil ifTrue: [^ nil]. ^ end - pos! ! !ChangeList class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:21'! 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 underPane pHeight | Smalltalk isMorphic ifTrue: [^ self openAsMorph: aChangeList name: aString multiSelect: multiSelect]. topView _ (StandardSystemView new) model: aChangeList. topView label: aString. topView minimumSize: 180 @ 120. topView borderWidth: 1. Preferences optionalButtons ifTrue: [underPane _ aChangeList optionalButtonsView. underPane isNil ifTrue: [pHeight _ 100] ifFalse: [topView addSubView: underPane. pHeight _ 100 - aChangeList optionalButtonHeight]] ifFalse: [underPane _ nil. pHeight _ 100]. aListView _ (multiSelect ifTrue: [PluggableListViewOfMany] ifFalse: [PluggableListView]) on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]) keystroke: #messageListKey:from:. aListView window: (0 @ 0 extent: 180 @ pHeight). underPane isNil ifTrue: [topView addSubView: aListView] ifFalse: [topView addSubView: aListView below: underPane]. 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: 'sw 1/7/2000 14:59'! 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 boundary | window _ (SystemWindow labelled: labelString) model: aChangeList. Preferences optionalButtons ifFalse: [boundary _ 0] ifTrue: [boundary _ 0.08. window addMorph: aChangeList buttonRowForChangeList frame: (0 @ 0 corner: 1 @ boundary)]. window addMorph: ((multiSelect ifTrue: [PluggableListMorphOfMany] ifFalse: [PluggableListMorph]) on: aChangeList list: #list selected: #listIndex changeSelected: #toggleListIndex: menu: (aChangeList showsVersions ifTrue: [#versionsMenu:] ifFalse: [#changeListMenu:]) keystroke: nil) frame: (0@boundary corner: 1@0.4). window addMorph: (AcceptableCleanTextMorph on: aChangeList text: #contents accept: #contents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@0.4 corner: 1@1). ^ window openInWorld! ! 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'! category ^category! ! !ChangeRecord methodsFor: 'access' stamp: 'sw 8/24/1998 08:16'! 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 stamp: stamp]]! ! !ChangeRecord methodsFor: 'access' stamp: 'tk 6/24/1999 15:27'! headerFor: selector ^ ' ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) , selector , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])! ! !ChangeRecord methodsFor: 'access'! isMetaClassChange ^meta! ! !ChangeRecord methodsFor: 'access'! methodClassName ^class! ! !ChangeRecord methodsFor: 'access' stamp: 'tk 6/21/1999 20:34'! readStamp "Get the time stamp of this method off the file" | item tokens anIndex | stamp _ ''. file ifNil: [^ stamp]. file position: position. item _ file nextChunk. tokens _ Scanner new scanTokens: item. tokens size < 3 ifTrue: [^ stamp]. anIndex _ tokens indexOf: #stamp: ifAbsent: [^ stamp]. ^ stamp _ tokens at: (anIndex + 1). ! ! !ChangeRecord methodsFor: 'access' stamp: 'tk 6/23/1999 08:20'! text | text | ^ file ifNil: [''] ifNotNil: [ file openReadOnly. file position: position. text _ file nextChunkText. file close. text]! ! !ChangeRecord methodsFor: 'initialization' stamp: 'tk 6/24/1999 14:51'! class: clsName category: cat method: method sourceFiles: fileArray "This should be enough to find all the information for a method, or method deletion" file _ fileArray at: method fileIndex. position _ method filePosition. type _ #method. class _ clsName copyUpTo: $ . "the non-meta part of a class name" category _ cat. meta _ clsName endsWith: ' class'. self readStamp.! ! ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut"). Every project has an associated changeSet. For simple projects, a different changeSet may be designated to capture changes at any time. This implementation of ChangeSet is capable of remembering and manipulating methods for which the classes are not present in the system. However at the present time, this capability is not used in normal rearranging and fileOuts, but only for invoking and revoking associated with isolation layers. For isolated projects (see Project class comment), the changeSet binding is semi-permanent. Every project exists in an isolation layer defined by its closest enclosing parent (or itself) that is isolated. If a project is not isolated, then changes reported to its designated changeSet must also be reported to the permanent changeSet for that layer, designated in the isolated project. This ensures that that outer project will be able to revert all changes upon exit. Note that only certain changes may be reverted. Classes may not be added, removed, renamed or reshaped except in the layer in which they are defined because these operations on non-local classes are not revertable. If a Squeak Project is established as being isolated, then its associated changeSet will be declared to be revertable. In this case all changes stored can be reverted. The changeSet associated with an isolated project is tied to that project, and cannot be edited in a changeSorter. ------ 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. revertable - a Boolean If this variable is true, then all of the changes recorded by this changeSet can be reverted. isolationSet - a ChangeSet or nil The isolationSet is the designated changeSet for an isolation layer. If this changeSet is an isolationSet, then this variable will be nil. If not, then it points to the isolationSet for this layer, and all changes reported here will also be reported to the isolationSet. isolatedProject - a Project or nil If this is an isolationSet, then this variable points to the project with which it is associated. changeRecords - Dictionary {class name -> a ClassChangeRecord}. These classChangeRecords (qv) remember all of the system changes. structures - Dictionary {#Rectangle -> #( 'origin' 'corner')}. Of the names of the instances variables before any changes for all classes in classChanges, and all of their superclasses. In the same format used in SmartRefStream. Inst var names are strings. superclasses - Dictionary {#Rectangle -> #Object}. Of all classes in classChanges, and all of their superclasses. Structures and superclasses save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp). NOTE: It should be fairly simple, by adding a bit more information to the classChangeRecords, to reconstruct the information now stored in 'structures' and 'superclasses'. This would be a welcome simplification. ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/1/2000 12:00'! clear "Reset the receiver to be empty. " changeRecords _ Dictionary new. preamble _ nil. postscript _ nil! ! !ChangeSet methodsFor: 'initialize-release' stamp: 'di 4/3/2000 14:46'! initialize "Reset the receiver to be empty." revertable _ false. self clear. "Avoid duplicate entries in AllChanges 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 3/23/2000 12:14'! wither "The receiver is to be clobbered. Clear it out. 2/7/96 sw" self clear. name _ nil! ! !ChangeSet methodsFor: 'change logging' stamp: 'jm 5/16/2003 09:19'! addClass: class "Include indication that a new class was created." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #new. self atClass: class add: #change. self addCoherency: class name. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'jm 5/16/2003 09:18'! changeClass: class from: oldClass "Remember that a class definition has been changed. Record the original structure, so that a conversion method can be built." class wantsChangeSetLogging ifFalse: [^ self]. self atClass: class add: #change. self addCoherency: class name. (self changeRecorderFor: class) notePriorDefinition: oldClass. self noteClassStructure: oldClass. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'jm 5/16/2003 09:18'! noteNewMethod: newMethod forClass: class selector: selector priorMethod: methodOrNil class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteNewMethod: newMethod selector: selector priorMethod: methodOrNil. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'jm 5/16/2003 09:17'! removeSelector: selector class: class priorMethod: priorMethod lastMethodInfo: info "Include indication that a method has been forgotten. info is a pair of the source code pointer and message category for the method that was removed." class wantsChangeSetLogging ifFalse: [^ self]. (self changeRecorderFor: class) noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: info. ! ! !ChangeSet methodsFor: 'change logging' stamp: 'jm 5/16/2003 09:18'! renameClass: class as: newName "Include indication that a class has been renamed." | recorder | (recorder _ self changeRecorderFor: class) noteChangeType: #rename; noteNewName: newName asSymbol. "store under new name (metaclass too)" changeRecords at: newName put: recorder. changeRecords removeKey: class name. recorder _ changeRecords at: class class name ifAbsent: [^ nil]. changeRecords at: (newName, ' class') put: recorder. changeRecords removeKey: class class name. recorder noteNewName: newName, ' class'. ! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'! classRemoves ^ changeRecords keys select: [:className | (changeRecords at: className) isClassRemoval]! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 4/8/2000 23:16'! editPostscript "edit the receiver's postscript, in a separate window. " | deps found | self assurePostscriptExists. deps _ postscript dependents select: [:m | (m isKindOf: SystemWindow) or: [m isKindOf: StandardSystemView]]. deps size > 0 ifTrue: [Smalltalk isMorphic ifTrue: [found _ deps detect: [:obj | (obj isKindOf: SystemWindow) and: [obj world == self currentWorld]] ifNone: [nil]. found ifNotNil: [^ found activate]] ifFalse: [found _ deps detect: [:obj | (obj isKindOf: StandardSystemView) and: [ScheduledControllers scheduledControllers includes: obj controller]] ifNone: [nil]. found ifNotNil: [^ ScheduledControllers activateController: found controller]]. . self inform: 'Caution -- there', (deps size isOrAreStringWith: 'other window'), ' already open on this postscript elsewhere']. postscript openLabel: 'Postscript for ChangeSet named ', name! ! !ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:44'! hasPostscript ^ postscript notNil! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 4/1/2000 12:00'! methodChanges | methodChangeDict changeTypes | methodChangeDict _ Dictionary new. changeRecords associationsDo: [:assn | changeTypes _ assn value methodChangeTypes. changeTypes isEmpty ifFalse: [methodChangeDict at: assn key put: changeTypes]]. ^ methodChangeDict! ! !ChangeSet methodsFor: 'accessing' stamp: 'di 3/29/2000 16:22'! methodInfoFromRemoval: classAndSelector ^ (self changeRecorderFor: classAndSelector first) infoFromRemoval: classAndSelector last! ! !ChangeSet methodsFor: 'accessing'! 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: 'accessing'! name: anObject name _ anObject! ! !ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 20:51'! postscriptHasDependents ^ postscript dependents size > 0! ! !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 methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'! removePostscript postscript _ nil! ! !ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! structures ^structures! ! !ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! superclasses ^superclasses! ! !ChangeSet methodsFor: 'testing' stamp: 'di 4/4/2000 16:55'! belongsToAProject Smalltalk at: #Project ifPresent: [:projClass | projClass allSubInstancesDo: [:proj | proj projectChangeSet == self ifTrue: [^ true]]]. ^ false! ! !ChangeSet methodsFor: 'testing' stamp: 'di 4/4/2000 17:08'! correspondingProject "If the receiver is the current change set for any project, answer it, else answer nil" Project allSubInstancesDo: [:proj | proj projectChangeSet == self ifTrue: [^ proj]]. ^ nil ! ! !ChangeSet methodsFor: 'testing' stamp: 'di 4/1/2000 12:00'! isEmpty "Answer whether the receiver contains any elements." ^ changeRecords isEmpty ! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'! okayToRemove ^ self okayToRemoveInforming: true! ! !ChangeSet methodsFor: 'testing' stamp: 'sw 8/3/1998 16:25'! okayToRemoveInforming: aBoolean "Answer whether it is okay to remove the receiver. If aBoolean is true, inform the receiver if it is not okay" | aName | aName _ self name. self == Smalltalk changes ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it is the current change set.']. ^ false]. self belongsToAProject ifTrue: [aBoolean ifTrue: [self inform: 'Cannot remove "', aName, '" because it belongs to a project.']. ^ false]. ^ true ! ! !ChangeSet methodsFor: 'testing' stamp: 'di 4/4/2000 17:08'! projectsBelongedTo "Answer a list of all the projects for which the receiver is the current change set" ^ Project allSubInstances select: [:proj | proj projectChangeSet == self] ! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 3/29/2000 11:01'! atSelector: selector class: class put: changeType (selector == #DoIt or: [selector == #DoItIn:]) ifTrue: [^ self]. (self changeRecorderFor: class) atSelector: selector put: changeType. ! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 10/19/1999 15:01'! 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]. (VersionsBrowser 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' stamp: 'di 4/1/2000 12:00'! changedMessageList "Used by a message set browser to access the list view information." | messageList | messageList _ SortedCollection new. changeRecords associationsDo: [:clAssoc | clAssoc value methodChangeTypes associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [messageList add: clAssoc key asString, ' ' , mAssoc key]]]. ^ messageList asArray! ! !ChangeSet methodsFor: 'method changes' stamp: 'tk 6/7/1999 18:57'! changedMessageListAugmented "Even added classes have all messages in changedMessageList." ^ self changedMessageList asArray! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'! methodChangesAtClass: className "Return an old-style dictionary of method change types." ^(changeRecords at: className ifAbsent: [^ Dictionary new]) methodChangeTypes! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 4/4/2000 11:14'! removeSelectorChanges: selector class: class "Remove all memory of changes associated with the argument, selector, in this class." | chgRecord | (chgRecord _ changeRecords at: class name ifAbsent: [^ self]) removeSelector: selector. chgRecord hasNoChanges ifTrue: [changeRecords removeKey: class name]! ! !ChangeSet methodsFor: 'method changes' stamp: 'di 4/1/2000 12:00'! selectorsInClass: aClass "Used by a ChangeSorter to access the list methods." ^ (changeRecords at: aClass ifAbsent: [^#()]) changedSelectors! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! changedClassNames "Answer a OrderedCollection of the names of changed or edited classes. DOES include removed classes. Sort alphabetically." ^ changeRecords keysSortedSafely ! ! !ChangeSet methodsFor: 'class changes' stamp: 'jm 5/29/2003 19:21'! changedClasses "Answer an OrderedCollection of changed or edited classes sorted alphabetically by name. Does not include removed classes." "Note: Much faster to sort names first, then convert back to classes because metaclasses reconstruct their name at every comparison in the sorted collection." ^ (self changedClassNames collect: [:cName | Smalltalk classNamed: cName]) select: [:aClass | aClass notNil] ! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 12:00'! classChangeAt: className "Return what we know about class changes to this class." ^ (changeRecords at: className ifAbsent: [^ Set new]) allChangeTypes! ! !ChangeSet methodsFor: 'class changes'! commentClass: class "Include indication that a class comment has been changed." self atClass: class add: #comment! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 3/28/2000 11:44'! fatDefForClass: class | newDef oldDef oldStrm newStrm outStrm oldVars newVars addedVars | newDef _ class definition. oldDef _ (self changeRecorderFor: class) priorDefinition. oldDef ifNil: [^ newDef]. oldDef = newDef ifTrue: [^ newDef]. oldStrm _ ReadStream on: oldDef. newStrm _ ReadStream on: newDef. outStrm _ WriteStream on: (String new: newDef size * 2). "Merge inst vars from old and new defs..." oldStrm upToAll: 'instanceVariableNames:'; upTo: $'. outStrm nextPutAll: (newStrm upToAll: 'instanceVariableNames:'); nextPutAll: 'instanceVariableNames:'; nextPutAll: (newStrm upTo: $'); nextPut: $'. oldVars _ (oldStrm upTo: $') findTokens: Character separators. newVars _ (newStrm upTo: $') findTokens: Character separators. addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection. oldVars , addedVars do: [:var | outStrm nextPutAll: var; space]. outStrm nextPut: $'. class isMeta ifFalse: ["Merge class vars from old and new defs..." oldStrm upToAll: 'classVariableNames:'; upTo: $'. outStrm nextPutAll: (newStrm upToAll: 'classVariableNames:'); nextPutAll: 'classVariableNames:'; nextPutAll: (newStrm upTo: $'); nextPut: $'. oldVars _ (oldStrm upTo: $') findTokens: Character separators. newVars _ (newStrm upTo: $') findTokens: Character separators. addedVars _ oldVars asSet addAll: newVars; removeAll: oldVars; asOrderedCollection. oldVars , addedVars do: [:var | outStrm nextPutAll: var; space]. outStrm nextPut: $']. outStrm nextPutAll: newStrm upToEnd. ^ outStrm contents ! ! !ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 19:54'! noteClassForgotten: className "Remove from structures if class is not a superclass of some other one we are remembering" structures ifNil: [^ self]. Smalltalk at: className ifPresent: [:cls | cls subclasses do: [:sub | (structures includesKey: sub) ifTrue: [ ^ self]]]. "No delete" structures removeKey: className ifAbsent: [].! ! !ChangeSet methodsFor: 'class changes' stamp: 'tk 6/9/1999 21:51'! noteClassStructure: aClass "Save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp)." | clsName | aClass ifNil: [^ self]. structures ifNil: [structures _ Dictionary new. superclasses _ Dictionary new]. clsName _ (aClass name asLowercase beginsWith: 'anobsolete') ifTrue: [(aClass name copyFrom: 11 to: aClass name size) asSymbol] ifFalse: [aClass name]. (structures includesKey: clsName) ifFalse: [ structures at: clsName put: ((Array with: aClass classVersion), (aClass allInstVarNames)). superclasses at: clsName put: aClass superclass name]. "up the superclass chain" aClass superclass ifNotNil: [self noteClassStructure: aClass superclass]. ! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 4/1/2000 23:17'! noteRemovalOf: class "The class is about to be removed from the system. Adjust the receiver to reflect that fact." (self changeRecorderFor: class) noteChangeType: #remove fromClass: class. changeRecords removeKey: class class name ifAbsent: [].! ! !ChangeSet methodsFor: 'class changes'! reorganizeClass: class "Include indication that a class was reorganized." self atClass: class add: #reorganize! ! !ChangeSet methodsFor: 'class changes' stamp: 'di 5/16/2000 09:03'! trimHistory "Drop non-essential history: methods added and then removed, as well as rename and reorganization of newly-added classes." changeRecords do: [:chgRecord | chgRecord trimHistory]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 09:37'! absorbClass: className from: otherChangeSet "Absorb into the receiver all the changes found in the class in the other change set. *** Classes renamed in otherChangeSet may have problems" | cls | (self changeRecorderFor: className) assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className). (cls _ Smalltalk classNamed: className) ifNotNil: [self absorbStructureOfClass: cls from: otherChangeSet]. ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 3/23/2000 11:52'! absorbMethod: selector class: aClass from: aChangeSet "Absorb into the receiver all the changes for the method in the class in the other change set." | info | info _ aChangeSet methodChanges at: aClass name ifAbsent: [Dictionary new]. self atSelector: selector class: aClass put: (info at: selector). ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/3/2000 17:53'! absorbStructureOfClass: aClass from: otherChangeSet "Absorb into the receiver all the structure and superclass info in the other change set. Used to write conversion methods." | sup next | otherChangeSet structures ifNil: [^ self]. (otherChangeSet structures includesKey: aClass name) ifFalse: [^ self]. structures ifNil: [structures _ Dictionary new. superclasses _ Dictionary new]. sup _ aClass name. [(structures includesKey: sup) ifTrue: ["use what is here" true] ifFalse: [structures at: sup put: (otherChangeSet structures at: sup). next _ otherChangeSet superclasses at: sup. superclasses at: sup put: next. (sup _ next) = 'nil'] ] whileFalse. ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:21'! assimilateAllChangesFoundIn: otherChangeSet "Make all changes in otherChangeSet take effect on self as if they happened just now." otherChangeSet changedClassNames do: [:className | self absorbClass: className from: otherChangeSet] ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/8/2000 23:16'! editPreamble "edit the receiver's preamble, in a separate window. " self assurePreambleExists. preamble openLabel: 'Preamble for ChangeSet named ', name! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 11:49'! expungeEmptyClassChangeEntries changeRecords keysAndValuesRemove: [:className :classRecord | classRecord hasNoChanges]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:40'! forgetAllChangesFoundIn: otherChangeSet "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." otherChangeSet == self ifTrue: [^ self]. otherChangeSet changedClassNames do: [:className | self forgetChangesForClass: className in: otherChangeSet]. self expungeEmptyClassChangeEntries. " Old code... aChangeSet changedClassNames do: [:className | (cls _ Smalltalk classNamed: className) ~~ nil ifTrue: [itsMethodChanges _ aChangeSet methodChanges at: className ifAbsent: [Dictionary new]. itsMethodChanges associationsDo: [:assoc | self forgetChange: assoc value forSelector: assoc key class: cls]. myClassChange _ self classChangeAt: className. myClassChange size > 0 ifTrue: [(aChangeSet classChangeAt: className) do: [:aChange | myClassChange remove: aChange ifAbsent: []]]. self noteClassForgotten: className]]. aChangeSet classRemoves do: [:className | (recorder _ changeRecords at: className ifAbsent: []) ifNotNil: [recorder forgetClassRemoval]]. self expungeEmptyClassChangeEntries " ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:04'! forgetChangesForClass: className in: otherChangeSet "See forgetAllChangesFoundIn:. Used in culling changeSets." (self changeRecorderFor: className) forgetChangesIn: (otherChangeSet changeRecorderFor: className). self noteClassForgotten: className ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'! hasPreamble ^ preamble notNil! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'! removeClassAndMetaClassChanges: class "Remove all memory of changes associated with this class and its metaclass. 7/18/96 sw" changeRecords removeKey: class name ifAbsent: []. changeRecords removeKey: class class name ifAbsent: []. ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/1/2000 12:00'! removeClassChanges: class "Remove all memory of changes associated with this class" | cname | (class isKindOf: String) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. changeRecords removeKey: cname ifAbsent: []. self noteClassForgotten: cname.! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'! removePreamble preamble _ nil! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/11/1998 16:13'! assurePostscriptExists "Make sure there is a StringHolder holding the postscript. " "NOTE: FileIn recognizes the postscript by the line with Postscript: on it" postscript == nil ifTrue: [postscript _ StringHolder new contents: '"Postscript: Leave the line above, and replace the rest of this comment by a useful one. Executable statements should follow this comment, and should be separated by periods, with no exclamation points (!!). Be sure to put any further comments in double-quotes, like this one." ']! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 4/7/1999 17:45'! 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 isEmptyOrNil]) ifTrue: [preamble _ StringHolder new contents: self preambleTemplate]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/26/2000 10:06'! checkForSlips "Return a collection of method refs with possible debugging code in them." | slips method | slips _ OrderedCollection new. self changedClasses do: [:aClass | (self methodChangesAtClass: aClass name) associationsDo: [:mAssoc | (#(remove addedThenRemoved) includes: mAssoc value) ifFalse: [method _ aClass compiledMethodAt: mAssoc key ifAbsent: [nil]. method ifNotNil: [method hasReportableSlip ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]. ^ slips! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/1/2000 15:47'! checkForUnsentMessages | nameLine allChangedSelectors augList unsent messageList | nameLine _ '"', self name, '"'. allChangedSelectors _ Set new. (augList _ self changedMessageListAugmented) do: [:aChange | MessageSet parse: aChange toClassAndSelector: [:cls :sel | cls ifNotNil: [allChangedSelectors add: sel]]]. unsent _ Smalltalk allUnSentMessagesIn: allChangedSelectors. unsent size = 0 ifTrue: [self inform: 'There are no unsent messages in change set ', nameLine] ifFalse: [messageList _ augList select: [:aChange | MessageSet parse: aChange toClassAndSelector: [:cls :sel | unsent includes: sel]]. Smalltalk browseMessageList: messageList name: 'Unsent messages in ', nameLine] ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'jm 10/30/2002 21:00'! fileOut "File out the receiver, to a file whose name is a function of the change-set name and either of the date & time or chosen to have a unique numeric tag, depending on the preference 'sequentialChangeSetRevertableFileNames'" | file slips nameToUse | nameToUse _ Preferences changeSetVersionNumbers ifTrue: [FileDirectory default nextNameFor: self name extension: 'cs'] ifFalse: [(self name, FileDirectory dot, Utilities dateTimeSuffix, FileDirectory dot, 'cs') asFileName]. Cursor write showWhile: [file _ FileStream newFileNamed: nameToUse. file header; timeStamp. self fileOutPreambleOn: file. self fileOutOn: file. self fileOutPostscriptOn: file. file trailer; close]. Preferences checkForSlips ifFalse: [^ self]. slips _ self checkForSlips. (slips size > 0 and: [self confirm: 'Methods in this fileOut have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']) ifTrue: [ Smalltalk browseMessageList: slips name: 'Possible slips in ', name]. ! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/28/2000 09:35'! fileOutChangesFor: class on: stream "Write out all the method changes for this class." | changes | changes _ Set new. (self methodChangesAtClass: class name) associationsDo: [:mAssoc | (mAssoc value = #remove or: [mAssoc value = #addedThenRemoved]) ifFalse: [changes add: mAssoc key]]. changes isEmpty ifFalse: [class fileOutChangedMessages: changes on: stream. stream cr]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 4/3/2000 14:46'! fileOutOn: stream "Write out all the changes the receiver knows about" | classList | (self isEmpty and: [stream isKindOf: FileStream]) ifTrue: [self notify: 'Warning: no changes to file out']. classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection. "First put out rename, max classDef and comment changes." classList do: [:aClass | self fileOutClassDefinition: aClass on: stream]. "Then put out all the method changes" classList do: [:aClass | self fileOutChangesFor: aClass on: stream]. "Finally put out removals, final class defs and reorganization if any" classList reverseDo: [:aClass | self fileOutPSFor: aClass on: stream]. self classRemoves asSortedCollection do: [:aClassName | stream nextChunkPut: 'Smalltalk removeClassNamed: #', aClassName; cr].! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 5/8/2000 20:47'! fileOutPSFor: class on: stream "Write out removals and initialization for this class." | dict changeType classRecord currentDef | classRecord _ changeRecords at: class name ifAbsent: [^ self]. dict _ classRecord methodChangeTypes. dict keysSortedSafely do: [:key | changeType _ dict at: key. (#(remove addedThenRemoved) includes: changeType) ifTrue: [stream nextChunkPut: class name, ' removeSelector: ', key storeString; cr] ifFalse: [(key = #initialize and: [class isMeta]) ifTrue: [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]. ((classRecord includesChangeType: #change) and: [(currentDef _ class definition) ~= (self fatDefForClass: class)]) ifTrue: [stream command: 'H3'; nextChunkPut: currentDef; cr; command: '/H3']. (classRecord includesChangeType: #reorganize) ifTrue: [class fileOutOrganizationOn: stream. stream cr]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 13:35'! fileOutPostscriptOn: stream "If the receiver has a postscript, put it out onto the stream. " | aString | aString _ self postscriptString. (aString ~~ nil and: [aString size > 0]) ifTrue: [stream nextChunkPut: aString "surroundedBySingleQuotes". stream cr; cr]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 3/29/1999 14:58'! fileOutPreambleOn: stream "If the receiver has a preamble, put it out onto the stream. " | aString | aString _ self preambleString. (aString ~~ nil and: [aString size > 0]) ifTrue: [stream nextChunkPut: aString "surroundedBySingleQuotes". stream cr; cr]! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'sw 3/8/1999 12:07'! lookForSlips | slips nameLine msg | nameLine _ ' "', self name, '" '. (slips _ self checkForSlips) size == 0 ifTrue: [^ self inform: 'No slips detected in change set', nameLine]. msg _ slips size == 1 ifTrue: [ 'One method in change set', nameLine, 'has a halt, reference to the Transcript, and/or some other ''slip'' in it. Would you like to browse it? ?'] ifFalse: [ slips size printString, ' methods in change set', nameLine, 'have halts or references to the Transcript or other ''slips'' in them. Would you like to browse them?']. (self confirm: msg) ifTrue: [Smalltalk browseMessageList: slips name: 'Possible slips in ', name]! ! !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' stamp: 'jm 5/31/2003 16:23'! 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." ^ String streamContents: [:strm | strm nextPutAll: '"Change Set:'. "NOTE: fileIn recognizes preambles by this string." strm tab;tab; nextPutAll: self name. strm cr; nextPutAll: 'Date:'; tab; tab; tab; nextPutAll: Date today printString. strm cr; nextPutAll: 'Author:'; tab; tab; tab; nextPutAll: Utilities authorName. strm cr; cr; nextPutAll: '"'] "Smalltalk changes preambleTemplate"! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:33'! summaryString "Answer the string summarizing this changeSet" ^ self summaryStringDelta: 0 " To summarize all recent changeSets on a file... (FileStream newFileNamed: 'Summaries.txt') nextPutAll: (String streamContents: [:s | (ChangeSorter changeSetsNamedSuchThat: [:name | name first isDigit and: [name initialIntegerOrNil >= 948]]) do: [:cs | s nextPutAll: cs summaryString; cr]]); close To list all changeSets with a certain string in the preamble... (FileStream newFileNamed: 'MyUpdates.txt') nextPutAll: (String streamContents: [:s | ChangeSorter gatherChangeSetRevertables do: [:cs | (cs preambleString notNil and: [cs preambleString includesSubString: 'Author Name']) ifTrue: [s nextPutAll: cs summaryString; cr]]]); close "! ! !ChangeSet methodsFor: 'fileIn/Out' stamp: 'di 9/24/1999 12:27'! summaryStringDelta: delta "Answer the string summarizing this changeSet" | ps s2 date author line intName | ^ String streamContents: [:s | intName _ self name splitInteger. intName first isNumber ifTrue: [s nextPutAll: (intName first + delta) printString , intName last] ifFalse: [s nextPutAll: intName first "weird convention of splitInteger"]. (ps _ self preambleString) ifNil: [s cr] ifNotNil: [s2 _ ReadStream on: ps. s2 match: 'Date:'; skipSeparators. date _ s2 upTo: Character cr. s2 match: 'Author:'; skipSeparators. author _ s2 upTo: Character cr. s nextPutAll: ' -- '; nextPutAll: author; nextPutAll: ' -- '; nextPutAll: date; cr. [s2 atEnd] whileFalse: [line _ s2 upTo: Character cr. (line isEmpty or: [line = '"']) ifFalse: [s nextPutAll: line; cr]]]]. ! ! !ChangeSet methodsFor: 'private' stamp: 'di 3/23/2000 08:37'! addCoherency: className "SqR!! 19980923: If I recreate the class then don't remove it" (self changeRecorderFor: className) checkCoherence. " classRemoves remove: className ifAbsent: []. (classChanges includesKey: className) ifTrue: [(classChanges at: className) remove: #remove ifAbsent: []] "! ! !ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 14:40'! atClass: class add: changeType (self changeRecorderFor: class) noteChangeType: changeType fromClass: class! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! atClass: class includes: changeType ^(changeRecords at: class name ifAbsent: [^false]) includesChangeType: changeType! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! atSelector: selector class: class ^ (changeRecords at: class name ifAbsent: [^ #none]) atSelector: selector ifAbsent: [^ #none]! ! !ChangeSet methodsFor: 'private' stamp: 'jm 5/16/2003 08:57'! changeRecorderFor: class | cname | (class isKindOf: String) ifTrue: [ cname _ class ] ifFalse: [ cname _ class name ]. "Later this will init the changeRecords so according to whether they should be revertable." ^ changeRecords at: cname ifAbsent: [ ^ changeRecords at: cname put: (ClassChangeRecord new initForClassNamed: cname)] ! ! !ChangeSet methodsFor: 'private' stamp: 'di 3/28/2000 09:23'! fileOutClassDefinition: class on: stream "Write out class definition for the given class on the given stream, if the class definition was added or changed." (self atClass: class includes: #rename) ifTrue: [stream nextChunkPut: 'Smalltalk renameClassNamed: #', (self oldNameFor: class), ' as: #', class name; cr]. ((self atClass: class includes: #change) or: [self atClass: class includes: #add]) ifTrue: [stream command: 'H3'; nextChunkPut: (self fatDefForClass: class); cr; command: '/H3']. (self atClass: class includes: #comment) ifTrue: [class theNonMetaClass organization putCommentOnFile: stream numbered: 0 moveSource: false forClass: class theNonMetaClass]. ! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! oldNameFor: class ^ (changeRecords at: class name) priorName! ! !ChangeSet class methodsFor: 'fileIn/Out' stamp: 'RAA 9/30/1999 14:34'! superclassOrder: classes "Arrange the classes in the collection, classes, in superclass order so the classes can be properly filed in." | all list i aClass | list _ classes copy. "list is indexable" all _ OrderedCollection new: list size. [list size > 0] whileTrue: [ i _ 0. [ i _ i + 1. aClass _ list at: i. (list includesAnyOf: aClass allSuperclasses) or: [ aClass isMeta and: [ (list includes: aClass soleInstance) or: [ list includesAnyOf: aClass soleInstance allSuperclasses ] ]. ]. ] whileTrue. all addLast: aClass. list _ list copyWithout: aClass ]. ^all! ! !ChangeSet class methodsFor: 'defaults' stamp: 'di 3/23/2000 15:20'! defaultName | namesInUse try | namesInUse _ ChangeSorter gatherChangeSets collect: [:each | each name]. 1 to: 999999 do: [:i | try _ 'Unnamed' , i printString. (namesInUse includes: try) ifFalse: [^ try]]! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 3/6/1999 09:33'! morphicWindow "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). ^ window ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sma 4/30/2000 09:29'! open "ChangeSorterPluggable new open" | topView | Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph]. 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: 'sw 3/6/1999 09:34'! openAsMorph "ChangeSorter new openAsMorph" ^ self morphicWindow openInWorld. ! ! !ChangeSorter methodsFor: 'creation' stamp: 'di 2/1/1999 20:51'! 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." | chgSetList aListMorph | contents _ ''. self addDependent: window. "so it will get changed: #relabel" window addMorph: (chgSetList _ PluggableListMorphByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted: keystroke: #changeSetListKey:from:) frame: (((0@0 extent: 0.5@0.25) scaleBy: rect extent) translateBy: rect origin). chgSetList autoDeselect: false. window addMorph: (PluggableListMorphByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classMenu: keystroke: #classListKey:from:) frame: (((0.5@0 extent: 0.5@0.25) scaleBy: rect extent) translateBy: rect origin). aListMorph _ PluggableListMorphByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (((0@0.25 extent: 1@0.25) scaleBy: rect extent) translateBy: rect origin). window addMorph: (PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (((0@0.5 corner: 1@1) scaleBy: rect extent) translateBy: rect origin). ! ! !ChangeSorter methodsFor: 'creation' stamp: 'sw 1/26/1999 09:15'! 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 cngSetListView | contents _ ''. self addDependent: topView. "so it will get changed: #relabel" cngSetListView _ PluggableListViewByItem on: self list: #changeSetList selected: #currentCngSet changeSelected: #showChangeSetNamed: menu: #changeSetMenu:shifted:. cngSetListView window: ((0 @ 0 extent: 180 @ 100) translateBy: offset). topView addSubView: cngSetListView. classView _ PluggableListViewByItem on: self list: #classList selected: #currentClassName changeSelected: #currentClassName: menu: #classMenu: keystroke: #classListKey:from:. classView window: (180 @ 0 extent: 180 @ 100). topView addSubView: classView toRightOf: cngSetListView. messageView _ PluggableListViewByItem on: self list: #messageList selected: #currentSelector changeSelected: #currentSelector: menu: #messageMenu:shifted: keystroke: #messageListKey:from:. messageView menuTitleSelector: #messageListSelectorTitle. messageView window: (0 @ 100 extent: 360 @ 100). topView addSubView: messageView below: cngSetListView. 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: messageView.! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 1/27/2000 11:19'! changeSetCurrentlyDisplayed ^ myChangeSet! ! !ChangeSorter methodsFor: 'access' stamp: 'di 6/15/1998 20:33'! modelWakeUp "A window with me as model is being entered. Make sure I am up-to-date with the changeSets." self canDiscardEdits ifTrue: [self update]! ! !ChangeSorter methodsFor: 'access' stamp: 'sw 1/28/1999 12:31'! showChangeSet: chgSet myChangeSet == chgSet ifFalse: [ myChangeSet _ chgSet. currentClassName _ nil. currentSelector _ nil]. self changed: #relabel. self changed: #currentCngSet. "new -- list of sets" self changed: #mainButtonName. "old, button" self changed: #classList. self changed: #messageList. self setContents. self contentsChanged.! ! !ChangeSorter methodsFor: 'access' stamp: 'tk 6/10/1998 07:38'! showChangeSetNamed: aName aName ifNil: [^ self showChangeSet: nil]. self showChangeSet: (AllChangeSets detect: [:each | each name = aName]) ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/1999 23:22'! addPreamble myChangeSet assurePreambleExists. self okToChange ifTrue: [currentClassName _ nil. currentSelector _ nil. self showChangeSet: myChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/1/2000 15:48'! browseMethodConflicts "Check to see if any other change set also holds changes to any methods in the selected change set; if so, open a browser on all such." | aList aClass aSelector | aList _ myChangeSet changedMessageListAugmented select: [:aChange | MessageSet parse: aChange toClassAndSelector: [:cls :sel | aClass _ cls. aSelector _ sel]. (ChangeSorter allChangeSetsWithClass: aClass selector: aSelector) size > 1]. aList size == 0 ifTrue: [^ self inform: 'No other change set has changes for any method in this change set.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in other change sets (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/12/1998 16:29'! changeSetList ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets]. ^ AllChangeSets reversed collect: [:each | each name]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 2/1/1999 20:58'! changeSetListKey: aChar from: view "Respond to a Command key. I am a model with a listView that has a list of changeSets." aChar == $f ifTrue: [^ self findCngSet]. ^ self arrowKey: aChar from: view! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'jm 6/7/2001 15:41'! changeSetMenu: aMenu shifted: isShifted "Could be for a single or double changeSorter" aMenu title: 'Change Set: ' , myChangeSet name. isShifted ifTrue: [^ self shiftedChangeSetMenu: aMenu]. aMenu add: 'make changes go to me' action: #newCurrent. aMenu addLine. aMenu add: 'new change set...' action: #newSet. aMenu add: 'find...' action: #findCngSet. aMenu add: 'show...' action: #chooseCngSet. aMenu add: 'rename change set' action: #rename. aMenu addLine. aMenu add: 'file out' action: #fileOut. aMenu add: 'browse methods' action: #browseChangeSet. aMenu addLine. parent ifNotNil: [aMenu add: 'copy all to other side' action: #copyAllToOther. aMenu add: 'submerge into other side' action: #submergeIntoOtherSide. aMenu add: 'subtract other side' action: #subtractOtherSide. aMenu addLine]. myChangeSet hasPreamble ifTrue: [aMenu add: 'edit preamble' action: #addPreamble. aMenu add: 'remove preamble' action: #removePreamble] ifFalse: [aMenu add: 'add preamble' action: #addPreamble]. "aMenu add: 'edit preamble...' action: #editPreamble." myChangeSet hasPostscript ifTrue: [aMenu add: 'edit postscript...' action: #editPostscript. aMenu add: 'remove postscript' action: #removePostscript] ifFalse: [aMenu add: 'add postscript...' action: #editPostscript]. aMenu addLine. aMenu add: 'destroy change set' action: #remove. aMenu addLine. aMenu add: 'more...' action: #shiftedYellowButtonActivity. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 10/27/1999 14:20'! checkForUnsentMessages "Open a message list browser on all unsent messages in the current change set" myChangeSet checkForUnsentMessages ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 13:36'! checkThatSidesDiffer: escapeBlock "If the change sets on both sides of the dual sorter are the same, put up an error message and escape via escapeBlock, else proceed happily" (myChangeSet == (parent other: self) changeSet) ifTrue: [self inform: 'This command requires that the change sets selected on the two sides of the change sorter *not* be the same.'. ^ escapeBlock value] ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/8/1999 14:52'! chooseCngSet "Present the user with an alphabetical list of change set names, and let her choose one" | index changeSetsSortedAlphabetically | self okToChange ifFalse: [^ self]. ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets]. changeSetsSortedAlphabetically _ AllChangeSets asSortedCollection: [:a :b | a name asLowercase withoutLeadingDigits < b name asLowercase withoutLeadingDigits]. index _ (PopUpMenu labels: (changeSetsSortedAlphabetically collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (changeSetsSortedAlphabetically at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/28/1999 12:30'! 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 contentsChanged. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/27/2000 11:21'! copyAllToOther "Copy this entire change set into the one on the other side" | companionSorter | self checkThatSidesDiffer: [^ self]. (companionSorter _ parent other: self) changeSetCurrentlyDisplayed assimilateAllChangesFoundIn: myChangeSet. companionSorter changed: #classList. "Later the changeSet itself will notice..." companionSorter changed: #messageList! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/5/1998 06:47'! currentCngSet ^ myChangeSet name! ! !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: 'sw 11/22/1998 23:57'! 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 readOnlyFileNamed: aFileName) named: aFileName. aNewChangeSet ifNotNil: [self showChangeSet: aNewChangeSet]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 6/10/1999 12:44'! fileOut "File out the current change set." myChangeSet fileOut. parent modelWakeUp. "notice object conversion methods created" ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/16/1999 13:30'! findCngSet "Search for a changeSet by name. Pop up a menu of all changeSets whose name contains the string entered by the user. If only one matches, then the pop-up menu is bypassed" | index pattern candidates | self okToChange ifFalse: [^ self]. ChangeSet instanceCount > AllChangeSets size ifTrue: [self class gatherChangeSets]. pattern _ FillInTheBlank request: 'ChangeSet name or fragment?'. pattern isEmpty ifTrue: [^ self]. candidates _ AllChangeSets select: [:c | c name includesSubstring: pattern caseSensitive: false]. candidates size = 0 ifTrue: [^ self beep]. candidates size = 1 ifTrue: [^ self showChangeSet: candidates first]. index _ (PopUpMenu labels: (candidates collect: [:each | each name]) asStringWithCr) startUp. index = 0 ifFalse: [self showChangeSet: (candidates at: index)]. ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'tk 10/26/1999 14:24'! goToChangeSetsProject "Transport the user to a project which bears the selected changeSet as its current changeSet" | aProject | (aProject _ myChangeSet correspondingProject) ifNotNil: [aProject enter: false revert: false saveForRevert: false] ifNil: [self inform: 'Has no project']! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/10/1999 01:01'! inspectChangeSet "Open a message list browser on the new and changed methods in the current change set" myChangeSet inspectWithLabel: 'Change set: ', myChangeSet name ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 2/17/1999 11:05'! lookForSlips "Open a message list browser on the new and changed methods in the current change set" myChangeSet lookForSlips ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/1/2000 15:48'! methodConflictsWithOtherSide "Check to see if the change set on the other side shares any methods with the selected change set; if so, open a browser on all such." | aList aClass aSelector other | self checkThatSidesDiffer: [^ self]. other _ (parent other: self) changeSet. aList _ myChangeSet changedMessageListAugmented select: [:aChange | MessageSet parse: aChange toClassAndSelector: [:cls :sel | aClass _ cls. aSelector _ sel]. aClass notNil and: [(other methodChangesAtClass: aClass name) includesKey: aSelector]]. aList size == 0 ifTrue: [^ self inform: 'There are no methods that appear both in this change set and in the one on the other side.']. MessageSet openMessageList: aList name: 'Methods in "', myChangeSet name, '" that are also in ', other name,' (', aList size printString, ')' ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 9/4/1998 09:00'! newSet "Create a new changeSet and show it., making it the current one. Reject name if already in use." | aSet | self okToChange ifFalse: [^ self]. aSet _ self class newChangeSet. aSet ifNotNil: [self update. self showChangeSet: aSet. self changed: #relabel]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 1/27/2000 15:03'! promoteToTopChangeSet self class promoteToTop: myChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/14/1998 12:00'! remove "Completely destroy my change set. Check if it's OK first" self okToChange ifFalse: [^ self]. self removePrompting: true. self update! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 6/29/1999 20:53'! removePostscript (myChangeSet hasPostscript and: [myChangeSet postscriptHasDependents]) ifTrue: [^ self inform: 'Cannot remove the postscript right now because there is at least one window open on that postscript. Close that window and try again.']. myChangeSet removePostscript. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/5/1999 19:32'! removePreamble myChangeSet removePreamble. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 5/26/2000 22:34'! 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]]. (doPrompt and: [myChangeSet hasPreamble or: [myChangeSet hasPostscript]]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble and/or a postscript, which will be lost if you destroy the change set. Do you really want to go ahead with this?') 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: 'di 6/14/1998 11:58'! 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 update. self changed: #mainButtonName. self changed: #relabel.! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'jm 10/7/2002 06:05'! shiftedChangeSetMenu: aMenu aMenu add: 'conflicts with other change sets' action: #browseMethodConflicts. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in at least one other change set.'. parent ifNotNil: [aMenu add: 'conflicts with opposite side' action: #methodConflictsWithOtherSide. aMenu balloonTextForLastItem: 'Browse all methods that occur both in this change set and in the one on the opposite side of the change sorter.'. ]. aMenu addLine. aMenu add: 'check for slips' action: #lookForSlips. aMenu balloonTextForLastItem: 'Check this change set for halts and references to Transcript.'. aMenu add: 'check for unsent messages' action: #checkForUnsentMessages. aMenu balloonTextForLastItem: 'Check this change set for messages that are not sent anywhere in the system'. aMenu addLine. aMenu add: 'inspect change set' action: #inspectChangeSet. aMenu balloonTextForLastItem: 'Open an inspector on this change set. (There are some details in a change set which you don''t see in a change sorter.)'. aMenu add: 'update' action: #update. aMenu balloonTextForLastItem: 'Update the display for this change set. (This is done automatically when you activate this window, so is seldom needed.)'. aMenu add: 'go to change set''s project' action: #goToChangeSetsProject. aMenu balloonTextForLastItem: 'If this change set is currently associated with a Project, go to that project right now.'. aMenu add: 'promote to top of list' action: #promoteToTopChangeSet. aMenu balloonTextForLastItem: 'Make this change set appear first in change-set lists in all change sorters.'. aMenu add: 'trim history' action: #trimHistory. aMenu balloonTextForLastItem: ' Drops any methods added and then removed, as well as renaming and reorganization of newly-added classes. NOTE: can cause confusion if later filed in over an earlier version of these changes'. aMenu add: 'clear this change set' action: #clearChangeSet. aMenu balloonTextForLastItem: 'Reset this change set to a pristine state where it holds no information. CAUTION: this is destructive and irreversible!!'. aMenu addLine. aMenu add: 'file into new...' action: #fileIntoNewChangeSet. aMenu balloonTextForLastItem: 'Load a fileout from disk and place its changes into a new change set (seldom needed -- much better to do this from a file-list browser these days.)'. aMenu addLine. aMenu add: 'more...' action: #unshiftedYellowButtonActivity. aMenu balloonTextForLastItem: 'Takes you back to the primary change-set menu.'. ^ aMenu! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 5/26/2000 18:23'! 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 checkThatSidesDiffer: [^ self]. 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]. (myChangeSet hasPreamble or: [myChangeSet hasPostscript]) ifTrue: [(self confirm: 'Caution!! This change set has a preamble or a postscript or both. If you submerge it into the other side, these will be lost. Do you really want to go ahead with this?') 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 modelWakeUp. "(parent other: self) changed: #classList. (parent other: self) changed: #messageList."! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 7/8/1999 12:32'! subtractOtherSide "Subtract the changes found on the other side from the requesting side." self checkThatSidesDiffer: [^ self]. myChangeSet forgetAllChangesFoundIn: ((parent other: self) changeSet). self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 5/12/2000 15:03'! trimHistory "Drop non-essential history (rename, reorg, method removals) from newly-added classes." myChangeSet trimHistory ! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'di 6/21/1998 13:02'! update "recompute all of my panes" self updateIfNecessary. parent ifNotNil: [(parent other: self) updateIfNecessary]! ! !ChangeSorter methodsFor: 'changeSet menu' stamp: 'sw 3/6/1999 11:01'! updateIfNecessary "recompute all of my panes" | newList | myChangeSet isMoribund ifTrue: [^ self showChangeSet: Smalltalk changes]. self okToChange ifFalse: [^ self]. priorChangeSetList == nil ifTrue: [priorChangeSetList _ self changeSetList. self changed: #changeSetList] ifFalse: [newList _ self changeSetList. priorChangeSetList = newList ifFalse: [priorChangeSetList _ newList. self changed: #changeSetList]]. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 10/5/1999 18:01'! classListKey: aChar from: view "Overridden to obviate spurious StringHolder processing of $s for findClass" ^ self messageListKey: aChar from: view! ! !ChangeSorter methodsFor: 'class list' stamp: 'jm 9/25/2006 22:01'! classMenu: aMenu "Set up aMenu for the class-lis." parent ifNotNil: [aMenu addList: #( "These two only apply to dual change sorters" ('copy class chgs to other side' copyClassToOther) ('move class chgs to other side' moveClassToOther))]. aMenu addList: #( ('delete class chgs from this change set' forgetClass) - ('browse full (b)' browseMethodFull) ('browse hierarchy' spawnHierarchy) ('browse protocol' spawnProtocol) - ('printOut' printOutClass) ('fileOut' fileOutClass) - ('inst var refs...' browseInstVarRefs) ('inst var defs...' browseInstVarDefs) ('class var refs...' browseClassVarRefs) ('class vars' browseClassVariables) ('class refs (N)' browseClassRefs) - ('unsent methods' browseUnusedMethods) ('unreferenced inst vars' showUnreferencedInstVars)). ^ aMenu! ! !ChangeSorter methodsFor: 'class list' stamp: 'di 4/4/2000 09:37'! copyClassToOther "Place these changes in the other changeSet also" | otherSorter otherChangeSet | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ self beep]. currentClassName ifNil: [^ self beep]. otherSorter _ parent other: self. otherChangeSet _ otherSorter changeSet. otherChangeSet absorbClass: self selectedClassOrMetaClass name from: myChangeSet. otherSorter showChangeSet: otherChangeSet.! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 1/28/1999 12:30'! currentClassName: aString currentClassName _ aString. currentSelector _ nil. "fix by wod" self changed: #currentClassName. self changed: #messageList. self setContents. self contentsChanged.! ! !ChangeSorter methodsFor: 'class list' stamp: 'ls 8/12/1998 23:47'! forgetClass "Remove all mention of this class from the changeSet" self okToChange ifFalse: [^ self]. currentClassName ifNotNil: [ myChangeSet removeClassChanges: currentClassName. currentClassName _ nil. currentSelector _ nil. self showChangeSet: myChangeSet]. ! ! !ChangeSorter methodsFor: 'class list' stamp: 'di 4/3/2000 20:31'! moveClassToOther "Place class changes in the other changeSet and remove them from this one" self copyClassToOther. self forgetClass! ! !ChangeSorter methodsFor: 'class list' stamp: 'sw 12/7/1998 09:43'! selectedClass "Answer the currently-selected class. If there is no selection, or if the selection refers to a class no longer extant, return nil" | c | ^ currentClassName ifNotNil: [(c _ self selectedClassOrMetaClass) ifNotNil: [c theNonMetaClass]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'di 3/23/2000 13:34'! 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 methodInfoFromRemoval: {class name. selector}. pair ifNil: [^ nil]. sourcePointer _ pair first. method _ CompiledMethod toReturnSelf setSourcePointer: sourcePointer. category _ pair last]. VersionsBrowser browseVersionsOf: method class: self selectedClass meta: class isMeta category: category selector: selector lostMethodPointer: sourcePointer. ! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 7/8/1999 12:31'! copyMethodToOther "Place this change in the other changeSet also" | other cls sel | self checkThatSidesDiffer: [^ self]. currentSelector ifNotNil: [other _ (parent other: self) changeSet. cls _ self selectedClassOrMetaClass. sel _ currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other] ! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 1/28/1999 12:31'! currentSelector: messageName currentSelector _ messageName. self changed: #currentSelector. self setContents. self contentsChanged.! ! !ChangeSorter methodsFor: 'message list' stamp: 'di 6/22/1998 02:08'! forget "Drop this method from the changeSet" self okToChange ifFalse: [^ self]. currentSelector ifNotNil: [ myChangeSet removeSelectorChanges: self selectedMessageName class: self selectedClassOrMetaClass. currentSelector _ nil. self showChangeSet: myChangeSet]! ! !ChangeSorter methodsFor: 'message list' stamp: 'di 4/25/2000 10:33'! messageList | probe newSelectors | currentClassName ifNil: [^ #()]. probe _ (currentClassName endsWith: ' class') ifTrue: [currentClassName] ifFalse: [currentClassName asSymbol]. newSelectors _ myChangeSet selectorsInClass: probe. (newSelectors includes: currentSelector) ifFalse: [currentSelector _ nil]. ^ newSelectors asSortedCollection ! ! !ChangeSorter methodsFor: 'message list' stamp: 'jm 9/25/2006 22:01'! messageMenu: aMenu shifted: shifted "Could be for a single or double changeSorter" shifted ifTrue: [^ self shiftedMessageMenu: aMenu]. parent ifNotNil: [aMenu addList: #( ('copy method to other side' copyMethodToOther) ('move method to other side' moveMethodToOther))]. aMenu addList: #( ('delete method from change set' forget) - ('remove method from system (x)' removeMessage) - ('browse full (b)' browseMethodFull) ('browse hierarchy' spawnHierarchy) ('browse method (O)' openSingleMessageBrowser) - ('fileOut' fileOutMessage) ('printOut' printOutMessage) - ('senders of... (n)' browseSendersOfMessages) ('implementors of... (m)' browseMessages) ('inheritance (i)' methodHierarchy) ('versions (v)' browseVersions) - ('more...' shiftedYellowButtonActivity)). ^ aMenu ! ! !ChangeSorter methodsFor: 'message list' stamp: 'sw 7/8/1999 12:31'! moveMethodToOther "Place this change in the other changeSet and remove it from this side" | other cls sel | self checkThatSidesDiffer: [^ self]. self okToChange ifFalse: [^ self beep]. currentSelector ifNotNil: [other _ (parent other: self) changeSet. other == myChangeSet ifTrue: [^ self beep]. cls _ self selectedClassOrMetaClass. sel _ currentSelector asSymbol. other absorbMethod: sel class: cls from: myChangeSet. (parent other: self) showChangeSet: other. self forget "removes the method from this side"] ! ! !ChangeSorter methodsFor: 'message list' stamp: 'di 6/21/1998 23:13'! removeFromCurrentChanges "Redisplay after removal in case we are viewing the current changeSet" super removeFromCurrentChanges. currentSelector _ nil. self showChangeSet: myChangeSet! ! !ChangeSorter methodsFor: 'message list' stamp: 'di 4/4/2000 10:54'! 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]. self selectedClassOrMetaClass removeSelector: sel. self update. confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: sel]]! ! !ChangeSorter methodsFor: 'message list' stamp: 'tk 2/7/2000 11:01'! selectedMessage "Answer a copy of the source code for the selected message selector." ^ contents ifNil: [''] ifNotNil: [contents copy]! ! !ChangeSorter methodsFor: 'message list' stamp: 'jm 10/14/2002 19:17'! shiftedMessageMenu: aMenu ^ aMenu addList: #( - ('toggle diffing' toggleDiffing) ('implementors of sent messages' browseAllMessages) ('change category...' changeCategory) - ('inspect instances' inspectInstances) ('inspect subinstances' inspectSubInstances) - ('change sets with this method' findMethodInChangeSets) ('revert to previous version' revertToPreviousVersion) ('revert and forget' revertAndForget) - ('more...' unshiftedYellowButtonActivity))! ! !ChangeSorter methodsFor: 'code pane' stamp: 'jm 5/29/2003 19:13'! 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: [(myChangeSet preambleString == nil or: [aString size == 0]) ifTrue: [ ^ false]. (aString select: [:char | char == $"]) size odd ifTrue: [self inform: 'unmatched double quotes in preamble'] ifFalse: [(Scanner new scanTokens: aString) size > 0 ifTrue: [ self inform: 'Part of the preamble is not within double-quotes. To put a double-quote inside a comment, type two double-quotes in a row. (Ignore this warning if you are including a doIt in the preamble.)']]. myChangeSet preambleString: aString. self currentSelector: nil. "forces update with no 'unsubmitted chgs' feedback" ^ true]. 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: 'mas 5/20/2000 22:03'! setContents "return the source code that shows in the bottom pane" | sel class strm changeType | self clearUserEditFlag. currentClassName ifNil: [^ contents _ myChangeSet preambleString ifNil: ['']]. 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 sourceCodeAt: sel. Preferences browseWithPrettyPrint ifTrue: [contents _ class compilerClass new format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. self showDiffs ifTrue: [contents _ self diffFromPriorSourceFor: contents]. ^ contents _ contents asText makeSelectorBoldIn: class] ifTrue: [strm _ WriteStream on: (String new: 100). (myChangeSet classChangeAt: currentClassName) do: [:each | each = #remove ifTrue: [strm nextPutAll: 'Entire class was removed.'; cr]. each = #addedThenRemoved ifTrue: [strm nextPutAll: 'Class was added then removed.']. each = #rename ifTrue: [strm nextPutAll: 'Class name was changed.'; cr]. each = #add ifTrue: [strm nextPutAll: 'Class definition was added.'; cr]. each = #change ifTrue: [strm nextPutAll: 'Class definition was changed.'; cr]. each = #reorganize ifTrue: [strm nextPutAll: 'Class organization was changed.'; cr]. each = #comment ifTrue: [strm nextPutAll: 'New class comment.'; cr. ]]. ^ contents _ strm contents].! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 2/21/2000 14:36'! allChangeSetsWithClass: class selector: selector class ifNil: [^ #()]. ^ self gatherChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 17:25'! changeSetsNamedSuchThat: nameBlock "(ChangeSorter changeSetsNamedSuchThat: [:name | name first isDigit and: [name initialInteger >= 373]]) do: [:cs | AllChangeSets remove: cs wither]" self gatherChangeSets. ^ AllChangeSets select: [:aChangeSet | nameBlock value: aChangeSet name]! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 4/3/2000 14:51'! gatherChangeSets "ChangeSorter gatherChangeSets" "Collect any change sets created in other projects" | allChangeSets obsolete | allChangeSets _ AllChangeSets asSet. ChangeSet allSubInstances do: [:each | (allChangeSets includes: each) == (obsolete _ each isMoribund) ifTrue:[ obsolete ifTrue: ["Was included and is obsolete." AllChangeSets remove: each] ifFalse: ["Was not included and is not obsolete." AllChangeSets add: each]]]. ^ AllChangeSets ! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 8/20/1999 10:27'! highestNumberedChangeSet "ChangeSorter highestNumberedChangeSet" | aList | aList _ (self allChangeSetNames select: [:aString | aString startsWithDigit] thenCollect: [:aString | aString initialIntegerOrNil]). ^ (aList size > 0) ifTrue: [aList max] ifFalse: [nil] ! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 2/15/1999 23:02'! mostRecentChangeSetWithChangeForClass: class selector: selector | hits | hits _ self gatherChangeSets select: [:cs | (cs atSelector: selector class: class) ~~ #none]. hits isEmpty ifTrue: [^ 'not in any change set']. ^ 'recent cs: ', hits last name! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 16:56'! newChangeSet "Prompt the user for a name, and establish a new change set of that name (if ok), making it the current changeset. Return nil of not ok, else return the actual changeset." | newName newSet | newName _ FillInTheBlank request: 'Please name the new change set:' initialAnswer: ChangeSet defaultName. newName isEmpty ifTrue: [self inform: 'nothing done'. ^ nil]. (self changeSetNamed: newName) ifNotNil: [self inform: 'Sorry that name is already used'. ^ nil]. newSet _ ChangeSet new name: newName. AllChangeSets add: newSet. Smalltalk newChanges: newSet. Transcript cr; show: newName, ' is now the current change set'. ^ newSet ! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'jm 6/21/2003 11:17'! newChangesFromStream: aStream named: aName "File in the code from the stream into a new change set whose name is derived from aName. Leave the 'current change set' unchanged. Returns the new change set; Returns nil on failure." | newName aNewChangeSet existingChanges | existingChanges _ Smalltalk changes. newName _ aName sansPeriodSuffix. (self changeSetNamed: newName) ~~ nil ifTrue: [self inform: 'Sorry -- "', newName, '" is already used as a change-set name'. aStream close. ^ nil]. aNewChangeSet _ ChangeSet new. aNewChangeSet name: newName. AllChangeSets add: aNewChangeSet. Smalltalk newChanges: aNewChangeSet. aStream fileInAnnouncing: 'Loading ', newName, '...'. Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName. Smalltalk newChanges: existingChanges. ^ aNewChangeSet! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 1/27/2000 15:04'! promoteToTop: aChangeSet "make aChangeSet the first in the list from now on" self gatherChangeSets. AllChangeSets remove: aChangeSet ifAbsent: [^ self]. AllChangeSets add: aChangeSet. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 8/18/1999 09:44'! removeChangeSet: aChangeSet "Remove the given changeSet. Caller must assure that it's cool to do this" AllChangeSets remove: aChangeSet ifAbsent: []. aChangeSet wither ! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'tk 6/24/1999 11:32'! 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 allSubInstancesDo: [: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: 'as yet unclassified' stamp: 'di 11/8/1998 16:32'! removeChangeSetsNamedSuchThat: nameBlock (ChangeSorter changeSetsNamedSuchThat: nameBlock) do: [:cs | AllChangeSets remove: cs wither]! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'di 11/9/1998 10:23'! removeEmptyUnnamedChangeSets "Remove all change sets that are empty, whose names start with Unnamed, and which are not nailed down by belonging to a Project." "ChangeSorter removeEmptyUnnamedChangeSets" | toGo | (toGo _ (self changeSetsNamedSuchThat: [:csName | csName beginsWith: 'Unnamed']) select: [:cs | cs isEmpty and: [cs okayToRemoveInforming: false]]) do: [:cs | AllChangeSets remove: cs wither]. self inform: toGo size printString, ' change set(s) removed.'! ! !ChangeSorter class methodsFor: 'as yet unclassified' stamp: 'sw 1/4/2000 16:31'! reorderChangeSets "ChangeSorter reorderChangeSets" "Change the order of the change sets to something more convenient: First come the unnumbered changesets that come with the release. Next come the numbered updates. Next come all remaining changesets In a ChangeSorter, they will appear in the reversed order." | newHead newMid newTail itsName | self gatherChangeSets. newHead _ OrderedCollection new. newMid _ OrderedCollection new. newTail _ OrderedCollection new. AllChangeSets do: [:aSet | itsName _ aSet name. ((itsName beginsWith: 'Play With Me') or: [#('New Changes' 'MakeInternal') includes: itsName]) ifTrue: [newHead add: aSet] ifFalse: [itsName startsWithDigit ifTrue: [newMid add: aSet] ifFalse: [newTail add: aSet]]]. AllChangeSets _ newHead, newMid, newTail. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]! ! !ChangedMessageSet methodsFor: 'everything' stamp: 'sw 9/30/1999 12:15'! contents: aString notifying: aController | selectedMessageName selector oldMessageList cls | self okayToAccept ifFalse: [^ false]. 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 methodsFor: 'as yet unclassified' stamp: 'sw 8/5/1998 17:42'! 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 _ aChangeSet changedMessageListAugmented. self openMessageList: messageSet name: ('Methods in Change Set ', aChangeSet name) autoSelect: nil changeSet: aChangeSet! ! !ChangedMessageSet class methodsFor: 'as yet unclassified' stamp: 'sma 4/30/2000 09:22'! openMessageList: messageList name: labelString autoSelect: autoSelectString changeSet: aChangeSet | messageSet | messageSet _ self messageList: messageList. messageSet changeSet: aChangeSet. messageSet autoSelectString: autoSelectString. Smalltalk isMorphic ifTrue: [self openAsMorph: messageSet name: labelString] ifFalse: [ScheduledControllers scheduleActive: (self open: messageSet name: labelString)]! ! 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: 'testing' stamp: 'ls 7/26/1998 20:27'! isSafeForHTTP "whether a character is 'safe', or needs to be escaped when used, eg, in a URL" ^self isAlphaNumeric or: [ '.~-_' includes: self ]! ! !Character methodsFor: 'testing' stamp: 'di 4/3/1999 00:38'! isSpecial "Answer whether the receiver is one of the special characters" ^'+-/\*~<>=@,%|&?!!' includes: self! ! !Character methodsFor: 'converting' stamp: 'sma 3/11/2000 17:21'! asString ^ String with: self! ! !Character methodsFor: 'converting' stamp: 'sma 3/15/2000 22:57'! isoToSqueak "Convert receiver from iso8895-1 (actually CP1252) to mac encoding. Does not do lf/cr conversion!! Characters not available in MacRoman encoding have been remapped to their base characters or to $?." value < 128 ifTrue: [^ self]. ^ Character value: (#( 219 63 226 196 227 201 160 224 246 228 83 220 206 63 90 63 "80-8F" 63 212 213 210 211 165 208 209 247 170 115 221 207 63 122 217 "90-9F" 202 193 162 163 63 180 124 164 172 169 187 199 194 45 168 248 "A0-AF" 161 177 50 51 171 181 166 225 252 49 188 200 63 63 63 192 "B0-BF" 203 231 229 204 128 129 174 130 233 131 230 232 237 234 235 236 "C0-CF" 63 132 241 238 239 205 133 42 175 244 242 243 134 89 63 167 "D0-DF" 136 135 137 139 138 140 190 141 143 142 144 145 147 146 148 149 "E0-EF" 63 150 152 151 153 155 154 214 191 157 156 158 159 121 63 216 "F0-FF" ) at: value - 127)! ! !Character class methodsFor: 'instance creation' stamp: 'ls 8/15/1998 06:56'! allCharacters ^ (0 to: 255) collect: [:v | Character value: v] ! ! !Character class methodsFor: 'constants' stamp: 'ls 9/8/1998 22:15'! lf "Answer the Character representing a linefeed." ^self value: 10! ! 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' stamp: 'di 6/7/2000 17:33'! copy "Overridden because Rectangle does a deepCopy, which goes nuts with the text" ^ self clone! ! 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: 'stop conditions' stamp: 'ar 1/9/2000 13:51'! 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: 'ar 1/9/2000 13:50'! 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' stamp: 'ar 1/9/2000 13:50'! 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' stamp: 'ar 1/9/2000 13:51'! 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: 'ar 1/8/2000 14:32'! setFont specialWidth _ nil. super setFont! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:47'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. textStyle alignment = Justified ifTrue:[ "Make a local copy of stop conditions so we don't modify the default" stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace]! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:50'! 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: 'jm 7/23/2003 16:03'! 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. self handleIndentation. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "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' stamp: 'ar 1/8/2000 14:34'! characterPointSetX: xVal characterPoint _ xVal @ characterPoint y! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'! lastCharacterExtentSetX: xVal lastCharacterExtent _ xVal @ lastCharacterExtent y! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:34'! lastSpaceOrTabExtentSetX: xVal lastSpaceOrTabExtent _ xVal @ lastSpaceOrTabExtent y! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 19:14'! 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." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterPoint _ aPoint. ^self buildCharacterBlockIn: aParagraph! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'jm 7/23/2003 16:43'! 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. self handleIndentation. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "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' stamp: 'ar 5/17/2000 19:14'! 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." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. characterIndex _ targetIndex. characterPoint _ aParagraph rightMarginForDisplay @ (aParagraph topAtLineIndex: (aParagraph lineIndexOfCharacterIndex: characterIndex)). ^self buildCharacterBlockIn: aParagraph! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'ar 5/19/2000 14:46'! characterNotInFont "See the note in CharacterScanner>>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: 'ar 5/17/2000 17:35'! placeEmbeddedObject: anchoredMorph (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth _ anchoredMorph width. ^ true! ! 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: 'private' stamp: 'ar 1/8/2000 14:27'! addEmphasis: code "Set the bold-ital-under-strike emphasis." emphasisCode _ emphasisCode bitOr: code! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'! addKern: kernDelta "Set the current kern amount." kern _ kern + kernDelta! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 5/17/2000 17:13'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle text _ aParagraph text. textStyle _ aParagraph textStyle. ! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:27'! setActualFont: aFont "Set the basal font to an isolated font reference." font _ aFont! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 5/18/2000 18:02'! setFont "Set the font and other emphasis." text == nil ifFalse:[ emphasisCode _ 0. kern _ 0. indentationLevel _ 0. alignment _ textStyle alignment. font _ nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font _ font emphasized: emphasisCode. "Install various parameters from the font." spaceWidth _ font widthOf: Space. xTable _ font xTable. map _ font characterToGlyphMap. stopConditions _ DefaultStopConditions.! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! text: t textStyle: ts text _ t. textStyle _ ts! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! textColor: ignored "Overridden in DisplayScanner"! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/19/2000 14:45'! characterNotInFont "Note: All fonts should have some sort of a character to glyph mapping. If a character is not in the font it should be mapped to the appropriate glyph (that is the glyph describing a non-existing character). If done correctly, this method should never be called. It is mainly provided for backward compatibility (and I'd really like to get rid of it - ar). 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. 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 7/23/2003 16:10'! handleIndentation "Handle indentation at the start of a line." self indentationLevel timesRepeat: [self plainTab]. ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/17/2000 18:20'! indentationLevel "return the number of tabs that are currently being placed at the beginning of each line" ^indentationLevel ifNil:[0]! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'! indentationLevel: anInteger "set the number of tabs to put at the beginning of each line" indentationLevel _ anInteger! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:23'! 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: 'ar 5/17/2000 18:20'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." | w | destX _ destX + (w _ anchoredMorph width). (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. lastIndex _ lastIndex + 1. self setFont. "Force recalculation of emphasis for next run" ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'jm 7/23/2003 16:24'! plainTab "Adjust destX for a tab." (alignment == Justified and: [self leadingTab not]) ifTrue: [ "embedded tabs in justified text are weird" destX _ destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [ destX _ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. ! ! !CharacterScanner methodsFor: 'scanning' stamp: 'ar 5/23/2000 12:59'! primScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "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, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char | lastIndex _ startIndex. [lastIndex <= stopIndex] whileTrue: [char _ (sourceString at: lastIndex). ascii _ char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextDestX _ destX + (font widthOf: char). nextDestX > rightX ifTrue: [^stops at: CrossedX]. destX _ nextDestX + kernDelta. lastIndex _ lastIndex + 1]. lastIndex _ stopIndex. ^stops at: EndOfRun! ! !CharacterScanner methodsFor: 'scanning' stamp: 'jm 7/23/2003 16:10'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "This method will perform text scanning with kerning." ^ self primScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ar 5/17/2000 17:33'! initialize destX _ destY _ 0.! ! !CharacterScanner class methodsFor: 'class initialization' stamp: 'ar 5/18/2000 16:50'! initialize "CharacterScanner initialize" "NewCharacterScanner initialize" | stopConditions | stopConditions _ Array new: 258. stopConditions atAllPut: nil. stopConditions at: Space asciiValue + 1 put: nil. stopConditions at: Tab asciiValue + 1 put: #tab. stopConditions at: CR asciiValue + 1 put: #cr. stopConditions at: EndOfRun put: #endOfRun. stopConditions at: CrossedX put: #crossedX. DefaultStopConditions _ stopConditions.! ! A set of characters. Lookups for inclusion are very fast.! !CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:33'! add: aCharacter map at: aCharacter asciiValue+1 put: 1.! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:41'! do: aBlock "evaluate aBlock with each character in the set" Character allCharacters do: [ :c | (self includes: c) ifTrue: [ aBlock value: c ] ] ! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:31'! includes: aCharacter ^(map at: aCharacter asciiValue + 1) > 0! ! !CharacterSet methodsFor: 'collection ops' stamp: 'ls 8/17/1998 20:34'! remove: aCharacter map at: aCharacter asciiValue + 1 put: 0! ! !CharacterSet methodsFor: 'conversion' stamp: 'ls 8/17/1998 20:39'! complement "return a character set containing precisely the characters the receiver does not" | set | set _ CharacterSet allCharacters. self do: [ :c | set remove: c ]. ^set! ! !CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'! = anObject ^self class == anObject class and: [ self byteArrayMap = anObject byteArrayMap ]! ! !CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'! hash ^self byteArrayMap hash! ! !CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:35'! byteArrayMap "return a ByteArray mapping each ascii value to a 1 if that ascii value is in the set, and a 0 if it isn't. Intended for use by primitives only" ^map! ! !CharacterSet methodsFor: 'private' stamp: 'ls 8/17/1998 20:30'! initialize map _ ByteArray new: 256 withAll: 0.! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:42'! allCharacters "return a set containing all characters" | set | set _ self empty. 0 to: 255 do: [ :ascii | set add: (Character value: ascii) ]. ^set! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/17/1998 20:36'! empty "return an empty set of characters" ^super new initialize! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 1/3/1999 12:52'! newFrom: aCollection | newCollection | newCollection _ self new. newCollection addAll: aCollection. ^newCollection! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! nonSeparators "return a set containing everything but the whitespace characters" ^self separators complement! ! !CharacterSet class methodsFor: 'instance creation' stamp: 'ls 8/18/1998 00:40'! separators "return a set containing just the whitespace characters" | set | set _ self empty. set addAll: Character separators. ^set! ! I add a number of facilities to those in ClassDescription: A set of all my subclasses (defined in ClassDescription, but only used here and below) A name by which I can be found in a SystemDictionary A classPool for class variables shared between this class and its metaclass A list of sharedPools which probably should be supplanted by some better mechanism. 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. The slot 'subclasses' is a redundant structure. It is never used during execution, but is used by the development system to simplify or speed certain operations. ! !Class methodsFor: 'initialize-release' stamp: 'ar 9/10/1999 17:34'! obsolete "Change the receiver and all of its subclasses to an obsolete class." self == Object ifTrue:[^self error:'Object is NOT obsolete']. name _ 'AnObsolete' , name. Object class instSize + 1 to: self class instSize do: [:i | self instVarAt: i put: nil]. "Store nil over class instVars." classPool _ nil. sharedPools _ nil. self class obsolete. super obsolete. ! ! !Class methodsFor: 'initialize-release' stamp: 'di 12/20/1999 12:37'! removeFromSystem "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver." self environment removeClassFromSystem: self. self obsolete! ! !Class methodsFor: 'initialize-release' stamp: 'sw 8/11/1998 13:23'! removeFromSystemUnlogged "Forget the receiver from the Smalltalk global dictionary. Any existing instances will refer to an obsolete version of the receiver. Do not log the removal either to the current change set nor to the system changes log" Smalltalk removeClassFromSystemUnlogged: self. self obsolete! ! !Class methodsFor: 'initialize-release' stamp: 'ar 2/13/1999 21:04'! 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 ifAbsent:[ (self confirm: 'The pool dictionary ', poolName,' does not exist.', '\Do you want it automatically created?' withCRs) ifTrue:[Smalltalk at: poolName asSymbol put: Dictionary new] ifFalse:[^self error: poolName,' does not exist']])]. 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' stamp: 'ar 7/15/1999 16:39'! 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. Must only be sent to a new instance; else we would need Object flushCache." superclass _ sup. methodDict _ md. format _ ft. name _ nm. organization _ org. instanceVariables _ nilOrArray. classPool _ pool. sharedPools _ poolSet! ! !Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. subclasses _ nil. "Important for moving down the subclasses field into Class" ! ! !Class methodsFor: 'testing' stamp: 'ar 7/15/1999 15:36'! isObsolete "Return true if the receiver is obsolete." ^(self environment at: name ifAbsent:[nil]) ~~ self! ! !Class methodsFor: 'copying' stamp: 'di 2/17/2000 22:43'! copy | newClass | newClass _ self class copy new superclass: superclass methodDict: self methodDict copy format: format name: name organization: self 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: 'class name' stamp: 'bf 5/31/2000 17:24'! rename: aString "The new name of the receiver is the argument, aString." | newName | (newName _ aString asSymbol) ~= self name ifTrue: [(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]! ! !Class methodsFor: 'instance variables' stamp: 'ar 7/15/1999 18:56'! addInstVarName: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) name: self name inEnvironment: self environment subclassOf: superclass type: self typeOfClass instanceVariableNames: self instanceVariablesString , aString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category ! ! !Class methodsFor: 'instance variables' stamp: 'ar 7/15/1999 18:56'! 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]. ^(ClassBuilder new) name: self name inEnvironment: self environment subclassOf: superclass type: self typeOfClass instanceVariableNames: newInstVarString classVariableNames: self classVariablesString poolDictionaries: self sharedPoolsString category: self category! ! !Class methodsFor: 'class variables' stamp: 'di 3/27/2000 21:54'! 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 | 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" Smalltalk changes changeClass: self from: self. classPool declare: symbol from: Undeclared]! ! !Class methodsFor: 'class variables' stamp: 'jm 7/24/1999 12:58'! 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." | aSymbol | aSymbol _ aString asSymbol. (classPool includesKey: aSymbol) ifFalse: [^self error: aString, ' is not a class variable']. self withAllSubclasses do:[:subclass | (Array with: subclass with: subclass class) do:[:classOrMeta | (classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol)) isEmpty ifFalse: [ (self confirm: (aString,' is still used in code of class ', classOrMeta name, '.\Is it okay to move it to Undeclared?') withCRs) ifTrue:[^Undeclared declare: aSymbol from: classPool] ifFalse:[^self]]]]. classPool removeKey: aSymbol. classPool isEmpty ifTrue: [classPool _ nil]. ! ! !Class methodsFor: 'compiling' stamp: 'di 12/4/1999 07:18'! canFindWithoutEnvironment: varName "This method is used for analysis of system structure -- see senders." "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." | assoc | "First look in classVar dictionary." (assoc _ self classPool associationAt: varName ifAbsent: []) == nil ifFalse: [^ true]. "Next look in shared pools." self sharedPools do: [:pool | assoc _ pool associationAt: varName ifAbsent: [ "Hideous string key hack from Hypersqueak now used in Wonderland" pool associationAt: varName asString ifAbsent: []]. assoc == nil ifFalse: [^ true]]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ superclass scopeHas: varName ifTrue: [:ignored]]. ! ! !Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'! compileAll super compileAll. self class compileAll.! ! !Class methodsFor: 'compiling' stamp: 'di 12/4/1999 16:51'! 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." | assoc | "First look in classVar dictionary." (assoc _ self classPool associationAt: varName ifAbsent: []) == nil ifFalse: [assocBlock value: assoc. ^ true]. "Next look in shared pools." self sharedPools do: [:pool | assoc _ pool associationAt: varName ifAbsent: [ "String key hack from Hypersqueak now used in Wonderland **Eliminate this**" pool associationAt: varName asString ifAbsent: []]. assoc == nil ifFalse: [assocBlock value: assoc. ^true]]. "Next look in declared environment." (assoc _ self environment associationAtOrAbove: varName ifAbsent: [nil]) == nil ifFalse: [assocBlock value: assoc. ^ true]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ superclass scopeHas: varName ifTrue: assocBlock]. ! ! !Class methodsFor: 'subclass creation' stamp: 'jm 11/14/2003 09:17'! subclass: t instanceVariableNames: f classVariableNames: d module: m "Provided for compatability with newer versions of Squeak." | s | s _ WriteStream on: String new. m do: [:each | s nextPutAll: each; space]. s size = 0 ifTrue: [s nextPutAll: 'Uncategorized'] ifFalse: [s skip: -1]. self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: '' category: s contents. ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'! 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)." ^(ClassBuilder new) superclass: self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'! 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." ^(ClassBuilder new) superclass: self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 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." ^(ClassBuilder new) superclass: self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 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." ^(ClassBuilder new) superclass: self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'dwh 11/20/1999 23:44'! weakSubclass: 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 weak indexable pointer variables." ^(ClassBuilder new) superclass: self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !Class methodsFor: 'fileIn/Out' stamp: 'jm 10/7/2002 06:57'! 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' stamp: 'ar 12/22/1999 17:32'! fileOutInitializerOn: aStream ^self class fileOutInitializerOn: aStream! ! !Class methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:30'! 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." ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! !Class methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:29'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool "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 initializing: aBool]! ! !Class methodsFor: 'fileIn/Out' stamp: 'dtl 1/15/2000 17:54'! fileOutPool: aPool onFileStream: aFileStream | aPoolName aValue | aPoolName _ Smalltalk keyAtIdentityValue: 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' stamp: 'ar 2/13/1999 21:17'! 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 keyAtIdentityValue: aPool))]. poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream]. ! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'! 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']. subclasses == nil ifTrue: [subclasses _ Array with: aSubclass. ^self]. subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" subclasses _ subclasses copyWith: aSubclass.! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'! removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." subclasses == nil ifFalse: [subclasses _ subclasses copyWithout: aSubclass. subclasses isEmpty ifTrue: [subclasses _ nil]]. ! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'! subclasses "Answer a Set containing the receiver's subclasses." ^subclasses == nil ifTrue: [#()] ifFalse: [subclasses copy]! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'jm 5/18/2003 13:40'! subclassesDo: aBlock "Evaluate the given block for each of the receiver's immediate subclasses." subclasses ifNotNil: [subclasses do: aBlock]. ! ! !Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'! setName: aSymbol "Private - set the name of the class" name _ aSymbol.! ! !Class methodsFor: 'organization' stamp: 'di 11/16/1999 16:25'! environment environment == nil ifTrue: [^ super environment]. ^ environment! ! !Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'! environment: anEnvironment environment _ anEnvironment! ! !Class class methodsFor: 'instance creation' stamp: 'di 1/11/2000 12:30'! template: aSystemCategoryName "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: ''' , aSystemCategoryName , ''''! ! !Class class methodsFor: 'instance creation' stamp: 'sw 4/27/2000 16:20'! templateForSubclassOf: priorClassName category: systemCategoryName "Answer an expression that can be edited and evaluated in order to define a new class, given that the class previously looked at was as given" ^ priorClassName asString, ' subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategoryName asString , ''''! ! Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. ! !ClassBuilder methodsFor: 'initialize' stamp: 'ar 11/22/1999 10:09'! doneCompiling: aClass "The receiver has finished modifying the class hierarchy. Do any necessary cleanup." aClass doneCompiling.! ! !ClassBuilder methodsFor: 'initialize' stamp: 'ar 8/29/1999 12:32'! initialize environ _ Smalltalk. instVarMap _ IdentityDictionary new.! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 11/22/1999 03:21'! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass | environ _ oldClass environment. instVars _ Scanner new scanFieldNames: instVarString. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "Create a template for the new class (will return oldClass when there is no change)" newClass _ self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass unsafe: unsafe. newClass == nil ifTrue:[^nil]. "Some error" newClass _ self recompile: false from: oldClass to: newClass mutate: false. self doneCompiling: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/26/1999 12:54'! mutate: oldClass to: newClass "Mutate oldClass to newClass. Convert all instances of oldClass and recursively update the subclasses." | subs newSubclass oldSubclass | subs _ oldClass subclasses asArray. "Walk down" 1 to: subs size do:[:i| oldSubclass _ subs at: i. self showProgressFor: oldSubclass. "Create the new class" newSubclass _ self reshapeClass: oldSubclass to: nil super: newClass. self mutate: oldSubclass to: newSubclass. ]. oldClass obsolete. newClass isObsolete ifTrue:[newClass obsolete]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category "Define a new class in the given environment" ^self name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: false! ! !ClassBuilder methodsFor: 'class definition' stamp: 'di 12/23/1999 15:23'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass newClass organization instVars classVars force | environ _ env. instVars _ Scanner new scanFieldNames: instVarString. classVars _ (Scanner new scanFieldNames: classVarString) collect: [:x | x asSymbol]. "Validate the proposed name" unsafe ifFalse:[(self validateClassName: className) ifFalse:[^nil]]. oldClass _ env at: className ifAbsent:[nil]. oldClass isBehavior ifFalse:[oldClass _ nil]. "Already checked in #validateClassName:" unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse:[^nil]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse:[^nil]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse:[^nil]]. "Create a template for the new class (will return oldClass when there is no change)" newClass _ self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe. newClass == nil ifTrue:[^nil]. "Some error" newClass == oldClass ifFalse:[newClass setName: className]. "Install the class variables and pool dictionaries... " force _ (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." organization _ environ ifNotNil:[environ organization]. organization classify: newClass name under: category asSymbol. newClass environment: environ. "... recompile ..." newClass _ self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent:[nil]) == newClass ifFalse:[ environ at: newClass name put: newClass. Smalltalk flushClassNameCache. ]. "... and fix eventual references to obsolete globals." oldClass _ nil. "So we have no references to the old class anymore" self fixGlobalReferences. self doneCompiling: newClass. ^newClass ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:36'! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass unsafe: unsafe "Create a new subclass of the given superclass. Note: The new class may be meta." | newFormat newClass meta | "Compute the format of the new class" newFormat _ self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" (oldClass ~~ nil and:[ newSuper == oldClass superclass and:[ newFormat = oldClass format and:[ instVars = oldClass instVarNames]]]) ifTrue:[^oldClass]. unsafe ifFalse:[ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue:[ self error: oldClass name, ' cannot be changed'. ^nil]. "Check if the receiver should not be redefined" (oldClass ~~ nil and:[oldClass shouldNotBeRedefined]) ifTrue:[ self notify: oldClass name asText allBold, ' should not be redefined!! \Proceed to store over it.' withCRs]]. oldClass == nil ifTrue:["Requires new metaclass" meta _ Metaclass new. meta superclass: (newSuper ifNil:[Class] ifNotNil:[newSuper class]) methodDictionary: MethodDictionary new format: (newSuper ifNil:[Class format] ifNotNil:[newSuper class format]). meta superclass addSubclass: meta. "In case of Class" newClass _ meta new. ] ifFalse:[ newClass _ oldClass shallowCopy ]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars; organization: (oldClass ifNotNil:[oldClass organization]). ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'jm 10/4/2002 07:06'! recompile: force from: oldClass to: aClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." | newClass | newClass _ aClass. oldClass == nil ifTrue:[ "newClass has an empty method dictionary so we don't need to recompile" Smalltalk changes addClass: newClass. newClass superclass addSubclass: newClass. ^newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ "No recompilation necessary but we might have added class vars or class pools so record the change" Smalltalk changes changeClass: newClass from: oldClass. ^newClass]. currentClassIndex _ 0. maxClassIndex _ oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ Smalltalk changes changeClass: newClass from: oldClass. "Recompile from newClass without mutating" self informUserDuring:[ newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" classMap _ WeakValueDictionary new. self informUserDuring:[ self showProgressFor: oldClass. newClass _ self reshapeClass: oldClass to: newClass super: newClass superclass. Smalltalk changes changeClass: newClass from: oldClass. self mutate: oldClass to: newClass. ]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/5/1999 15:23'! reshapeClass: aClass to: templateClass super: newSuper "Reshape the given class to the new super class. If templateClass is not nil then it defines the shape of the new class" | fmt newClass newMeta newSuperMeta oldMeta instVars oldClass | templateClass == nil ifTrue:[oldClass _ aClass] ifFalse:[oldClass _ templateClass]. aClass becomeUncompact. "Compute the new format of the class" instVars _ instVarMap at: aClass name ifAbsent:[oldClass instVarNames]. fmt _ self computeFormat: oldClass typeOfClass instSize: instVars size forSuper: newSuper ccIndex: 0."Known to be 0 since we uncompacted aClass first" fmt == nil ifTrue:[^nil]. aClass isMeta ifFalse:["Create a new meta class" oldMeta _ aClass class. newMeta _ oldMeta clone. newSuperMeta _ newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Fix up meta class structure" oldMeta superclass removeSubclass: oldMeta. newMeta superclass addSubclass: newMeta. "And record the change so we can fix global refs later" self recordClass: oldMeta replacedBy: newMeta. ]. newClass _ newMeta == nil ifTrue:[oldClass clone] ifFalse:[newMeta adoptInstance: oldClass from: oldMeta]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: fmt; setInstVarNames: instVars; organization: aClass organization. "Recompile the new class" aClass hasMethods ifTrue:[newClass compileAllFrom: aClass]. "Export the new class into the environment" aClass isMeta ifFalse:[ "Derefence super sends in the old class" self fixSuperSendsFrom: aClass. "Export the class" environ at: newClass name put: newClass. "And use the ST association in the new class" self fixSuperSendsTo: newClass]. "Fix up the class hierarchy" aClass superclass removeSubclass: aClass. newClass superclass addSubclass: newClass. "Adopt all the instances of the old class" aClass autoMutateInstances ifTrue:[newClass updateInstancesFrom: aClass]. "And record the change" self recordClass: aClass replacedBy: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 11/22/1999 03:20'! silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex | srcVars _ srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars _ srcVars] ifFalse:[dstVars _ dstClass instVarNames]. dstIndex _ dstVars indexOf: prevInstVarName. dstVars _ (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ self recompile: false from: dstClass to: dstClass mutate: true. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ self recompile: false from: srcClass to: srcClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ self recompile: false from: dstClass to: dstClass mutate: true. ]. self recompile: false from: srcClass to: srcClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass.! ! !ClassBuilder methodsFor: 'class format' stamp: 'ar 9/10/1999 12:55'! computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex "Compute the new format for making oldClass a subclass of newSuper. Return the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | instSize _ newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). instSize > 254 ifTrue:[ self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #compiledMethod ifTrue:[^CompiledMethod instSpec]. type == #normal ifTrue:[isVar _ isWeak _ false. isWords _ isPointers _ true]. type == #bytes ifTrue:[isVar _ true. isWords _ isPointers _ isWeak _ false]. type == #words ifTrue:[isVar _ isWords _ true. isPointers _ isWeak _ false]. type == #variable ifTrue:[isVar _ isPointers _ isWords _ true. isWeak _ false]. type == #weak ifTrue:[isVar _ isWeak _ isWords _ isPointers _ true]. (isPointers not and:[instSize > 0]) ifTrue:[ self error:'A non-pointer class cannot have instance variables'. ^nil]. ^(self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak) + (ccIndex bitShift: 11).! ! !ClassBuilder methodsFor: 'class format' stamp: 'ar 7/11/1999 06:39'! format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak "Compute the format for the given instance specfication." | cClass instSpec sizeHiBits fmt | 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 _ isWeak ifTrue:[4] ifFalse:[isPointers ifTrue: [isVar ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. fmt _ sizeHiBits. fmt _ (fmt bitShift: 5) + cClass. fmt _ (fmt bitShift: 4) + instSpec. fmt _ (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" fmt _ (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" ^fmt! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:41'! validateClass: srcClass forMoving: iv downTo: dstClass "Make sure that we don't have any accesses to the instVar left" srcClass withAllSubclassesDo:[:cls| (cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[ cls forgetDoIts. (cls whichSelectorsAccess: iv) isEmpty ifFalse:[ self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'. Proceed to move it to Undeclared'. ]. ]. ]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'! validateClass: srcClass forMoving: iv upTo: dstClass "Make sure we don't have this instvar already" dstClass withAllSubclassesDo:[:cls| (cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[ cls isPointers ifFalse:[ self error: dstClass name, ' cannot have instance variables'. ^false]. cls instSize >= 254 ifTrue:[ self error: cls name, ' has more than 254 instance variables'. ^false]. (cls instVarNames includes: iv) ifTrue:[ self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,' Proceed to move it up to ', dstClass name asText allBold,' as well'. instVarMap at: cls name put: (cls instVarNames copyWithout: iv)]. ]. ]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/13/1999 05:26'! validateClassName: aString "Validate the new class name" aString first isUppercase ifFalse:[ self error: 'Class names must be capitalized'. ^false]. environ at: aString ifPresent:[:old| (old isKindOf: Behavior) ifFalse:[ self notify: aString asText allBold, ' already exists!!\Proceed will store over it.' withCRs]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:48'! validateClassvars: classVarArray from: oldClass forSuper: newSuper "Check if any of the classVars of oldClass conflict with the new superclass" | usedNames classVars temp | classVarArray isEmpty ifTrue:[^true]. "Okay" "Validate the class var names" usedNames _ classVarArray asSet. usedNames size = classVarArray size ifFalse:[ classVarArray do:[:var| usedNames remove: var ifAbsent:[temp _ var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp _ var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames _ newSuper allClassVarNames asSet. classVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl classVarNames includes: iv) ifTrue:[temp _ cl]]. self error: iv, ' is already defined in ', temp name. ^false]]]. oldClass == nil ifFalse:[ usedNames _ Set new: 20. oldClass allSubclassesDo:[:cl| usedNames addAll: cl classVarNames]. classVars _ classVarArray. newSuper == nil ifFalse:[classVars _ classVars, newSuper allClassVarNames asArray]. classVars do:[:iv| (usedNames includes: iv) ifTrue:[ self error: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:49'! validateInstvars: instVarArray from: oldClass forSuper: newSuper "Check if any of the instVars of oldClass conflict with the new superclass" | instVars usedNames temp | instVarArray isEmpty ifTrue:[^true]. "Okay" "Validate the inst var names" usedNames _ instVarArray asSet. usedNames size = instVarArray size ifFalse:[ instVarArray do:[:var| usedNames remove: var ifAbsent:[temp _ var]]. self error: temp,' is multiply defined'. ^false]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp _ var]]. self error: temp,' is a reserved name'. ^false]. newSuper == nil ifFalse:[ usedNames _ newSuper allInstVarNames asSet. instVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl instVarNames includes: iv) ifTrue:[temp _ cl]]. self error: iv,' is already defined in ', temp name. ^false]]]. oldClass == nil ifFalse:[ usedNames _ Set new: 20. oldClass allSubclassesDo:[:cl| usedNames addAll: cl instVarNames]. instVars _ instVarArray. newSuper == nil ifFalse:[instVars _ instVars, newSuper allInstVarNames]. instVars do:[:iv| (usedNames includes: iv) ifTrue:[ self error: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'di 11/24/1999 13:09'! validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize "Validate the # of instVars and the format of the subclasses" | deltaSize oldType | oldClass == nil ifTrue: [^ true]. "No subclasses" "Compute the # of instvars needed for all subclasses" deltaSize _ newInstSize. (oldClass notNil) ifTrue: [deltaSize _ deltaSize - oldClass instVarNames size]. (newSuper notNil) ifTrue: [deltaSize _ deltaSize + newSuper instSize]. (oldClass notNil and: [oldClass superclass notNil]) ifTrue: [deltaSize _ deltaSize - oldClass superclass instSize]. oldClass == nil ifTrue: [ deltaSize > 254 ifTrue: [ self error: 'More than 254 instance variables'. ^ false]. ^ true]. oldClass withAllSubclassesDo: [:sub | sub instSize + deltaSize > 254 ifTrue: [ self error: sub name,' has more than 254 instance variables'. ^ false]]. newType ~~ #normal ifTrue: ["And check if the immediate subclasses of oldClass can keep its layout" oldClass subclassesDo:[:sub| oldType _ sub typeOfClass. oldType == newType ifFalse: [ self error: sub name,' cannot be recompiled'. ^ false]]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'! validateSuperclass: aSuperClass forSubclass: aClass "Check if it is okay to use aSuperClass as the superclass of aClass" aClass == nil ifTrue:["New class" (aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]]) ifFalse:[self error: aSuperClass name,' is not a valid superclass'. ^false]. ^true]. aSuperClass == aClass superclass ifTrue:[^true]. "No change" (aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy" ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name]. "Check for circular references" (aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]]) ifTrue:[self error: aSuperClass name,' inherits from ', aClass name. ^false]. ^true! ! !ClassBuilder methodsFor: 'private' stamp: 'di 12/6/1999 12:31'! fixGlobalReferences "Fix all the references to globals which are now outdated. Care must be taken that we do not accidentally 'fix' dangerous stuff." | oldClasses newClasses condition | classMap == nil ifTrue:[^self]. (self retryWithGC: [condition _ classMap anySatisfy: [:any| any notNil and:[any isObsolete]]. any_nil. condition] until:[:obsRef| obsRef = false]) ifFalse:[^self]. "GC cleaned up the remaining refs" "Collect the old and the new refs" oldClasses _ OrderedCollection new. newClasses _ OrderedCollection new. classMap keysAndValuesDo:[:new :old| old == nil ifFalse:[ newClasses add: new. oldClasses add: old]]. oldClasses isEmpty ifTrue:[^self]. "GC cleaned up the rest" "Now fix all the known dangerous pointers to old classes by creating copies of those still needed. Dangerous pointers should come only from obsolete subclasses (where the superclass must be preserved)." self fixObsoleteReferencesTo: oldClasses. "After this has been done fix the remaining references" progress == nil ifFalse:[progress value: 'Fixing references to globals']. "Forward all old refs to the new ones" (oldClasses asArray) elementsForwardIdentityTo: (newClasses asArray). "Done"! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 7/20/1999 10:45'! fixObsoleteMethodsFrom: oldClasses map: obsoleteClasses "Fix the methods of the obsolete classes" | nLits tempMethod | oldClasses do:[:class| obsoleteClasses at: class ifPresent:[:tempClass| class selectorsAndMethodsDo:[:sel :meth| "Create a clean copy for the temps" tempMethod _ meth copy. "Fix the super sends" tempMethod sendsToSuper ifTrue:[ nLits _ tempMethod numLiterals. "Hack the method class in the temp class" tempMethod literalAt: nLits put: (Association new value: (obsoleteClasses at: class ifAbsent:[class])). ]. "Install in tempClass" tempClass addSelector: sel withMethod: tempMethod. ]. ]. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'jm 5/16/2003 10:04'! fixObsoleteReferencesTo: oldClasses "Fix all obsolete references to the given set of outdated classes." | obsoleteClasses obj | progress ifNotNil: [progress value: 'Fixing obsolete class references...']. "Prepare a map of obsolete classes" obsoleteClasses _ self mapObsoleteClassesToTemps: oldClasses. "Sanity check for debugging" "oldClasses size = obsoleteClasses size ifFalse:[self error:'Obsolete classes size mismatch']." "Fix the methods" self fixObsoleteMethodsFrom: oldClasses map: obsoleteClasses. "Now search and fix all dangerous objects" obj _ 0 someObject. [0 == obj] whileFalse: [ (obj isBehavior and:[obsoleteClasses includesKey: obj superclass]) ifTrue: [ (obsoleteClasses includesKey: obj) ifFalse: [ obj superclass: (obsoleteClasses at: obj superclass)]]. obj _ obj nextObject]. ! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:03'! fixSuperSendsFrom: oldClass "The oldClass is about to be removed from the environment. Fix all references to super so that the association is different from the original ST association." | newSuper nLits lastLiteral | newSuper _ Association key: nil value: oldClass. oldClass methodsDo:[:meth| nLits _ meth numLiterals. nLits > 0 ifTrue:[lastLiteral _ meth literalAt: nLits] ifFalse:[lastLiteral _ nil]. (lastLiteral class == Association and:[meth sendsToSuper]) ifTrue:[ meth literalAt: nLits put: newSuper. ]. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:04'! fixSuperSendsTo: newClass "The newClass has been exported into the environment. Fix all references to super so that the association is the original ST association." | newSuper nLits lastLiteral | newSuper _ Smalltalk associationAt: newClass name ifAbsent:[nil]. newSuper == nil ifTrue:[^self]. newSuper value == newClass ifTrue:[^self]. newClass methodsDo:[:meth| nLits _ meth numLiterals. nLits > 0 ifTrue:[lastLiteral _ meth literalAt: nLits] ifFalse:[lastLiteral _ nil]. (lastLiteral class == Association and:[meth sendsToSuper]) ifTrue:[ meth literalAt: nLits put: newSuper. ]. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 13:03'! informUserDuring: aBlock self class isSilent ifTrue:[^aBlock value]. Utilities informUserDuring:[:bar| progress _ bar. aBlock value]. progress _ nil.! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 12:29'! mapObsoleteClassesToTemps: oldClasses "Map the old classes to temporary classes. These temporary classes will survive the #become: operation and be used as the class of any instances or subclasses of the obsolete classes." | oldMeta tempMeta obsoleteClasses | obsoleteClasses _ IdentityDictionary new: oldClasses size. oldClasses do:[:oldClass| "Note: If a class is getting obsolete here so is its metaclass" oldMeta _ oldClass isMeta ifTrue:[oldClass] ifFalse:[oldClass class]. tempMeta _ obsoleteClasses at: oldMeta ifAbsentPut:[oldMeta clone]. oldClass isMeta ifFalse:[ tempMeta adoptInstance: oldClass from: oldMeta. obsoleteClasses at: oldClass put: tempMeta soleInstance. "Note: If we haven't mutated the instances of the old class to the new layout we must do it here." oldClass autoMutateInstances ifFalse:[ tempMeta soleInstance updateInstancesFrom: oldClass]]]. "Fix the superclasses of the clones" obsoleteClasses keysAndValuesDo:[:old :temp| temp superclass: (obsoleteClasses at: temp superclass "Might be a subclass of a live class" ifAbsent:[temp superclass])]. "And install new method dictionaries" obsoleteClasses valuesDo:[:temp| temp methodDictionary: temp methodDictionary copy. ]. ^obsoleteClasses! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 7/20/1999 00:00'! recordClass: oldClass replacedBy: newClass "Record the replacement of oldClass by newClass so that we can fix any references to oldClass later on." classMap at: newClass put: oldClass. (classMap includesKey: oldClass) ifTrue:[ "This will happen if we recompile from Class in which case the metaclass gets recorded twice" classMap at: newClass put: (classMap at: oldClass). classMap removeKey: oldClass. ]. "And keep the changes up to date" (instVarMap includesKey: oldClass name) ifTrue:[ Smalltalk changes changeClass: newClass from: oldClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 7/15/1999 13:39'! reservedNames "Return a list of names that must not be used for variables" ^#('self' 'super' 'thisContext' 'true' 'false' 'nil' self super thisContext true false nil).! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 7/15/1999 14:01'! showProgressFor: aClass "Announce that we're processing aClass" progress == nil ifTrue:[^self]. currentClassIndex _ currentClassIndex + 1. aClass hasMethods ifTrue:[ progress value: ('Recompiling ', aClass name,' (', currentClassIndex printString,'/', maxClassIndex printString,')')].! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 8/29/1999 15:43'! tooDangerousClasses "Return a list of class names which will not be modified in the public interface" ^#( "Object will break immediately" Object "Contexts and their superclasses" InstructionStream ContextPart BlockContext MethodContext "Superclasses of basic collections" Collection SequenceableCollection ArrayedCollection "Collections known to the VM" Array Bitmap String Symbol ByteArray CompiledMethod TranslatedMethod "Basic Numbers" Magnitude Number SmallInteger Float "Misc other" LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject ) ! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'! class: oldClass instanceVariableNames: instVarString "This is the basic initialization message to change the definition of an existing Metaclass" oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass']. ^self class: oldClass instanceVariableNames: instVarString unsafe: false! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'! moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the given instVar from srcClass to dstClass" (srcClass instVarNames includes: instVarName) ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. (srcClass inheritsFrom: dstClass) ifTrue:[ "Move the instvar up the hierarchy." (self validateClass: srcClass forMoving: instVarName upTo: dstClass) ifFalse:[^false]. ]. (dstClass inheritsFrom: srcClass) ifTrue:[ "Move the instvar down the hierarchy" (self validateClass: srcClass forMoving: instVarName downTo: dstClass) ifFalse:[^false]. ]. ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! superclass: newSuper 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." ^self name: t inEnvironment: newSuper environment subclassOf: newSuper type: newSuper typeOfClass instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! superclass: aClass 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 in which the subclass is to have indexable byte-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields']. (aClass isVariable and: [aClass isWords]) ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a byte subclass of a class with pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #bytes instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! superclass: aClass 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 in which the subclass is to have indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #variable instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! superclass: aClass 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 in which the subclass is to have indexable word-sized nonpointer variables." (aClass instSize > 0) ifTrue: [^self error: 'cannot make a word subclass of a class with named fields']. (aClass isVariable and: [aClass isBytes]) ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields']. (aClass isVariable and: [aClass isPointers]) ifTrue: [^self error: 'cannot make a word subclass of a class with pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #words instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! superclass: aClass weakSubclass: 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 weak indexable pointer variables." aClass isBits ifTrue: [^self error: 'cannot make a pointer subclass of a class with non-pointer fields']. ^self name: t inEnvironment: aClass environment subclassOf: aClass type: #weak instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !ClassBuilder class methodsFor: 'testing' stamp: 'ar 7/15/1999 14:04'! autoMutateInstances "Don't mutate me while I'm compiling myself" ^false! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'! beSilent: aBool "ClassDefiner beSilent: true" "ClassDefiner beSilent: false" QuietMode _ aBool.! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'! beSilentDuring: aBlock "Temporarily suppress information about what is going on" | wasSilent result | wasSilent _ self isSilent. self beSilent: true. result _ aBlock value. self beSilent: wasSilent. ^result! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'! isSilent ^QuietMode == true! ! I represent a mechanism for retrieving class descriptions stored on a file.! !ClassCategoryReader methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 23:24'! scanFromNoCompile: aStream "Just move the source code for the methods from aStream." | methodText selector | [methodText _ aStream nextChunkText. methodText size > 0] whileTrue: [(SourceFiles at: 2) ifNotNil: [ selector _ class parserClass new parseSelector: methodText. (class compiledMethodAt: selector) putSource: methodText fromParseNode: nil class: class category: category withStamp: changeStamp inFile: 2 priorMethod: nil]]! ! A ClassChangeRecorder keeps track of most substantive changes premissible in a project, isolated or not. Structure: inForce a boolean Tells whether these changes are in effect. true for all changeSets in and above the current project. It should be sufficient only to record this for the changeSet as a whole, but this redundancy could help in error recovery. classIsLocal a boolean True if and only if this class is defined in this layer of the project structure. changeTypes an identitySet Summarizes which changes have been made in this class. Values include #comment, #reorganize, #rename, and the four more summarized below. thisName a string Retains the class name for this layer. priorName a string Preserves the prior name. thisComment a text Retains the class comment for this layer. priorComment a text Preserves the prior comment. thisOrganization a classOrganizer Retains the class organization for this layer. priorOrganization a classOrganizer Preserves the prior organization. thisMD a methodDictionary Used to prepare changes for nearly atomic invocation of this layer (see below). priorMD a methodDictionary Preserves the state of an altered class as it exists in the next outer layer of the project structure. methodChanges a dictionary of classChangeRecords Retains all the method changes for this layer. Four of the possible changeTypes are maintained in a mutually exclusive set, analogously to MethodChangeRecords. Here is a simple summary of the relationship between these four changeType symbols and the recording of prior state | prior == nil | prior not nil --------- |---------------------------- |-------------------- add | add | change --------- |---------------------------- |-------------------- remove | addedThenRemoved | remove A classChangeRecorder is notified of changes by the method noteMethodChange: . ClassChangeRecorders are designed to invoke a set of changes relative to the definition of a class in an prior layer. It is important that both invocation and revocation of these changes take place in a nearly atomic fashion so that interdependent changes will be adopted as a whole, and so that only one flush of the method cache should be necessary. A further reason for revocation to be simple is that it may be requested as an attempt to recover from an error in a project that is failing.! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:39'! allChangeTypes | chgs | (priorName ~~ nil and: [changeTypes includes: #rename]) ifTrue: [(chgs _ changeTypes copy) add: 'oldName: ' , priorName. ^ chgs]. ^ changeTypes! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 4/2/2000 21:59'! assimilateAllChangesIn: otherRecord | selector changeRecord changeType | otherRecord isClassRemoval ifTrue: [^ self noteChangeType: #remove]. otherRecord allChangeTypes do: [:chg | self noteChangeType: chg fromClass: self realClass]. otherRecord methodChanges associationsDo: [:assn | selector _ assn key. changeRecord _ assn value. changeType _ changeRecord changeType. (changeType == #remove or: [changeType == #addedThenRemoved]) ifTrue: [changeType == #addedThenRemoved ifTrue: [self atSelector: selector put: #add]. self noteRemoveSelector: selector priorMethod: nil lastMethodInfo: changeRecord methodInfoFromRemoval] ifFalse: [self atSelector: selector put: changeType]]. ! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 10:59'! hasNoChanges ^ changeTypes isEmpty and: [methodChanges isEmpty]! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/24/2000 09:36'! includesChangeType: changeType changeType == #new ifTrue: [^ changeTypes includes: #add]. "Backwd compat" ^ changeTypes includes: changeType! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'di 3/28/2000 15:14'! noteChangeType: changeSymbol ^ self noteChangeType: changeSymbol fromClass: nil! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'jm 5/29/2003 19:49'! noteChangeType: changeSymbol fromClass: class (changeSymbol = #new or: [changeSymbol = #add]) ifTrue: [changeTypes add: #add. changeTypes remove: #change ifAbsent: []. ^ self]. changeSymbol = #change ifTrue: [(changeTypes includes: #add) ifTrue: [^ self]. ^ changeTypes add: changeSymbol]. changeSymbol = #comment ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #reorganize ifTrue: [^ changeTypes add: changeSymbol]. changeSymbol = #rename ifTrue: [^ changeTypes add: changeSymbol]. (changeSymbol beginsWith: 'oldName: ') ifTrue: ["Must only be used when assimilating other changeSets" (changeTypes includes: #add) ifTrue: [^ self]. priorName _ changeSymbol copyFrom: 'oldName: ' size + 1 to: changeSymbol size. ^ changeTypes add: #rename]. changeSymbol = #remove ifTrue: [(changeTypes includes: #add) ifTrue: [changeTypes add: #addedThenRemoved] ifFalse: [changeTypes add: #remove]. ^ changeTypes removeAll: #(add change comment reorganize)]. self error: 'Unrecognized changeType'! ! !ClassChangeRecord methodsFor: 'all changes' stamp: 'jm 5/29/2003 19:49'! trimHistory "Drop non-essential history." "Forget methods added and later removed" methodChanges keysAndValuesRemove: [:sel :chgRecord | chgRecord changeType == #addedThenRemoved]. "Forget renaming and reorganization of newly-added classes." (changeTypes includes: #add) ifTrue: [changeTypes removeAll: #(rename reorganize)]. ! ! !ClassChangeRecord methodsFor: 'isolation layers' stamp: 'di 3/30/2000 18:03'! realClass "Return the actual class (or meta), as determined from my name." thisName ifNil: [^ nil]. (thisName endsWith: ' class') ifTrue: [^ (Smalltalk at: (thisName copyFrom: 1 to: thisName size - 6) asSymbol ifAbsent: [^ nil]) class] ifFalse: [^ Smalltalk at: thisName ifAbsent: [^ nil]]! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:06'! checkCoherence "If I recreate the class then don't remove it" (changeTypes includes: #remove) ifTrue: [changeTypes remove: #remove. changeTypes add: #change]. (changeTypes includes: #addedThenRemoved) ifTrue: [changeTypes remove: #addedThenRemoved. changeTypes add: #add]. ! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/27/2000 22:08'! notePriorDefinition: oldClass oldClass ifNil: [^ self]. priorDefinition ifNil: [priorDefinition _ oldClass definition]! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'! priorDefinition ^ priorDefinition! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'! noteNewName: newName thisName _ newName! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'! priorName ^ priorName! ! !ClassChangeRecord methodsFor: 'removal' stamp: 'jm 5/29/2003 19:49'! forgetChangesIn: otherRecord "See forgetAllChangesFoundIn:. Used in culling changeSets." | cls otherMethodChanges selector actionToSubtract | (cls _ self realClass) == nil ifTrue: [^ self]. "We can do better now, though..." otherMethodChanges _ otherRecord methodChangeTypes. otherMethodChanges associationsDo: [:assoc | selector _ assoc key. actionToSubtract _ assoc value. (cls includesSelector: selector) ifTrue: [(#(add change) includes: actionToSubtract) ifTrue: [methodChanges removeKey: selector ifAbsent: []]] ifFalse: [(#(remove addedThenRemoved) includes: actionToSubtract) ifTrue: [methodChanges removeKey: selector ifAbsent: []]]]. changeTypes isEmpty ifFalse: [changeTypes removeAll: otherRecord allChangeTypes. (changeTypes includes: #rename) ifFalse: [changeTypes removeAllSuchThat: [:x | x beginsWith: 'oldName: ']]]! ! !ClassChangeRecord methodsFor: 'removal' stamp: 'di 4/1/2000 23:05'! isClassRemoval "NOTE: there are other removals with changeType #addedThenRemoved, but this message is used to write out removals in fileOut, and those cases should not be written out." ^ (changeTypes includes: #remove) or: [changeTypes includes: #removeClass]! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:38'! atSelector: selector ifAbsent: absentBlock ^ (methodChanges at: selector ifAbsent: absentBlock) changeType! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'! atSelector: selector put: changeType (self findOrMakeMethodChangeAt: selector priorMethod: nil) noteChangeType: changeType! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 10:07'! changedSelectors "Return a set of the changed or removed selectors." ^ methodChanges keys! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 11:01'! findOrMakeMethodChangeAt: selector priorMethod: priorMethod ^ methodChanges at: selector ifAbsent: [methodChanges at: selector put: (MethodChangeRecord new priorMethod: priorMethod)]! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/29/2000 16:26'! infoFromRemoval: selector ^ (methodChanges at: selector ifAbsent: [^ nil]) methodInfoFromRemoval ! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/24/2000 09:46'! methodChangeTypes "Return an old-style dictionary of method change types." | dict selector record | dict _ IdentityDictionary new. methodChanges associationsDo: [:assn | selector _ assn key. record _ assn value. dict at: selector put: record changeType]. ^ dict! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 4/1/2000 23:49'! methodChanges ^ methodChanges! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/28/2000 23:28'! noteNewMethod: newMethod selector: selector priorMethod: methodOrNil | methodChange | methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil. methodOrNil == nil ifTrue: [methodChange noteChangeType: #add] ifFalse: [methodChange noteChangeType: #change]. methodChange noteNewMethod: newMethod. ! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 23:00'! noteRemoveSelector: selector priorMethod: priorMethod lastMethodInfo: infoOrNil | methodChange | methodChange _ self findOrMakeMethodChangeAt: selector priorMethod: priorMethod. methodChange changeType == #add ifTrue: [methodChange noteChangeType: #addedThenRemoved] ifFalse: [methodChange noteChangeType: #remove]. infoOrNil ifNotNil: ["Save the source code pointer and category so can still browse old versions" methodChange noteMethodInfoFromRemoval: infoOrNil] ! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/23/2000 11:58'! removeSelector: selector "Remove all memory of changes associated with the argument, selector, in this class." methodChanges removeKey: selector ifAbsent: []! ! !ClassChangeRecord methodsFor: 'initialization' stamp: 'jm 5/16/2003 08:59'! initForClassNamed: className changeTypes _ IdentitySet new. methodChanges _ IdentityDictionary new. priorName _ thisName _ className. ! ! !ClassCommentReader methodsFor: 'as yet unclassified' stamp: 'tk 1/27/2000 22:56'! scanFromNoCompile: 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." self scanFrom: aStream. "for comments, the same as usual"! ! I add a number of facilities to basic Behaviors: 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. The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 11/22/1999 10:09'! doneCompiling "A ClassBuilder has finished the compilation of the receiver. This message is a notification for a class that needs to do some cleanup / reinitialization after it has been recompiled."! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 7/14/1999 04:41'! obsolete "Make the receiver obsolete." superclass removeSubclass: self. organization _ nil. super obsolete.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'di 7/21/1999 11:05'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. organization _ nil. instanceVariables _ nil.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'tk 10/4/1999 09:43'! updateInstances: oldInstances from: oldClass isMeta: isMeta "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary." "If there are any contexts having an old instance as receiver it might crash the system because the layout has changed, and the method only knows about the old layout." | map variable instSize newInstances | oldInstances isEmpty ifTrue:[^self]. "no instances to convert" isMeta ifTrue: [ oldInstances size = 1 ifFalse:[^self error:'Metaclasses can only have one instance']. self soleInstance class == self ifTrue:[ ^self error:'Metaclasses can only have one instance']]. map _ self instVarMappingFrom: oldClass. variable _ self isVariable. instSize _ self instSize. newInstances _ Array new: oldInstances size. 1 to: oldInstances size do:[:i| newInstances at: i put: ( self newInstanceFrom: (oldInstances at: i) variable: variable size: instSize map: map)]. "Now perform a bulk mutation of old instances into new ones" oldInstances elementsExchangeIdentityWith: newInstances.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'jm 10/14/2002 18:36'! 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." "ar 7/15/1999: The updating below is possibly dangerous. If there are any contexts having an old instance as receiver it might crash the system if the new receiver in which the context is executed has a different layout. See bottom below for a simple example:" | oldInstances | oldInstances _ oldClass allInstances asArray. self updateInstances: oldInstances from: oldClass isMeta: false. " | crashingBlock class | class _ Object subclass: #CrashTestDummy instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. class compile:'instVar: value instVar _ value'. class compile:'crashingBlock ^[instVar]'. crashingBlock _ (class new) instVar: 42; crashingBlock. Object subclass: #CrashTestDummy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Crash-Test'. crashingBlock. crashingBlock value. " ! ! !ClassDescription methodsFor: 'accessing' stamp: 'di 2/9/2000 17:54'! comment "Answer the receiver's comment. (If missing, supply a template) " | aString | aString _ self theNonMetaClass organization classComment. aString isEmpty ifFalse: [^ aString]. ^ 'Main comment stating the purpose of this class and relevant relationship to other classes. Possible useful expressions for doIt or printIt. Structure: instVar1 type -- comment about the purpose of instVar1 instVar2 type -- comment about the purpose of instVar2 Any further useful comments about the general approach of this implementation.'! ! !ClassDescription methodsFor: 'accessing' stamp: 'sw 9/8/1998 14:43'! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self theNonMetaClass classComment: aStringOrText stamp: aStamp. Smalltalk changes commentClass: self theNonMetaClass! ! !ClassDescription methodsFor: 'copying' stamp: 'di 2/17/2000 22:35'! 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]. (self 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' stamp: 'sw 6/16/1998 15:01'! copyMethodDictionaryFrom: donorClass "Copy the method dictionary of the donor class over to the receiver" methodDict _ donorClass copyOfMethodDictionary. organization _ donorClass organization deepCopy! ! !ClassDescription methodsFor: 'printing' stamp: 'di 12/19/1999 14:37'! 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: (self environment keyAtIdentityValue: x ifAbsent: ['private']); space]. ^ aStream contents! ! !ClassDescription methodsFor: 'instance variables' stamp: 'RAA 8/9/1999 19:32'! 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 contents isEmpty ifTrue: [^1 beep]. "handle nil superclass better" 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' stamp: 'di 11/9/1998 20:21'! checkForInstVarsOK: instVarString "Return true if instVarString does no include any names used in a subclass" | instVarArray | instVarArray _ Scanner new scanFieldNames: instVarString. self allSubclasses do: [:cl | cl instVarNames do: [:n | (instVarArray includes: n) ifTrue: [self error: n , ' is already used in ' , cl name. ^ false]]]. ^ true! ! !ClassDescription methodsFor: 'instance variables' stamp: 'jm 5/29/2003 19:04'! chooseInstVarAlphabeticallyThenDo: aBlock "Put up a menu of all the instance variables in the receiver, presented in alphabetical order, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter." | allVars index | allVars _ self allInstVarNames copy asArray sort. allVars isEmpty ifTrue: [^ self inform: 'There are no instance variables']. index _ (PopUpMenu labelArray: allVars lines: #()) startUpWithCaption: 'Instance variables in ', self name. index = 0 ifTrue: [^ self]. aBlock value: (allVars at: index) ! ! !ClassDescription methodsFor: 'instance variables' stamp: 'ls 12/5/1999 13:40'! chooseInstVarThenDo: aBlock "Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter. If the list is 6 or larger, then offer an alphabetical formulation as an alternative. triggered by a 'show alphabetically' item at the top of the list." | lines labelStream vars allVars index count offerAlpha | (count _ self allInstVarNames size) = 0 ifTrue: [^ self inform: 'There are no instance variables.']. allVars _ OrderedCollection new. lines _ OrderedCollection new. labelStream _ WriteStream on: (String new: 200). (offerAlpha _ count > 5) ifTrue: [lines add: 1. allVars add: 'show alphabetically'. labelStream nextPutAll: allVars first; cr]. self withAllSuperclasses reverseDo: [:class | vars _ class instVarNames. vars do: [:var | labelStream nextPutAll: var; cr. allVars add: var]. vars isEmpty ifFalse: [lines add: allVars size]]. labelStream skip: -1 "cut last CR". (lines size > 0 and: [lines last = allVars size]) ifTrue: [lines removeLast]. "dispense with inelegant line beneath last item" index _ (PopUpMenu labels: labelStream contents lines: lines) startUpWithCaption: 'Instance variables in ', self name. index = 0 ifTrue: [^ self]. (index = 1 and: [offerAlpha]) ifTrue: [^ self chooseInstVarAlphabeticallyThenDo: aBlock]. aBlock value: (allVars at: index)! ! !ClassDescription methodsFor: 'instance variables' stamp: 'sw 5/27/1999 16:46'! classThatDefinesInstanceVariable: instVarName (instanceVariables notNil and: [instanceVariables includes: instVarName asString]) ifTrue: [^ self]. ^ superclass ifNotNil: [superclass classThatDefinesInstanceVariable: instVarName]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'di 9/14/1998 08:40'! renameInstVar: oldName to: newName (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" ^ self renameSilentlyInstVar: oldName to: newName! ! !ClassDescription methodsFor: 'instance variables' stamp: 'jm 5/29/2003 19:49'! renameSilentlyInstVar: old to: new | i oldCode newCode parser header body sels oldName newName | oldName _ old asString. newName _ new asString. (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]]. instanceVariables replaceFrom: i to: i with: (Array with: newName). self withAllSubclasses do: [:cls | sels _ cls selectors. sels removeAll: #(DoIt DoItIn:). sels do: [:sel | oldCode _ cls sourceCodeAt: sel. "Don't make changes in the method header" (parser _ cls parserClass new) parseSelector: oldCode. header _ oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). body _ header size > oldCode size ifTrue: [''] ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. newCode _ header , (body copyReplaceTokens: oldName with: newName). newCode ~= oldCode ifTrue: [cls compile: newCode classified: (cls organization categoryOfElement: sel) notifying: nil]]. cls isMeta ifFalse: [oldCode _ cls comment. newCode _ oldCode copyReplaceTokens: oldName with: newName. newCode ~= oldCode ifTrue: [cls comment: newCode]]]! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'di 3/27/1999 23:53'! recoverFromMDFault (organization isMemberOf: Array) ifFalse: [^ self error: 'oops']. methodDict _ organization first. organization _ organization second.! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'di 3/23/2000 23:08'! removeSelector: selector | priorMethod | "Remove the message whose selector is given from the method dictionary of the receiver, if it is there. Answer nil otherwise." (self methodDict includesKey: selector) ifFalse: [^ nil]. priorMethod _ self compiledMethodAt: selector. Smalltalk changes removeSelector: selector class: self priorMethod: priorMethod lastMethodInfo: {priorMethod sourcePointer. (self whichCategoryIncludesSelector: selector)}. super removeSelector: selector. self organization removeElement: selector. self acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: self name , ' removeSelector: #' , selector]! ! !ClassDescription methodsFor: 'method dictionary' stamp: 'di 2/17/2000 22:34'! removeSelectorUnlogged: aSymbol "Remove the message whose selector is aSymbol from the method dictionary of the receiver, if it is there. Answer nil otherwise. Do not log the action either to the current change set or to the changes log" (self methodDict includesKey: aSymbol) ifFalse: [^ nil]. super removeSelector: aSymbol. self organization removeElement: aSymbol! ! !ClassDescription methodsFor: 'organization' stamp: 'di 2/17/2000 22:36'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [organization _ ClassOrganizer defaultList: self methodDict keys asSortedCollection asArray]. (organization isMemberOf: Array) ifTrue: [self recoverFromMDFault]. ^ organization! ! !ClassDescription methodsFor: 'organization' stamp: 'tk 6/21/1999 12:59'! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." organization _ aClassOrg! ! !ClassDescription methodsFor: 'organization' stamp: 'di 9/10/1999 10:21'! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict _ MethodDictionary new. self isMeta ifFalse: [self class zapAllMethods]! ! !ClassDescription methodsFor: 'compiling' stamp: 'di 2/17/2000 22:34'! 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 _ self methodDict at: selector ifAbsent: [nil]. methodNode _ node]. self acceptsLoggingOfCompilation ifTrue: [newText _ ((requestor == nil or: [requestor isKindOf: SyntaxError]) not 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' stamp: 'jm 5/31/2003 15:50'! 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 newMethod priorMethodOrNil | methodNode _ self compilerClass new compile: code in: self notifying: requestor ifFail: failBlock. selector _ methodNode selector. selAndNodeBlock value: selector value: methodNode. methodNode encoder requestor: requestor. "Why was this not preserved?" newMethod _ methodNode generate: bytes. priorMethodOrNil _ (methodDict includesKey: selector) ifTrue: [self compiledMethodAt: selector] ifFalse: [nil]. Smalltalk changes noteNewMethod: newMethod forClass: self selector: selector priorMethod: priorMethodOrNil. self addSelector: selector withMethod: newMethod. ^ newMethod! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 7/1/1999 23:07'! compileProgrammatically: code classified: cat | oldInitials | oldInitials _ Utilities authorInitialsPerSe. Utilities setAuthorInitials: 'programmatic'. self compile: code classified: cat. Utilities setAuthorInitials: oldInitials. ! ! !ClassDescription methodsFor: 'compiling' stamp: 'sw 8/11/1998 14:40'! compileUnlogged: text classified: category notifying: requestor | selector | self compile: text asString notifying: requestor trailer: #(0 0 0 0) ifFail: [^ nil] elseSetSelectorAndNode: [:sel :node | selector _ sel]. self organization classify: selector under: category. ^ selector! ! !ClassDescription methodsFor: 'compiling' stamp: 'ar 7/20/1999 11:04'! moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName "Move the given instance variable to another class." self == anotherClass ifFalse:[ self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly. Proceed to do it anyways.']. ^(ClassBuilder new) moveInstVarNamed: instVarName from: self to: anotherClass after: prevInstVarName! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/8/1998 14:44'! 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." ^ self classComment: aString stamp: ''! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 3/28/2000 14:34'! classComment: aString stamp: aStamp "Store the comment, aString or Text or RemoteString, associated with the class we are organizing. Empty string gets stored only if had a non-empty one before." | ptr header file oldCommentRemoteStr | (aString isKindOf: RemoteString) ifTrue: [^ self organization classComment: aString]. oldCommentRemoteStr _ self 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: '. aStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: ptr printString]. file nextChunkPut: header]]. Smalltalk changes commentClass: self. aStamp size > 0 ifTrue: [self commentStamp: aStamp]. organization classComment: (RemoteString newString: aString onFileNumber: 2). ! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 9/2/1998 14:22'! commentStamp: changeStamp self organization commentStamp: changeStamp. ^ self commentStamp: changeStamp prior: 0! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 12/19/1999 21:24'! definition "Answer a String that defines the receiver." | aStream path | aStream _ WriteStream on: (String new: 300). superclass == nil ifTrue: [aStream nextPutAll: 'nil'] ifFalse: [path _ ''. self environment scopeFor: superclass name from: nil envtAndPathIfFound: [:envt :remotePath | path _ remotePath]. aStream nextPutAll: path , superclass name]. aStream nextPutAll: 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 10/15/1999 14:45'! fileOutCategory: aSymbol 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." | selectors | aFileStream cr. selectors := (aSymbol asString = ClassOrganizer allCategory) ifTrue: [ self organization allMethodSelectors ] ifFalse: [ self organization listAtCategoryNamed: aSymbol ]. "Overridden to preserve author stamps in sources file regardless" selectors do: [:sel | self printMethodChunk: sel withPreamble: true on: aFileStream moveSource: moveSource toFile: fileIndex]. ^ self! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'ar 3/21/98 02:36'! kindOfSubclass "Answer a string that describes what kind of subclass the receiver is, i.e., weak, variable, variable byte, variable word, or not variable." self isWeak ifTrue:[^' weakSubclass: ']. self isVariable ifTrue: [self isBits ifTrue: [self isBytes ifTrue: [^' variableByteSubclass: '] ifFalse: [^' variableWordSubclass: ']] ifFalse: [^' variableSubclass: ']] ifFalse: [^' subclass: ']! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 11/13/1998 15:25'! methods "Answer a ClassCategoryReader for compiling messages that are not classified, as in fileouts made with Smalltalk/V" ^ ClassCategoryReader new setClass: self category: ClassOrganizer default! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 8/15/1998 22:02'! methodsFor: categoryName stamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol changeStamp: changeStamp "Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ]style[(65 333 22 17)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:42'! 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 _ self methodDict keys select: [:sel | (self methodDict at: sel) fileIndex > 1]. self fileOutChangedMessages: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'di 4/4/1999 11:43'! 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 ~~ nil and: [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: 'RAA 5/5/2000 09:08'! 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 endPos | doPreamble ifTrue: [preamble _ self name , ' methodsFor: ' , (self organization categoryOfElement: selector) asString printString] ifFalse: [preamble _ '']. method _ self 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" [endPos _ outStream position. method checkOKToAdd: endPos - newPos at: newPos. method setSourcePosition: newPos inFile: fileIndex]]. preamble size > 0 ifTrue: [outStream nextChunkPut: ' ']. ^ outStream cr! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'sw 11/6/1999 23:08'! reformatMethodAt: selector | newCodeString method | newCodeString _ (self compilerClass new) format: (self sourceCodeAt: selector) in: self notifying: nil decorated: false. method _ self compiledMethodAt: selector. method putSource: newCodeString fromParseNode: nil class: self category: (self organization categoryOfElement: selector) inFile: 2 priorMethod: method! ! !ClassDescription methodsFor: 'fileIn/Out' stamp: 'tk 8/15/1998 15:26'! reorganize "During fileIn, !!Rectangle reorganize!! allows Rectangle to seize control and treat the next chunk as its organization. See the transfer of control where ReadWriteStream fileIn calls scanFrom:" Smalltalk changes reorganizeClass: self. ^self organization! ]style[(10 156 22 80)f1b,f1,f1LReadWriteStream fileIn;,f1! ! !ClassDescription methodsFor: 'private' stamp: 'ar 7/11/1999 11:41'! instVarMappingFrom: oldClass "Return the mapping from instVars of oldClass to new class that is used for converting old instances of oldClass." | oldInstVarNames | oldInstVarNames _ oldClass allInstVarNames. ^self allInstVarNames collect: [:instVarName | oldInstVarNames indexOf: instVarName]. ! ! !ClassDescription methodsFor: 'private' stamp: 'di 4/3/1999 22:29'! linesOfCode "InterpreterSimulator linesOfCode 790" "An approximate measure of lines of code. Includes comments, but excludes blank lines." | lines code strm line | lines _ 0. self selectorsDo: [:sel | code _ self sourceCodeAt: sel. strm _ ReadStream on: code. [strm atEnd] whileFalse: [line _ strm upTo: Character cr. line isEmpty ifFalse: [lines _ lines+1]]]. self isMeta ifTrue: [^ lines] ifFalse: [^ lines + self class linesOfCode] " (SystemOrganization categories select: [:c | 'Fabrik*' match: c]) detectSum: [:c | (SystemOrganization superclassOrder: c) detectSum: [:cl | cl linesOfCode]] 24878 "! ! !ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'! newInstanceFrom: oldInstance variable: variable size: instSize map: map "Create a new instance of the receiver based on the given old instance. The supplied map contains a mapping of the old instVar names into the receiver's instVars" | new | variable ifTrue: [new _ self basicNew: oldInstance basicSize] ifFalse: [new _ self basicNew]. 1 to: instSize do: [:offset | (map at: offset) > 0 ifTrue: [new instVarAt: offset put: (oldInstance instVarAt: (map at: offset))]]. variable ifTrue: [1 to: oldInstance basicSize do: [:offset | new basicAt: offset put: (oldInstance basicAt: offset)]]. ^new! ! !ClassDescription methodsFor: 'private' stamp: 'ar 7/15/1999 17:04'! setInstVarNames: instVarArray "Private - for class initialization only" | required | required _ self instSize. superclass notNil ifTrue:[required _ required - superclass instSize]. instVarArray size = required ifFalse:[^self error: required printString, ' instvar names are required']. instVarArray isEmpty ifTrue:[instanceVariables _ nil] ifFalse:[instanceVariables _ instVarArray asArray].! ! !ClassDescription methodsFor: 'private' stamp: 'jm 11/1/1998 11:47'! spaceUsed "Answer a rough estimate of number of bytes used by this class and its metaclass. Does not include space used by class variables." | space 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: Array) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: Float) ifTrue: [space _ space + 12]. (lit isMemberOf: String) ifTrue: [space _ space + (lit size + 6)]. (lit isMemberOf: LargeNegativeInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]. (lit isMemberOf: LargePositiveInteger) ifTrue: [space _ space + ((lit size + 1) * 4)]]]. (self isMemberOf: Metaclass) ifTrue: [^ space] ifFalse: [^ space + self class spaceUsed]. ! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'sma 6/1/2000 12:22'! allSubclasses "Answer a Set of the receiver's and the receiver's descendent's subclasses." | scan scanTop | scan _ OrderedCollection withAll: self subclasses. scanTop _ 1. [scanTop > scan size] whileFalse: [scan addAll: (scan at: scanTop) subclasses. scanTop _ scanTop + 1]. ^ scan asSet! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'jm 5/29/2003 19:26'! classesThatImplementAllOf: selectorSet "Return an array of any classes that implement all the messages in selectorSet." | found remaining | found _ OrderedCollection new. selectorSet do: [:sel | (self methodDict includesKey: sel) ifTrue: [found add: sel]]. found isEmpty ifTrue: [^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: selectorSet)]] ifFalse: [remaining _ selectorSet select: [:sel | (found includes: sel) not]. remaining isEmpty ifTrue: [^ Array with: self]. ^ self subclasses inject: Array new into: [:subsThatDo :sub | subsThatDo , (sub classesThatImplementAllOf: remaining)]]! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:57'! 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 | 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 asSortedCollection:[:c1 :c2| c1 name <= c2 name]. "Print subclasses in alphabetical order" subclassNames do: [:subclass | subclass printSubclassesOn: aStream level: level + 1]! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 6/10/1999 12:05'! 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! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 7/21/1999 11:05'! subclasses ^ Array new! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 08:22'! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." ^self subclasses do: aBlock! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'SqR 5/25/2000 16:54'! withAllSubclasses "Answer a Set of the receiver, the receiver's descendent's, and the receiver's descendent's subclasses." ^ self allSubclasses add: self; yourself! ! !ClassDiffBuilder methodsFor: 'initialize'! split: aString | lines in out c | lines := OrderedCollection new. in := ReadStream on: aString. out := WriteStream on: String new. [in atEnd] whileFalse:[ (c := in next) isSeparator ifTrue:[ out nextPut: c. lines add: out contents. out reset. ] ifFalse:[ out nextPut: c. ]. ]. out position = 0 ifFalse:[ lines add: out contents. ]. ^lines! ! !ClassDiffBuilder methodsFor: 'printing'! printPatchSequence: ps on: aStream | type line attr | ps do:[:assoc| type := assoc key. line := assoc value. attr := TextEmphasis normal. type == #insert ifTrue:[attr := TextColor red]. type == #remove ifTrue:[attr := TextEmphasis struckOut]. aStream withAttribute: attr do:[aStream nextPutAll: line]. ].! ! I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! !ClassOrganizer methodsFor: 'accessing' stamp: 'di 12/2/1999 20:36'! changeFromCategorySpecs: categorySpecs "Tokens is an array of categorySpecs as scanned from a browser 'reorganize' pane, or built up by some other process, such as a scan of an environment." | oldElements newElements newCategories newStops currentStop temp ii cc catSpec | oldElements _ elementArray asSet. newCategories _ Array new: categorySpecs size. newStops _ Array new: categorySpecs size. currentStop _ 0. newElements _ WriteStream on: (Array new: 16). 1 to: categorySpecs size do: [:i | catSpec _ categorySpecs at: i. newCategories at: i put: catSpec first asSymbol. catSpec 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: 'di 12/2/1999 10:54'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs _ Scanner new scanTokens: aString. "If nothing was scanned and I had no elements before, then default me" (categorySpecs isEmpty and: [elementArray isEmpty]) ifTrue: [^ self setDefaultList: Array new]. ^ self changeFromCategorySpecs: categorySpecs! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'di 5/4/1999 20:14'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [globalComment _ aString] ifFalse: [(aString == nil or: [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: 'sw 8/24/1998 12:29'! commentStamp ^ commentStamp! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'sw 8/24/1998 12:29'! commentStamp: aStamp commentStamp _ aStamp! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'sw 3/23/1999 15:58'! listAtCategoryNumber: anInteger "Answer the array of elements stored at the position indexed by anInteger. Answer nil if anInteger is larger than the number of categories." | firstIndex lastIndex | firstIndex _ (anInteger > 1 ifTrue: [categoryStops at: anInteger - 1] ifFalse: [0]) + 1. (categoryStops size < anInteger) ifTrue: [^ nil]. "It can happen, if Default category got aggressively removed by some automatic operation" lastIndex _ categoryStops at: anInteger. ^elementArray copyFrom: firstIndex to: lastIndex! ! !ClassOrganizer methodsFor: 'compiler access' stamp: 'sw 3/23/1999 17:04'! classify: element under: heading self classify: element under: heading suppressIfDefault: true! ! !ClassOrganizer methodsFor: 'compiler access' stamp: 'sw 3/23/1999 17:02'! classify: element under: heading suppressIfDefault: aBoolean "Store the argument, element, in the category named heading. If aBoolean is true, then invoke special logic such that the classification is NOT done if the new heading is the Default and the element already had a non-Default classification -- useful for filein" | 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: [(aBoolean and: [realHeading = Default]) ifTrue: [^ self]. "return if non-Default category already assigned in memory" self removeElement: element]. "remove if in another category" (categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading]. catIndex _ categoryArray indexOf: realHeading. elemIndex _ catIndex > 1 ifTrue: [categoryStops at: catIndex - 1] ifFalse: [0]. [(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) and: [element >= (elementArray at: elemIndex)]] whileTrue. "elemIndex is now the index for inserting the element. Do the insertion before it." elementArray _ elementArray copyReplaceFrom: elemIndex to: elemIndex-1 with: (Array with: element). "add one to stops for this and later categories" catIndex to: categoryArray size do: [:i | categoryStops at: i put: (categoryStops at: i) + 1]. (self listAtCategoryNamed: Default) size = 0 ifTrue: [self removeCategory: Default]! ! !ClassOrganizer methodsFor: 'method dictionary' stamp: 'di 3/29/2000 21:41'! allMethodSelectors "give a list of all method selectors." ^ elementArray copy sort! ! !ClassOrganizer methodsFor: 'method dictionary' stamp: 'sw 3/23/1999 17:04'! letUserReclassify: anElement "Put up a list of categories and solicit one from the user. Answer true if user indeed made a change, else false" "ClassOrganizer organization letUserReclassify: #letUserReclassify:" | currentCat newCat | currentCat _ self categoryOfElement: anElement. newCat _ self categoryFromUserWithPrompt: 'Choose Category (currently "', currentCat, '")'. (newCat ~~ nil and: [newCat ~= currentCat]) ifTrue: [self classify: anElement under: newCat suppressIfDefault: false. ^ true] ifFalse: [^ false]! ! !ClassOrganizer methodsFor: 'method dictionary' stamp: 'sw 10/20/1999 16:24'! 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 _ categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCategory! ! !ClassOrganizer methodsFor: 'printing' stamp: 'di 4/26/2000 20:22'! printOn: aStream "Refer to the comment in Object|printOn:." | elementIndex | elementIndex _ 1. 1 to: categoryArray size do: [:i | aStream nextPut: $(. (categoryArray at: i) asString printOn: aStream. [elementIndex <= (categoryStops at: i)] whileTrue: [aStream space; nextPutAll: (elementArray at: elementIndex). elementIndex _ elementIndex + 1]. aStream nextPut: $); cr]! ! !ClassOrganizer methodsFor: 'fileIn/Out' stamp: 'sw 8/24/1998 12:33'! 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: '. commentStamp ifNil: [commentStamp _ '']. commentStamp storeOn: strm. strm nextPutAll: ' prior: '; nextPutAll: '0']. aFileStream nextChunkPut: header. aClass organization fileOutCommentOn: aFileStream moveSource: moveSource toFile: sourceIndex. aFileStream cr]! ! !ClassOrganizer methodsFor: 'private' stamp: 'sw 2/24/1999 15:26'! categoryFromUserWithPrompt: aPrompt "SystemDictionary organization categoryFromUserWithPrompt: 'testing'" | aMenu | aMenu _ CustomMenu new. self categories do: [:cat | aMenu add: cat asString action: cat]. ^ aMenu startUpWithCaption: aPrompt! ! !ClassOrganizer methodsFor: 'private' stamp: 'di 3/29/2000 21:42'! elementArray ^ elementArray! ! !ClassOrganizer class methodsFor: 'class initialization' stamp: 'ccn 3/22/1999 17:43'! allCategory "Return a symbol that represents the virtual all methods category." ^ '-- all --' asSymbol! ! An ancestor class for all models which can show code. Eventually, much of the code that currently resides in StringHolder which only applies to code-holding StringHolders might get moved down here.! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'jm 6/15/2003 12:35'! annotation "Provide a line of annotation material for a middle pane." | stamp aMessage sendersCount implementorsCount toShow aCategory separator aString aList versionsCount | (aMessage _ self selectedMessageName) ifNil: [^ '------']. toShow _ ReadWriteStream on: ''. separator _ ' ¥ '. Preferences defaultAnnotationRequests do: [:aRequest | (aRequest == #timeStamp) ifTrue: [stamp _ self timeStamp. toShow nextPutAll: (stamp size > 0 ifTrue: [stamp, separator] ifFalse: ['no timeStamp', separator])]. (aRequest == #messageCategory) ifTrue: [aCategory _ self selectedClassOrMetaClass organization categoryOfElement: self selectedMessageName. aCategory ifNotNil: "woud be nil for a method no longer present, e.g. in a recent-submissions browser" [toShow nextPutAll: aCategory, separator]]. (aRequest == #sendersCount) ifTrue: [sendersCount _ (Smalltalk allCallsOn: aMessage) size. sendersCount _ sendersCount == 1 ifTrue: ['1 sender'] ifFalse: [sendersCount printString, ' senders']. toShow nextPutAll: sendersCount, separator]. (aRequest == #implementorsCount) ifTrue: [implementorsCount _ (Smalltalk allImplementorsOf: aMessage) size. implementorsCount _ implementorsCount == 1 ifTrue: ['1 implementor'] ifFalse: [implementorsCount printString, ' implementors']. toShow nextPutAll: implementorsCount, separator]. (aRequest == #priorVersionsCount) ifTrue: [versionsCount _ VersionsBrowser versionCountForSelector: self selectedMessageName class: self selectedClassOrMetaClass. toShow nextPutAll: ((versionsCount > 1 ifTrue: [versionsCount == 2 ifTrue: ['1 prior version'] ifFalse: [versionsCount printString, ' prior versions']] ifFalse: ['no prior versions']), separator)]. (aRequest == #priorTimeStamp) ifTrue: [stamp _ VersionsBrowser timeStampFor: self selectedMessageName class: self selectedClassOrMetaClass reverseOrdinal: 2. stamp ifNotNil: [toShow nextPutAll: 'prior time stamp: ', stamp, separator]]. (aRequest == #recentChangeSet) ifTrue: [aString _ ChangeSorter mostRecentChangeSetWithChangeForClass: self selectedClassOrMetaClass selector: self selectedMessageName. aString size > 0 ifTrue: [toShow nextPutAll: aString, separator]]. (aRequest == #allChangeSets) ifTrue: [aList _ ChangeSorter allChangeSetsWithClass: self selectedClassOrMetaClass selector: self selectedMessageName. aList size > 0 ifTrue: [aList size = 1 ifTrue: [toShow nextPutAll: 'only in change set '] ifFalse: [toShow nextPutAll: 'in change sets: ']. aList do: [:aChangeSet | toShow nextPutAll: aChangeSet name, ' ']] ifFalse: [toShow nextPutAll: 'in no change set']. toShow nextPutAll: separator]]. ^ toShow contents! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:14'! changeCategory "Present a menu of the categories of messages for the current class, and let the user choose a new category for the current message" | aClass aSelector | (aClass _ self selectedClassOrMetaClass) ifNotNil: [(aSelector _ self selectedMessageName) ifNotNil: [(aClass organization letUserReclassify: aSelector) ifTrue: ["Smalltalk changes reorganizeClass: aClass." "Decided on further review that the above, when present, could cause more unexpected harm than good" self methodCategoryChanged]]]! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:11'! contentsChanged self changed: #contents. self changed: #annotation! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 17:29'! didCodeChangeElsewhere | aClass aSelector | "Determine whether the code for the currently selected method and class has been changed somewhere else." currentCompiledMethod ifNil: [^ false]. (aClass _ self selectedClassOrMetaClass) ifNil: [^ false]. (aSelector _ self selectedMessageName) ifNil: [^ false]. ^ (aClass compiledMethodAt: aSelector ifAbsent: [nil]) ~~ currentCompiledMethod ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'jm 6/15/2003 11:51'! diffButton | outerButton aButton | "Return a checkbox that lets the user decide whether diffs should be shown or not" outerButton _ AlignmentMorph newRow. outerButton centering: #center. outerButton color: Color transparent. outerButton hResizing: #shrinkWrap; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ ThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #toggleDiff; getSelector: #showDiffs. outerButton addMorphBack: (StringMorph contents: 'diffs') lock. outerButton setBalloonText: 'If checked, then code differences from the previous version, if any, will be shown.'. ^ outerButton ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:04'! diffFromPriorSourceFor: sourceCode | prior | "If there is a prior version of source for the selected method, return a diff, else just return the source code" ^ (prior _ self priorSourceOrNil) ifNil: [sourceCode] ifNotNil: [TextDiffBuilder buildDisplayPatchFrom: prior to: sourceCode]! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:11'! methodCategoryChanged self changed: #annotation! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/28/1999 13:48'! modelWakeUpIn: aWindow self updateListsAndCodeIn: aWindow. super modelWakeUpIn: aWindow! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/30/1999 12:08'! okayToAccept self showDiffs ifFalse: [^ true]. ^ (SelectionMenu confirm: 'Caution!! You are "showing diffs" here, so there is a danger that some of the text in the code pane is contaminated by the "diff" display' trueChoice: 'accept anyway -- I''ll take my chances' falseChoice: 'um, let me reconsider') ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:09'! priorSourceOrNil "If the currently-selected method has a previous version, return its source, else return nil" | aClass aSelector changeRecords | (aClass _ self selectedClassOrMetaClass) ifNil: [^ nil]. (aSelector _ self selectedMessageName) ifNil: [^ nil]. changeRecords _ aClass changeRecordsAt: aSelector. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. ^ (changeRecords at: 2) string ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 3/22/2000 23:04'! selectedMessageCategoryName "Answer the name of the message category of the message of the currently selected context." ^ self selectedClass organization categoryOfElement: self selectedMessageName! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 13:56'! showDiffs ^ showDiffs == true ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 13:56'! showDiffs: aBoolean showDiffs _ aBoolean! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 5/5/2000 09:23'! showUnreferencedInstVars "Search for all instance variables known to the selected class, and put up a list of those that have no references anywhere in the system. The search includes superclasses, so that you don't need to navigate your way to the class that defines each inst variable in order to determine whether it is unreferenced" | cls aList aReport | (cls _ self selectedClass) ifNil: [^ self]. aList _ cls allUnreferencedInstanceVariables. aList size == 0 ifTrue: [^ self inform: 'There are no unreferenced instance variables in ', cls name]. aReport _ String streamContents: [:aStream | aStream nextPutAll: 'Unreferenced instance variable(s) in ', cls name; cr. aList do: [:el | aStream tab; nextPutAll: el; cr]]. Transcript cr; show: aReport. (SelectionMenu labels: aList selections: aList) startUpWithCaption: 'Unreferenced instance variables in ', cls name! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 03:18'! spawnHierarchy "Create and schedule a new class hierarchy browser on the currently selected class or meta." | newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass | (selectedClassOrMetaClass _ self selectedClassOrMetaClass) ifNil: [^ self]. newBrowser _ HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass. (aSymbol _ self selectedMessageName) ifNotNil: [aBehavior _ selectedClassOrMetaClass. messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol. newBrowser messageCategoryListIndex: messageCatIndex + 1. newBrowser messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)]. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: self selectedClassName , ' hierarchy'! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 14:24'! spawnProtocol | aClassOrMetaclass | "Create and schedule a new protocol browser on the currently selected class or meta." (aClassOrMetaclass _ self selectedClassOrMetaClass) ifNotNil: [ProtocolBrowser openSubProtocolForClass: aClassOrMetaclass]! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 08:37'! stepIn: aSystemWindow self updateListsAndCodeIn: aSystemWindow! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 16:08'! toggleDiff self okToChange ifTrue: [self showDiffs: self showDiffs not. contents _ nil. self changed: #contents] ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 16:33'! toggleDiffing | showing | showing _ self showDiffs. self toggleDiff. showing = self showDiffs ifTrue: ["cancelled out" ^ self]. self inform: (showDiffs ifTrue: ['Okay, diffs will be shown'] ifFalse: ['Okay, diffs will no longer be shown']) ! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 17:30'! updateCodePaneIfNeeded "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits" self didCodeChangeElsewhere ifTrue: [self hasUnacceptedEdits ifFalse: [contents _ nil. self contentsChanged] ifTrue: [self changed: #codeChangedElsewhere]]! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 14:14'! updateListsAndCodeIn: aWindow super updateListsAndCodeIn: aWindow. self updateCodePaneIfNeeded! ! !CodeHolder methodsFor: 'as yet unclassified' stamp: 'sw 10/20/1999 12:22'! wantsStepsIn: aWindow ^ Preferences smartUpdating! ! !CollapsedMorph methodsFor: 'as yet unclassified' stamp: 'sw 5/9/2000 00:18'! beReplacementFor: aMorph | itsWorld priorPosition | (itsWorld _ aMorph world) ifNil: [^self]. uncollapsedMorph _ aMorph. self setLabel: aMorph externalName. aMorph delete. itsWorld addMorphFront: self. self collapseOrExpand. (priorPosition _ aMorph valueOfProperty: #collapsedPosition ifAbsent: [nil]) ifNotNil: [self position: priorPosition]. ! ! !CollapsedMorph methodsFor: 'as yet unclassified' stamp: 'bf 5/11/2000 11:41'! collapseOrExpand isCollapsed ifTrue: [uncollapsedMorph setProperty: #collapsedPosition toValue: self position. mustNotClose _ false. "We're not closing but expanding" self delete. self currentWorld addMorphFront: uncollapsedMorph] ifFalse: [super collapseOrExpand]! ! I am the abstract superclass of all classes that represent a group of elements.! !Collection methodsFor: 'accessing' stamp: 'jm 11/9/2002 23:00'! average "Answer the average of my elements. Assume I contain only numbers." ^ self sum asFloat / self size ! ! !Collection methodsFor: 'accessing' stamp: 'jm 5/29/2003 19:32'! contents "Compatibility with streams." ^ self ! ! !Collection methodsFor: 'accessing' stamp: 'jm 5/29/2003 19:38'! max "Answer the maximum element of this collection. Raise an error if the collection is empty." ^ self inject: self anyOne into: [:max :each | max max: each] ! ! !Collection methodsFor: 'accessing' stamp: 'jm 5/29/2003 19:38'! min "Answer the minimum element of this collection. Raise an error if the collection is empty." ^ self inject: self anyOne into: [:min :each | min min: each] ! ! !Collection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:34'! size "Answer how many elements the receiver contains." | tally | tally _ 0. self do: [:each | tally _ tally + 1]. ^ tally! ! !Collection methodsFor: 'accessing' stamp: 'jm 5/29/2003 19:44'! sum "Answer the sum of the elements of this collection. Answer zero if the collection is empty." "Details: To allow collections of any kind of object that understands + and - to be summed, the inital sum is an arbitrary sample element (as opposed to 0). This initial value is then subtracted from the final sum." | sum sample | self size = 0 ifTrue: [^ 0]. sample _ self anyOne. sum _ self inject: sample into: [:accum :each | accum + each]. ^ sum - sample ! ! !Collection methodsFor: 'adding' stamp: 'sma 5/12/2000 17:26'! addAll: aCollection "Include all the elements of aCollection as the receiver's elements. Answer aCollection. Actually, any object responding to #do: can be used as argument." aCollection do: [:each | self add: each]. ^ aCollection! ! !Collection methodsFor: 'comparing' stamp: 'sma 5/12/2000 12:08'! hash "A default hash function for any collection. Note that this method is insensitive to contents when the size is greater than 10, so critical applications that compare many large collections of the same length will want to refine this behavior." | hash | hash _ self species hash. self size <= 10 ifTrue: [self do: [:elem | hash _ hash bitXor: elem hash]]. ^ hash bitXor: self size hash! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! asArray "Answer an Array whose elements are the elements of the receiver. Implementation note: Cannot use ''Array withAll: self'' as that only works for SequenceableCollections which support the replacement primitive." | array index | array _ Array new: self size. index _ 0. self do: [:each | array at: (index _ index + 1) put: each]. ^ array! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:10'! asBag "Answer a Bag whose elements are the elements of the receiver." ^ Bag withAll: self! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:22'! asByteArray "Answer a ByteArray whose elements are the elements of the receiver. Implementation note: Cannot use ''ByteArray withAll: self'' as that only works for SequenceableCollections which support the replacement primitive." | array index | array _ ByteArray new: self size. index _ 0. self do: [:each | array at: (index _ index + 1) put: each]. ^ array! ! !Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:43'! 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." ^ self as: OrderedCollection! ! !Collection methodsFor: 'converting' stamp: 'sma 5/6/2000 20:29'! asSet "Answer a Set whose elements are the unique elements of the receiver." ^ Set withAll: self! ! !Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:44'! asSortedCollection "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is the default less than or equal." ^ self as: SortedCollection! ! !Collection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:46'! asSortedCollection: aSortBlock "Answer a SortedCollection whose elements are the elements of the receiver. The sort order is defined by the argument, aSortBlock." | aSortedCollection | aSortedCollection _ SortedCollection new: self size. aSortedCollection sortBlock: aSortBlock. aSortedCollection addAll: self. ^ aSortedCollection! ! !Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:41'! copyWith: newElement "Answer a new collection with newElement added (as last element if sequenceable)." ^ self copy add: newElement; yourself! ! !Collection methodsFor: 'copying' stamp: 'sma 5/12/2000 14:43'! copyWithout: oldElement "Answer a copy of the receiver that does not contain any elements equal to oldElement." ^ self reject: [:each | each = oldElement] "Examples: 'fred the bear' copyWithout: $e #(2 3 4 5 5 6) copyWithout: 5 "! ! !Collection methodsFor: 'enumerating' stamp: 'sma 4/30/2000 11:17'! anySatisfy: aBlock "Evaluate aBlock with the elements of the receiver. If aBlock returns true for any element return true. Otherwise return false." self do: [:each | (aBlock value: each) ifTrue: [^ true]]. ^ false! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:45'! 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' stamp: 'sma 5/12/2000 11:20'! 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: aBlock]! ! !Collection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:52'! 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' stamp: 'sma 5/12/2000 11:59'! select: selectBlock thenCollect: collectBlock "Utility method to improve readability." ^ (self select: selectBlock) collect: collectBlock! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:22'! remove: oldObject "Remove oldObject from the receiver's elements. Answer oldObject unless no element is equal to oldObject, in which case, raise an error. ArrayedCollections cannot respond to this message." ^ self remove: oldObject ifAbsent: [self errorNotFound: oldObject]! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:14'! remove: oldObject ifAbsent: anExceptionBlock "Remove oldObject from 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. ArrayedCollections cannot respond to this message." self subclassResponsibility! ! !Collection methodsFor: 'removing' stamp: 'jm 5/29/2003 19:48'! removeAll: aCollection "Remove each element of aCollection which is present in the receiver from the receiver. Answer aCollection. No error is raised if an element isn't found. ArrayedCollections cannot respond to this message." aCollection do: [:each | self remove: each ifAbsent: []]. ^ aCollection ! ! !Collection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:19'! removeAllSuchThat: aBlock "Evaluate aBlock for each element and remove all that elements from the receiver for that aBlock evaluates to true. Use a copy to enumerate collections whose order changes when an element is removed (i.e. Sets)." self copy do: [:each | (aBlock value: each) ifTrue: [self remove: each]]! ! !Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:07'! includes: anObject "Answer whether anObject is one of the receiver's elements." ^ self anySatisfy: [:each | each = anObject]! ! !Collection methodsFor: 'testing' stamp: 'sw 4/7/1999 17:28'! isEmptyOrNil "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" ^ self size = 0! ! !Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:39'! printElementsOn: aStream aStream nextPut: $(. self do: [:element | aStream print: element; space]. self isEmpty ifFalse: [aStream skip: -1]. aStream nextPut: $)! ! !Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! printNameOn: aStream super printOn: aStream! ! !Collection methodsFor: 'printing' stamp: 'sma 6/1/2000 09:41'! printOn: aStream "Append a sequence of characters that identify the receiver to aStream." self printNameOn: aStream. self printElementsOn: aStream! ! !Collection methodsFor: 'private' stamp: 'sma 5/12/2000 11:33'! anyOne "Answer a representative sample of the receiver. This method can be helpful when needing to preinfer the nature of the contents of semi-homogeneous collections." self emptyCheck. self do: [:each | ^ each]! ! !Collection methodsFor: 'private' stamp: 'sma 5/12/2000 11:22'! errorNotFound: anObject "Actually, this should raise a special Exception not just an error." self error: 'Object is not in the collection.'! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 19:58'! with: anObject "Answer an instance of me containing anObject." ^ self new add: anObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:01'! with: firstObject with: secondObject "Answer an instance of me containing the two arguments as elements." ^ self new add: firstObject; add: secondObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:03'! with: firstObject with: secondObject with: thirdObject "Answer an instance of me containing the three arguments as elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject "Answer an instance of me, containing the four arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject "Answer an instance of me, containing the five arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:06'! with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject with: sixthObject "Answer an instance of me, containing the six arguments as the elements." ^ self new add: firstObject; add: secondObject; add: thirdObject; add: fourthObject; add: fifthObject; add: sixthObject; yourself! ! !Collection class methodsFor: 'instance creation' stamp: 'sma 5/6/2000 20:07'! withAll: aCollection "Create a new collection containing all the elements from aCollection." ^ (self new: aCollection size) addAll: aCollection; yourself! ! !Collection class methodsFor: 'private' stamp: 'sma 3/3/2000 10:45'! initialize "Set up a Random number generator to be used by atRandom when the user does not feel like creating his own Random generator." RandomForPicking _ Random new! ! !Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'! randomForPicking ^ RandomForPicking! ! This class represents abstract color, regardless of the depth of bitmap it will be shown in. At the very last moment a Color is converted to a pixelValue that depends on the depth of the actual Bitmap inside the Form it will be used with. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. (See comment in BitBlt.) To change the depth of the Display and set how many colors you can see, execute: (Display newDepth: 8). (See comment in DisplayMedium) Color is represented as the amount of light in red, green, and blue. White is (1.0, 1.0, 1.0) and black is (0, 0, 0). Pure red is (1.0, 0, 0). These colors are "additive". Think of Color's instance variables as: r amount of red, a Float between 0.0 and 1.0. g amount of green, a Float between 0.0 and 1.0. b amount of blue, a Float between 0.0 and 1.0. (But, in fact, the three are encoded as values from 0 to 1023 and combined in a single integer, rgb. The user does not need to know this.) Many colors are named. You find a color by name by sending a message to class Color, for example (Color lightBlue). Also, (Color red: 0.2 green: 0.6 blue: 1.0) or (Color r: 0.2 g: 0.6 b: 1.0) creates a color. (see below) A color is essentially immutable. Once you set red, green, and blue, you cannot change them. Instead, create a new Color and use it. Applications such as contour maps and bar graphs will want to display one of a set of shades based on a number. Convert the range of this number to an integer from 1 to N. Then call (Color green lightShades: N) to get an Array of colors from white to green. Use the Array messages at:, atPin:, or atWrap: to pull out the correct color from the array. atPin: gives the first (or last) color if the index is out of range. atWrap: wraps around to the other end if the index is out of range. Here are some fun things to run in when your screen has color: Pen new mandala: 30 diameter: Display height-100. Pen new web "Draw with the mouse, opt-click to end" Display fillWhite. Pen new hilberts: 5. Form toothpaste: 30 "Draw with mouse, opt-click to end" You might also want to try the comment in Form>class>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: 'equality' stamp: 'di 1/6/1999 20:26'! = aColor "Return true if the receiver equals the given color. This method handles TranslucentColors, too." aColor isColor ifFalse: [^ false]. ^ aColor privateRGB = rgb and: [aColor privateAlpha = self privateAlpha] ! ! !Color methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! isTranslucent ^ false ! ! !Color methodsFor: 'queries' stamp: 'di 1/3/1999 12:23'! isTranslucentColor "This means: self isTranslucent, but isTransparent not" ^ false! ! !Color methodsFor: 'transformations' stamp: 'jm 9/23/2003 17:24'! alpha: alphaValue "Return a new TransparentColor with the given amount of opacity ('alpha')." alphaValue >= 1.0 ifFalse: [ ^ TranslucentColor basicNew setRgb: rgb alpha: (255.0 * alphaValue) asInteger]. ! ! !Color methodsFor: 'transformations' stamp: 'jm 6/25/1998 10:12'! darker "Answer a darker shade of this color." ^ self mixed: 0.8333 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'jm 6/17/1998 11:23'! lighter "Answer a lighter shade of this color." ^ self mixed: 0.8333 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! negated "Return an RGB inverted color" ^Color r: 1.0 - self red g: 1.0 - self green b: 1.0 - self blue! ! !Color methodsFor: 'transformations' stamp: 'sw 3/6/1999 01:19'! slightlyDarker "Answer a slightly darker shade of this color." ^ self mixed: 0.93 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'sw 3/6/1999 01:20'! slightlyLighter "Answer a slightly lighter shade of this color." ^ self mixed: 0.93 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'dew 6/18/1999 19:24'! twiceDarker "Answer a significantly darker shade of this color." ^ self mixed: 0.5 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 6/18/1999 19:24'! twiceLighter "Answer a significantly lighter shade of this color." ^ self mixed: 0.5 with: Color white ! ! !Color methodsFor: 'printing' stamp: 'bf 5/25/2000 16:52'! printOn: aStream | name | (name _ self name) ifNotNil: [^ aStream nextPutAll: 'Color '; nextPutAll: name]. self storeOn: aStream. ! ! !Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! storeArrayOn: aStream aStream nextPutAll: '#('. self storeArrayValuesOn: aStream. aStream nextPutAll: ') ' ! ! !Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! storeArrayValuesOn: aStream (self red roundTo: 0.001) storeOn: aStream. aStream space. (self green roundTo: 0.001) storeOn: aStream. aStream space. (self blue roundTo: 0.001) storeOn: aStream. ! ! !Color methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! asNontranslucentColor ^ self! ! !Color methodsFor: 'conversions' stamp: 'di 3/25/2000 10:13'! 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 and:[cachedBitPattern size = 2]) 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" ^ cachedBitPattern _ Bitmap with: (mask1*pv1) + (mask2*pv2) with: (mask1*pv3) + (mask2*pv1)! ! !Color methodsFor: 'conversions' stamp: 'hmm 4/25/2000 09:40'! 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." "Note for depths > 2, there are stippled and non-stippled versions (generated with #balancedPatternForDepth: and #bitPatternForDepth:, respectively). The stippled versions don't work with the window bit caching of StandardSystemView, so we make sure that for these depths, only unstippled patterns are returned" (depth == cachedDepth and: [depth <= 2 or: [cachedBitPattern size = 1]]) 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' stamp: 'bf 10/13/1999 14:22'! makeForegroundColor "Make a foreground color contrasting with me" ^self luminance >= "Color red luminance" 0.299 ifTrue: [Color black] ifFalse: [Color white]! ! !Color methodsFor: 'conversions' stamp: 'jm 1/26/2001 15:11'! 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 set to all ones (opaque alpha)" val _ LargePositiveInteger new: 4. val at: 3 put: ((rgb bitShift: -22) bitAnd: 16rFF). val at: 2 put: ((rgb bitShift: -12) bitAnd: 16rFF). val at: 1 put: ((rgb bitShift: -2) bitAnd: 16rFF). val = 0 ifTrue: [val at: 1 put: 1]. "closest non-transparent black" val at: 4 put: 16rFF. "opaque alpha" ^ 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' stamp: 'di 11/30/1998 09:03'! 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." | halfword | depth = 32 ifTrue: [^ pixelValue]. depth = 16 ifTrue: [halfword _ pixelValue] ifFalse: [halfword _ pixelValue * (#(16rFFFF "replicates at every bit" 16r5555 - "replicates every 2 bits" 16r1111 - - - "replicates every 4 bits" 16r0101) at: depth) "replicates every 8 bits"]. ^ halfword bitOr: (halfword bitShift: 16)! ! !Color methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:28'! scaledPixelValue32 "Return the alpha scaled pixel value for depth 32" ^self pixelWordForDepth: 32! ! !Color methodsFor: 'private'! privateGreen "Private!! Return the internal representation of my green component. Replaced >> by bitShift: 0 -. SqR!! 2/25/1999 23:08" ^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! ! !Color methodsFor: 'private' stamp: 'jm 9/23/2003 17:17'! setRgb: rgbValue "Initialize this color." rgb == nil ifFalse: [self attemptToMutateError]. rgb _ rgbValue. ! ! !Color class methodsFor: 'instance creation' stamp: 'sw 11/9/1998 19:25'! colorFrom: parm "Return an instantiated color from parm. If parm is already a color, return it, else return the result of my performing it if it's a symbol, else just return the thing" (parm isKindOf: Color) ifTrue: [^ parm]. (parm isKindOf: Symbol) ifTrue: [^ self perform: parm]. ^ parm! ! !Color class methodsFor: 'instance creation' stamp: 'ar 6/29/1999 16:08'! 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 transparent]. alpha < 255 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: 'mir 7/21/1999 11:54'! fromArray: colorDef colorDef size == 3 ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)]. colorDef size == 0 ifTrue: [^Color transparent]. colorDef size == 4 ifTrue: [^(TranslucentColor r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)]. self error: 'Undefined color definition'! ! !Color class methodsFor: 'instance creation' stamp: 'dvf 6/16/2000 17:48'! fromString: aString "for HTML color spec: #FFCCAA or white/black" "Color fromString: '#FFCCAA'. Color fromString: 'white'. Color fromString: 'orange'" | aColorHex red green blue | aString isEmptyOrNil ifTrue: [^ Color white]. aString first = $# ifTrue: [aColorHex _ aString copyFrom: 2 to: aString size] ifFalse: [aColorHex _ aString]. [aColorHex size = 6 ifTrue: [aColorHex _ aColorHex asUppercase. red _ ('16r', (aColorHex copyFrom: 1 to: 2)) asNumber/255. green _ ('16r', (aColorHex copyFrom: 3 to: 4)) asNumber/255. blue _ ('16r', (aColorHex copyFrom: 5 to: 6)) asNumber/255. ^ self r: red g: green b: blue]] ifError: [:err :rcvr | "not a hex color triplet" ]. "try to match aColorHex with known named colors" aColorHex _ aColorHex asLowercase. ^self perform: (ColorNames detect: [:i | i asString asLowercase = aColorHex] ifNone: [#white])! ! !Color class methodsFor: 'class initialization' stamp: 'dwh 7/7/1999 23:57'! 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: (TranslucentColor new alpha: 0.0). self named: #paleBuff put: (Color r: 254 g: 250 b: 235 range: 255). self named: #paleBlue put: (Color r: 222 g: 249 b: 254 range: 255). self named: #paleYellow put: (Color r: 255 g: 255 b: 217 range: 255). self named: #paleGreen put: (Color r: 223 g: 255 b: 213 range: 255). self named: #paleRed put: (Color r: 255 g: 230 b: 230 range: 255). self named: #veryPaleRed put: (Color r: 255 g: 242 b: 242 range: 255). self named: #paleTan put: (Color r: 235 g: 224 b: 199 range: 255). self named: #paleMagenta put: (Color r: 255 g: 230 b: 255 range: 255). self named: #paleOrange put: (Color r: 253 g: 237 b: 215 range: 255). self named: #palePeach put: (Color r: 255 g: 237 b: 213 range: 255). ! ! !Color class methodsFor: 'class initialization' stamp: 'ar 2/16/2000 21:56'! initializeTranslucentPatterns "Color initializeTranslucentPatterns" | mask bits pattern patternList | TranslucentPatterns _ Array new: 8. #(1 2 4 8) do:[:d| patternList _ Array new: 5. mask _ (1 bitShift: d) - 1. bits _ 2 * d. [bits >= 32] whileFalse: [ mask _ mask bitOr: (mask bitShift: bits). "double the length of mask" bits _ bits + bits]. "0% pattern" pattern _ Bitmap with: 0 with: 0. patternList at: 1 put: pattern. "25% pattern" pattern _ Bitmap with: mask with: 0. patternList at: 2 put: pattern. "50% pattern" pattern _ Bitmap with: mask with: mask bitInvert32. patternList at: 3 put: pattern. "75% pattern" pattern _ Bitmap with: mask with: 16rFFFFFFFF. patternList at: 4 put: pattern. "100% pattern" pattern _ Bitmap with: 16rFFFFFFFF with: 16rFFFFFFFF. patternList at: 5 put: pattern. TranslucentPatterns at: d put: patternList. ].! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleBlue ^PaleBlue! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleBuff ^PaleBuff! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleGreen ^PaleGreen! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleMagenta ^PaleMagenta! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleOrange ^PaleOrange! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! palePeach ^PalePeach! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleRed ^PaleRed! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleTan ^PaleTan! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! paleYellow ^PaleYellow! ! !Color class methodsFor: 'named colors' stamp: 'wod 5/24/1998 01:56'! tan ^ Color r: 0.8 g: 0.8 b: 0.5! ! !Color class methodsFor: 'named colors' stamp: 'dwh 7/7/1999 23:56'! veryPaleRed ^VeryPaleRed! ! !Color class methodsFor: 'colormaps' stamp: 'jm 5/2/1999 07:24'! 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'." | srcIndex map | CachedColormaps class == Array ifFalse: [CachedColormaps _ (1 to: 9) collect: [:i | Array new: 32]]. srcIndex _ sourceDepth. sourceDepth > 8 ifTrue: [srcIndex _ 9]. (map _ (CachedColormaps at: srcIndex) at: destDepth) ~~ nil ifTrue: [^ map]. map _ self computeColormapFrom: sourceDepth to: destDepth. (CachedColormaps at: srcIndex) at: destDepth put: map. ^ map ! ! !Color class methodsFor: 'colormaps' stamp: 'jm 3/25/1999 19:48'! computeColormapFrom: sourceDepth to: destDepth "Compute a colorMap for translating between the given depths. A colormap is a Bitmap whose entries contain the pixel values for the destination depth. Typical clients use cachedColormapFrom:to: instead." | map bitsPerColor | 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" destDepth > 8 ifTrue: [bitsPerColor _ 5] "retain maximum color resolution" ifFalse: [bitsPerColor _ 4]. map _ self computeRGBColormapFor: destDepth bitsPerColor: bitsPerColor]. "Note: zero is transparent except when source depth is one-bit deep" sourceDepth > 1 ifTrue: [map at: 1 put: 0]. ^ map ! ! !Color class methodsFor: 'other' stamp: 'di 3/29/1999 13:33'! 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 == nil or: [MaskingMap size ~= sizeNeeded]) ifTrue: [MaskingMap _ Bitmap new: sizeNeeded withAll: 16rFFFFFFFF. MaskingMap at: 1 put: 0. "transparent"]. ^ MaskingMap ! ! !Color class methodsFor: 'other' stamp: 'ar 2/16/2000 21:56'! translucentMaskFor: alphaValue depth: d "Return a pattern representing a mask usable for stipple transparency" ^(TranslucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! ! !Color class methodsFor: 'color from user' stamp: 'jm 1/19/1999 11:33'! colorTest: depth extent: chartExtent colorMapper: colorMapper "Create 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 colorTest: 32 extent: 570@180 colorMapper: [:c | c]) display" "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | Color r: (c red * 7) asInteger / 7 g: (c green * 7) asInteger / 7 b: (c blue * 3) asInteger / 3]) display" "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | Color r: (c red * 5) asInteger / 5 g: (c green * 5) asInteger / 5 b: (c blue * 5) asInteger / 5]) display" "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | Color r: (c red * 15) asInteger / 15 g: (c green * 15) asInteger / 15 b: (c blue * 15) asInteger / 15]) display" "(Color colorTest: 32 extent: 570@180 colorMapper: [:c | Color r: (c red * 31) asInteger / 31 g: (c green * 31) asInteger / 31 b: (c blue * 31) asInteger / 31]) 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. c _ colorMapper value: c. 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. c _ colorMapper value: c. 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. c _ colorMapper value: c. palette fill: (x@y extent: 10@1) fillColor: c. y _ y + 1]. ^ palette ! ! !Color class methodsFor: 'color from user' stamp: 'di 4/13/1999 14:30'! 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 _ 'transparent'] 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: 'di 4/13/1999 14:28'! 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.' displayOn: f at: q origin + (9@1). 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 ! ! !ColorForm methodsFor: 'accessing' stamp: 'mir 7/21/1999 11:51'! colorsFromArray: colorArray | colorList | colorList _ colorArray collect: [:colorDef | Color fromArray: colorDef]. self colors: colorList! ! !ColorForm methodsFor: 'pixel accessing' stamp: 'jm 5/29/2003 17:57'! 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' stamp: 'di 11/11/1998 13:20'! asGrayScale "Return a grayscale ColorForm computed by mapping each color into its grayscale equivalent" ^ self copy colors: (colors collect: [:c | c isTransparent ifTrue: [c] ifFalse: [Color gray: c luminance]])! ! !ColorForm methodsFor: 'color manipulation' stamp: 'ar 5/25/2000 19:51'! 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 and:[cachedColormap isColormap not]) 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: 'di 8/28/1998 15:48'! indexOfColor: aColor "Return the index of aColor in my color array" self ensureColorArrayExists. ^ colors indexOf: aColor ifAbsent: [0]! ! !ColorForm methodsFor: 'color manipulation' stamp: 'jm 10/19/1998 10:52'! mapColor: oldColor to: 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: 'jm 5/29/2003 17:57'! 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: 'jm 5/29/2003 17:57'! 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: 'private' stamp: 'jm 9/24/2003 12:27'! privateColors ^ colors ! ! !ColorForm methodsFor: 'private' stamp: 'jm 9/24/2003 12:43'! privateColors: anObject colors _ anObject. cachedDepth _ nil. cachedColormap _ nil. ! ! !ColorForm methodsFor: 'private' stamp: 'jm 4/5/1999 10:11'! setColors: colorArray cachedColormap: aBitmap depth: anInteger "Semi-private. Set the color array, cached colormap, and cached colormap depth to avoid having to recompute the colormap when switching color palettes in animations." colors _ colorArray. cachedDepth _ anInteger. cachedColormap _ aBitmap. ! ! !ColorForm methodsFor: 'scaling, rotation' stamp: 'ar 3/15/1999 14:28'! flipBy: direction centerAt: aPoint | oldColors newForm | oldColors _ colors. self colors: nil. newForm _ super flipBy: direction centerAt: aPoint. self colors: oldColors. newForm colors: oldColors. ^newForm ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'jm 7/23/1999 20:42'! hibernate "Make myself take up less space. See comment in Form>hibernate." super hibernate. self clearColormapCache. ! ! !ColorForm methodsFor: 'fileIn/Out' stamp: 'bf 5/25/2000 16:31'! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream cr; tab; nextPutAll: 'colorsFromArray: #('. self colors do: [:color | color storeArrayOn: aStream]. aStream nextPutAll: ' ))'.! ! !ColorForm methodsFor: 'postscript generation' stamp: 'jm 10/14/2003 18:33'! asFormWithSingleTransparentColor | pixelCounts transparentIndices newF | pixelCounts _ self tallyPixelValues. transparentIndices _ (1 to: colors size) select: [:i | (colors at: i) isTransparent and: [(pixelCounts at: i) > 0]]. transparentIndices size < 2 ifTrue: [^ self]. newF _ self deepCopy. newF mapColors: transparentIndices to: transparentIndices first. ^ newF ! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:54'! alphaMask ^masks at: 4! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:55'! alphaMask: value masks at: 4 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! alphaShift ^shifts at: 4! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! alphaShift: value shifts at: 4 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! at: index ^colors at: index! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! at: index put: value ^colors at: index put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueMask ^masks at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueMask: value masks at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueShift ^shifts at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! blueShift: value shifts at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'! colors ^colors! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenMask ^masks at: 2! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenMask: value masks at: 2 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenShift ^shifts at: 2! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! greenShift: value shifts at: 2 put: value.! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! masks ^masks! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! redMask ^masks at: 1! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redMask: value masks at: 1 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redShift ^shifts at: 1! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:37'! redShift: value shifts at: 1 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 20:48'! rgbaBitMasks "Return the rgba bit masks for the receiver" ^masks asArray with: shifts collect:[:m :s| m bitShift: s]! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 5/27/2000 19:16'! shifts ^shifts! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 1/16/2000 20:52'! mapPixel: pixelValue "Perform a forward pixel mapping operation" | pv | (shifts == nil and:[masks == nil]) ifFalse:[ pv _ (((pixelValue bitAnd: self redMask) bitShift: self redShift) bitOr: ((pixelValue bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pixelValue bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pixelValue bitAnd: self alphaMask) bitShift: self alphaShift)). ] ifTrue:[pv _ pixelValue]. colors == nil ifTrue:[^pv] ifFalse:[^colors at: pv].! ! !ColorMap methodsFor: 'pixel mapping' stamp: 'ar 1/16/2000 20:52'! pixelMap: pixelValue "Perform a reverse pixel mapping operation" | pv | colors == nil ifTrue:[pv _ pixelValue] ifFalse:[pv _ colors at: pixelValue]. (shifts == nil and:[masks == nil]) ifTrue:[^pv] ifFalse:[^(((pv bitAnd: self redMask) bitShift: self redShift) bitOr: ((pv bitAnd: self greenMask) bitShift: self greenShift)) bitOr: (((pv bitAnd: self blueMask) bitShift: self blueShift) bitOr: ((pv bitAnd: self alphaMask) bitShift: self alphaShift))]! ! !ColorMap methodsFor: 'private' stamp: 'ar 2/22/2000 16:47'! setShifts: shiftArray masks: maskArray colors: colorArray shiftArray ifNotNil:[shifts _ shiftArray asIntegerArray]. maskArray ifNotNil:[masks _ maskArray asWordArray]. colorArray ifNotNil:[colors _ colorArray asWordArray].! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/25/2000 19:41'! isColormap ^true! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! isFixed "Return true if the receiver does not use a lookup mechanism for pixel mapping" ^self isIndexed not! ! !ColorMap methodsFor: 'testing' stamp: 'ar 5/27/2000 19:06'! isIndexed "Return true if the receiver uses a lookup mechanism for pixel mapping" ^colors notNil! ! !ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:28'! = aColorMap "Return true if the receiver is equal to aColorMap" self species = aColorMap species ifFalse:[^false]. self isIndexed = aColorMap isIndexed ifFalse:[^false]. ^self colors = aColorMap colors and:[ self shifts = aColorMap shifts and:[ self masks = aColorMap masks]]! ! !ColorMap methodsFor: 'comparing' stamp: 'ar 5/27/2000 19:29'! hash "Hash is re-implemented because #= is re-implemented" ^colors hash bitXor: (shifts hash bitXor: masks hash)! ! !ColorMap class methodsFor: 'instance creation' stamp: 'jm 5/12/2003 18:57'! colors: colorArray ^ self new setShifts: nil masks: nil colors: colorArray ! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 5/27/2000 20:09'! mapBitsFrom: srcBitMask to: dstBitMask "Return an array consisting of the shift and the mask for mapping component values out of srcBitMask and into dstBitMask. While this computation is somewhat complicated it eases the batch conversion of all the pixels in BitBlt." | srcBits dstBits srcLow srcHigh dstLow dstHigh bits mask shift | (srcBitMask = 0 or:[dstBitMask = 0]) ifTrue:[^#(0 0)]. "Zero mask and shift" "Compute low and high bit position for source and dest bit mask" srcLow _ srcBitMask lowBit - 1. srcHigh _ srcBitMask highBit. dstLow _ dstBitMask lowBit - 1. dstHigh _ dstBitMask highBit. "Compute the number of bits in source and dest bit mask" srcBits _ srcHigh - srcLow. dstBits _ dstHigh - dstLow. "Compute the maximum number of bits we can transfer inbetween" bits _ srcBits min: dstBits. "Compute the (unshifted) transfer mask" mask _ (1 bitShift: bits) - 1. "Shift the transfer mask to the mask the highest n bits of srcBitMask" mask _ mask bitShift: (srcHigh - bits). "Compute the delta shift so that the most significant bit of the source bit mask falls on the most significant bit of the dest bit mask. Note that delta is used for #bitShift: so shift > 0 : shift right shift < 0 : shift left e.g., if dstHigh > srcHigh we need to shift left and if dstHigh < srcHigh we need to shift right. This leads to:" shift _ dstHigh - srcHigh. "And that's all we need" ^Array with: shift with: mask! ! !ColorMap class methodsFor: 'instance creation' stamp: 'jm 5/12/2003 18:57'! shifts: shiftArray masks: maskArray ^ self new setShifts: shiftArray masks: maskArray colors: nil ! ! !ColorMap class methodsFor: 'instance creation' stamp: 'ar 1/16/2000 16:02'! shifts: shiftArray masks: maskArray colors: colorArray ^self new setShifts: shiftArray masks: maskArray colors: colorArray! ! I allow a user to interactively select a color from a palette. ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'ar 2/17/2000 01:14'! buildChartForm | chartForm transText | chartForm _ ColorChart deepCopy asFormOfDepth: Display depth. true "Display depth >= 16" ifTrue: [chartForm fill: ((TransparentBox left + 9)@0 extent: 1@9) fillColor: Color lightGray. chartForm fill: ((TransparentBox right - 10)@0 extent: 1@9) fillColor: Color lightGray. transText _ (Form extent: 63@9 depth: 1 "Where there's a will there's a way..." fromArray: #( 0 0 4194306 1024 4194306 1024 15628058 2476592640 4887714 2485462016 1883804850 2486772764 4756618 2485462016 4748474 1939416064 0 0) offset: 0@0). transText displayOn: chartForm at: 62@0. Display depth = 32 ifTrue: ["Set opaque bits for 32-bit display" chartForm fill: chartForm boundingBox rule: Form under fillColor: (Color r: 0.0 g: 0.0 b: 0.0 alpha: 1.0)]]. chartForm borderWidth: 1. self form: chartForm. self updateSelectorDisplay. ! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'RAA 9/25/1999 11:42'! initialize super initialize. theSelectorDisplayMorph _ AlignmentMorph newRow color: Color white; borderWidth: 1; borderColor: Color red; hResizing: #shrinkWrap; vResizing: #shrinkWrap; addMorph: (StringMorph contents: 'theSelector'). self addMorph: theSelectorDisplayMorph. self buildChartForm. self addMorph: (SimpleButtonMorph new borderWidth: 0; label: 'x' font: nil; color: Color transparent; actionSelector: #delete; target: self; position: 1@0; extent: 10@9). selectedColor _ Color white. sourceHand _ nil. deleteOnMouseUp _ false. updateContinuously _ true. selector _ nil. target _ nil! ! !ColorPickerMorph methodsFor: 'initialization' stamp: 'ee 6/25/2003 15:18'! updateSelectorDisplay theSelectorDisplayMorph ifNil: [^self]. theSelectorDisplayMorph position: self bottomLeft. theSelectorDisplayMorph firstSubmorph contents: selector asString , ' ' , selectedColor printString! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'! argument ^argument! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:33'! argument: anObject argument _ anObject! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'sw 10/26/1999 00:16'! originalColor: colorOrSymbol | aColor | aColor _ (colorOrSymbol isKindOf: Color) ifTrue: [colorOrSymbol] ifFalse: [Color lightGreen]. originalColor _ aColor. originalForm fill: RevertBox fillColor: originalColor! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'RAA 9/25/1999 11:35'! selector: aSymbol selector _ aSymbol. self updateSelectorDisplay! ! !ColorPickerMorph methodsFor: 'accessing' stamp: 'sw 3/8/1999 14:28'! target: anObject target _ anObject. (target respondsTo: #color) ifTrue: [selectedColor _ target color] ifFalse: [selectedColor _ Color white]. ! ! !ColorPickerMorph methodsFor: 'event handling' stamp: 'ee 6/25/2003 15:08'! mouseDown: evt | localPt | localPt _ evt cursorPoint - self topLeft. (DragBox containsPoint: localPt) ifTrue: [^ evt hand grabMorph: self]. (RevertBox containsPoint: localPt) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. self comeToFront. sourceHand _ evt hand. self startStepping. ! ! !ColorPickerMorph methodsFor: 'private' stamp: 'ar 2/17/2000 01:12'! pickColorAt: aPoint "RAA 27 Nov 99 - aPoint is global, so no need to add viewbox topleft" | worldBox globalP c alpha localPt | localPt _ aPoint - self topLeft. (FeedbackBox containsPoint: localPt) ifTrue: [^ self]. (RevertBox containsPoint: localPt) ifTrue: [^ self updateColor: originalColor feedbackColor: originalColor]. "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: localPt) ifTrue: [alpha _ (aPoint x - bounds left - TransparentBox left - 10) asFloat / (TransparentBox width - 20) min: 1.0 max: 0.0. "(alpha roundTo: 0.01) printString , ' ' displayAt: 0@0." " -- debug" self updateColor: (selectedColor alpha: alpha) feedbackColor: (selectedColor alpha: alpha)] ifFalse: [self updateColor: ((selectedColor isColor and: [selectedColor isTranslucentColor]) ifTrue: [c alpha: selectedColor alpha] ifFalse: [c]) feedbackColor: c]! ! !ColorPickerMorph methodsFor: 'private' stamp: 'LC 2/2/2000 03:17'! updateTargetColor | nArgs | (target ~~ nil and: [selector ~~ nil]) ifTrue: [self updateSelectorDisplay. nArgs _ selector numArgs. nArgs = 1 ifTrue:[^target perform: selector with: selectedColor]. nArgs = 2 ifTrue:[^target perform: selector with: selectedColor with: sourceHand]. nArgs = 3 ifTrue:[^target perform: selector with: selectedColor with: argument with: sourceHand]]. ! ! !ColorPickerMorph methodsFor: 'other' stamp: 'jm 12/7/2002 16:32'! addToWorld: world near: box | goodLocation | goodLocation _ self bestPositionNear: box inWorld: world. world allMorphsDo: [:p | (p isMemberOf: ColorPickerMorph) ifTrue: [(p ~~ self and: [p owner notNil and: [p target == target]]) ifTrue: [(p selector == selector and: [p argument == argument]) ifTrue: [^ p comeToFront "uncover existing picker"] ifFalse: ["place second picker relative to first" goodLocation _ self bestPositionNear: p bounds inWorld: world]]]]. self position: goodLocation. world addMorphFront: self. self changed. ! ! !ColorPickerMorph methodsFor: 'other' stamp: 'jm 12/7/2002 16:54'! bestPositionNear: box inWorld: world | fullBox points matchingPoints b | fullBox _ self fullBounds. points _ #(topLeft bottomLeft topLeft topRight). "possible anchors" matchingPoints _ #(bottomLeft topLeft topRight topLeft). "possible alignment for anchor" 1 to: 4 do: [:i | "Try the four obvious anchor points" b _ fullBox align: (fullBox perform: (points at: i)) with: (box perform: (matchingPoints at: i)). (world bounds containsRect: b) ifTrue: [^ b topLeft]]. "found a place!!" ^ box center "when all else fails" ! ! !ColorPickerMorph methodsFor: 'other' stamp: 'LC 2/2/2000 04:28'! containsPoint: aPoint ^ (super containsPoint: aPoint) or: [RevertBox containsPoint: aPoint - self topLeft]! ! !ColorPickerMorph methodsFor: 'other' stamp: 'di 9/3/1999 13:34'! drawOn: aCanvas aCanvas depth = 1 ifTrue: [aCanvas fillRectangle: self bounds color: Color white]. Display depth = originalForm depth ifFalse: [self buildChartForm]. super drawOn: aCanvas! ! !ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:04'! includeInNewMorphMenu ^ true ! ! !ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'di 9/3/1999 13:14'! initialize "ColorPickerMorph initialize" ColorChart _ Color colorPaletteForDepth: 16 extent: 190@60. DragBox _ (11@0) extent: 9@8. RevertBox _ (ColorChart width - 20)@1 extent: 9@8. FeedbackBox _ (ColorChart width - 10)@1 extent: 9@8. TransparentBox _ DragBox topRight corner: RevertBox bottomLeft. ColorChart fillBlack: ((DragBox left - 1)@0 extent: 1@9). ColorChart fillBlack: ((TransparentBox left)@0 extent: 1@9). ColorChart fillBlack: ((FeedbackBox left - 1)@0 extent: 1@9). ColorChart fillBlack: ((RevertBox left - 1)@0 extent: 1@9). (Form dotOfSize: 5) displayOn: ColorChart at: DragBox center + (0@1). ! ! !ColorPickerMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/27/1999 11:40'! perniciousBorderColor "Answer the color of the border lines of a color picker; this color gets reported as you drag the mouse through from the translucent box to the true color area, for example, and can cause some difficulties in some special cases, so it is faithfully reported here in this hard-coded fashion in order that energetic clients wishing to handle it as special-case it can do so." ^ Color r: 0.0 g: 0.0 b: 0.032! ! 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' stamp: 'di 10/22/1999 13:14'! needsFrameSize: newFrameSize "Set the largeFrameBit to accomodate the newFrameSize" | 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' stamp: 'di 1/2/1999 17:00'! flushCache "Tell the interpreter to remove all references to this method from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. NOTE: Only one of two selective flush methods needs to be used. Squeak 2.2 and earlier uses 119 (See Symbol flushCache). Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'di 10/23/1999 22:00'! frameSize "Answer the size of temporary frame needed to run the receiver." "NOTE: Versions 2.7 and later use two sizes of contexts." (self header noMask: 16r20000) ifTrue: [^ SmallFrame] ifFalse: [^ LargeFrame] ! ! !CompiledMethod methodsFor: 'accessing' stamp: 'ar 6/2/1998 16:26'! numArgs "Answer the number of arguments the receiver takes." ^ (self header bitShift: -24) bitAnd: 16r0F! ! !CompiledMethod methodsFor: 'testing' stamp: 'sw 8/20/1998 09:31'! hasReportableSlip "Answer whether the receiver contains anything that might be brought to the attention of the author when filing out. Customize the lists to suit your preferences. If slips do not get reported in spite of your best efforts here, make certain that the Preference 'suppressCheckForSlips' has not been hard-coded to true." | assoc | #(halt halt: urgent hottest) do: [:aLit | (self hasLiteral: aLit) ifTrue: [^ true]]. #(Transcript AA BB CC DD EE) do: [:aSymbol | (assoc _ (Smalltalk associationAt: aSymbol ifAbsent: [nil])) ifNotNil: [(self hasLiteral: assoc) ifTrue: [^ true]]]. ^ false! ! !CompiledMethod methodsFor: 'testing' stamp: 'di 12/26/1998 21:31'! isQuick "Answer whether the receiver is a quick return (of self or of an instance variable)." ^ self primitive between: 256 and: 519! ! !CompiledMethod methodsFor: 'testing' stamp: 'ar 6/2/1998 16:11'! isReturnField "Answer whether the receiver is a quick return of an instance variable." ^ self primitive between: 264 and: 519! ! !CompiledMethod methodsFor: 'printing' stamp: 'sma 2/12/2000 14:01'! decompileString | clAndSel cl sel | clAndSel _ self who. clAndSel = #(unknown unknown) ifTrue: [cl _ Object. sel _ #xxxUnknown. self numArgs >= 1 ifTrue: [sel _ sel , ':'. 2 to: self numArgs do: [:i | sel _ sel , 'with:']. sel _ sel asSymbol]] ifFalse: [cl _ clAndSel first. sel _ clAndSel last]. ^ (cl decompilerClass new decompile: sel in: cl method: self) decompileString! ! !CompiledMethod methodsFor: 'printing' stamp: 'jm 10/14/2002 19:07'! printOn: aStream "Overrides method inherited from the byte arrayed collection." self printNameOn: aStream. aStream nextPutAll: '(', self identityHash printString, ')'. ! ! !CompiledMethod methodsFor: 'printing' stamp: 'ar 11/28/1999 19:37'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ self primitive. primIndex = 0 ifTrue:[^self]. primIndex = 120 "External call spec" ifTrue:[^aStream print: (self literalAt: 1); cr]. aStream nextPutAll: '; cr! ! !CompiledMethod methodsFor: 'printing' stamp: 'di 12/26/1998 21:30'! 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 printPrimitiveOn: aStream. (InstructionPrinter on: self) printInstructionsOn: aStream. ^aStream contents! ! !CompiledMethod methodsFor: 'printing' stamp: 'di 2/4/2000 21:13'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." | sel | Smalltalk allBehaviorsDo: [:class | (sel _ class methodDict keyAtIdentityValue: self ifAbsent: [nil]) ifNotNil: [^Array with: class with: sel]]. ^ Array with: #unknown with: #unknown ! ! !CompiledMethod methodsFor: 'literals' stamp: 'sma 6/3/2000 21:39'! hasLiteralThorough: literal "Answer true if any literal in this method is literal, even if embedded in array structure." | lit | 2 to: self numLiterals + 1 do: [:index | (lit _ self objectAt: index) == literal ifTrue: [^ true]. (lit class == Array and: [lit hasLiteral: literal]) ifTrue: [^ true]]. ^ false! ! !CompiledMethod methodsFor: 'scanning' stamp: 'di 12/26/1998 21:30'! 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: 'source code management' stamp: 'di 4/21/2000 07:54'! checkOKToAdd: size at: filePosition "Issue several warnings as the end of the changes file approaches its limit, and finally halt with an error when the end is reached." | fileSizeLimit margin | fileSizeLimit _ 16r2000000. 3 to: 1 by: -1 do: [:i | margin _ i*100000. (filePosition + size + margin) > fileSizeLimit ifTrue: [(filePosition + margin) > fileSizeLimit ifFalse: [self notify: 'WARNING: your changes file is within ' , margin printString , ' characters of its size limit. You should take action soon to reduce its size. You may proceed.']] ifFalse: [^ self]]. (filePosition + size > fileSizeLimit) ifFalse: [^ self]. self error: 'You have reached the size limit of the changes file. You must take action now to reduce it. Close this error. Do not attempt to proceed.'! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'! fileIndex ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'! filePosition ^SourceFiles filePositionFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'source code management' stamp: 'di 12/26/1998 22:34'! getSourceFor: selector in: class "Retrieve or reconstruct the source code for this method." | source flagByte | flagByte _ self last. (flagByte = 0 or: [flagByte = 251 "some source-less methods have flag = 251, rest = 0" and: [((1 to: 3) collect: [:i | self at: self size - i]) = #(0 0 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: 'di 4/21/2000 07:53'! 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)]. Smalltalk assureStartupStampLogged. file setToEnd. preambleBlock value: file. "Write the preamble" remoteString _ RemoteString newString: sourceStr onFileNumber: fileIndex toFile: file. file nextChunkPut: ' '; flush. self checkOKToAdd: sourceStr size at: remoteString position. self setSourcePosition: remoteString position inFile: fileIndex! ! !CompiledMethod methodsFor: 'source code management' stamp: 'di 9/23/1998 19:22'! 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: [Array with: 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' stamp: 'hmm 4/26/2000 21:00'! setSourcePointer: srcPointer srcPointer = 0 ifTrue: [ self at: self size put: 0. ^self]. (srcPointer between: 16r1000000 and: 16r4FFFFFF) ifFalse: [self error: 'Source pointer out of range']. self at: self size put: (srcPointer bitShift: -24) + 251. 1 to: 3 do: [:i | self at: self size-i put: ((srcPointer bitShift: (i-3)*8) bitAnd: 16rFF)]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 21:02'! setSourcePosition: position inFile: fileIndex self setSourcePointer: (SourceFiles sourcePointerFromFileIndex: fileIndex andPosition: position)! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:44'! sourcePointer "Answer the integer which can be used to find the source file and position for this method. The returned value is either 0 (if no source is stored) or a number between 16r1000000 and 16r4FFFFFF. The actual interpretation of this number is up to the SourceFileArray stored in the global variable SourceFiles." | pos | self last < 252 ifTrue: [^ 0 "no source"]. pos _ self last - 251. self size - 1 to: self size - 3 by: -1 do: [:i | pos _ pos * 256 + (self at: i)]. ^pos! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'di 1/11/1999 22:13'! fullFrameSize "CompiledMethod fullFrameSize" ^ LargeFrame! ! !CompiledMethod class methodsFor: 'class initialization' stamp: 'di 10/22/1999 09:56'! initialize "CompiledMethod initialize" "Initialize class variables specifying the size of the temporary frame needed to run instances of me." SmallFrame _ 16. "Context range for temps+stack" LargeFrame _ 56.! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'tk 1/21/2000 15:25'! new: size self error: 'CompiledMethods may only be created with newMethod:header:'! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:37'! newBytes: numberOfBytes trailerBytes: trailer 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 method | nTemps > 64 ifTrue: [^ self error: 'Cannot compile -- too many temporary variables']. 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)]. method _ self newMethod: numberOfBytes + trailer size header: (nArgs bitShift: 24) + (nTemps bitShift: 18) + (largeBit bitShift: 17) + (nLits bitShift: 9) + primBits. 1 to: trailer size do: "Copy the source code trailer to the end" [:i | method at: method size - trailer size + i put: (trailer at: i)]. ^ method! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:43'! toReturnConstant: index trailerBytes: trailer "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 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + index ! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:44'! toReturnField: field trailerBytes: trailer "Answer an instance of me that is a quick return of the instance variable indexed by the argument, field." ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 264 + field ! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:51'! toReturnSelf "Answer an instance of me that is a quick return of the instance (^self)." ^ self toReturnSelfTrailerBytes: #(0 0 0 0)! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'di 5/25/2000 06:44'! toReturnSelfTrailerBytes: trailer "Answer an instance of me that is a quick return of the instance (^self)." ^ self newBytes: 0 trailerBytes: trailer nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 ! ! 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' stamp: 'di 10/9/1998 16:50'! 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) doitFlag: false] ifFalse: [^requestor notify: aString at: location in: sourceStream]! ! !Compiler methodsFor: 'public access' stamp: 'bf 10/14/1999 19:55'! 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). self interactive ifTrue: [method _ method copyWithTempNames: methodNode tempNames]. 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' stamp: 'sw 11/7/1999 00:11'! format: textOrStream in: aClass notifying: aRequestor decorated: aBoolean "Compile a parse tree from the argument, textOrStream. Answer a string containing the original code, formatted nicely. If aBoolean is true, 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]. ^ aBoolean ifTrue: [aNode decompileText] ifFalse: [aNode decompileString]! ! !Compiler methodsFor: 'private' stamp: 'mn 5/25/2000 07:36'! format: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self class parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !Compiler methodsFor: 'private' stamp: 'mn 5/25/2000 07:37'! translate: aStream noPattern: noPattern ifFail: failBlock | tree | tree _ self class parserClass new parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! A composite transform provides the effect of several levels of coordinate transformations.! !CompositeTransform methodsFor: 'initialization' stamp: 'di 10/26/1999 17:08'! composedWith: aTransform "Return a new transform that has the effect of transforming points first by the receiver and then by the argument." self isIdentity ifTrue: [^ aTransform]. aTransform isIdentity ifTrue: [^ self]. ^ CompositeTransform new globalTransform: self localTransform: aTransform! ! !CompositeTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:00'! isCompositeTransform ^true! ! !CompositeTransform methodsFor: 'transformations' stamp: 'di 10/1/1998 13:51'! invert: aPoint ^ globalTransform invert: (localTransform invert: aPoint)! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'! angle ^ localTransform angle + globalTransform angle! ! !CompositeTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:45'! inverseTransformation "Return the inverse transformation of the receiver" ^self species new globalTransform: localTransform inverseTransformation localTransform: globalTransform inverseTransformation! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:40'! offset ^ (self localPointToGlobal: 0@0) negated! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'! scale ^ localTransform scale * globalTransform scale! ! !CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^localTransform globalPointToLocal: (globalTransform globalPointToLocal: aPoint)! ! !CompositeTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:39'! localPointToGlobal: aPoint "Transform aPoint from global coordinates into local coordinates" ^globalTransform localPointToGlobal: (localTransform localPointToGlobal: aPoint)! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'! asCompositeTransform ^self! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'! asMatrixTransform2x3 ^globalTransform asMatrixTransform2x3 composedWithLocal: localTransform asMatrixTransform2x3! ! !CompositeTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! asMorphicTransform "Squash a composite transform down to a simple one" ^ MorphicTransform offset: self offset angle: self angle scale: self scale! ! !CompositeTransform methodsFor: 'encoding' stamp: 'ls 3/19/2000 16:28'! encodeForRemoteCanvas ^String streamContents: [ :str | str nextPutAll: 'Composite,'; nextPutAll: '('; nextPutAll: globalTransform encodeForRemoteCanvas; nextPutAll: ')('; nextPutAll: localTransform encodeForRemoteCanvas; nextPutAll: ')' ]! ! !CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:49'! fromRemoteCanvasEncoding: encoding | firstStart firstEnd firstEncoding firstTransform secondStart secondEnd secondEncoding secondTransform | "format: Composite,(enc1)(enc2)" "decode the first encoding" firstStart := encoding indexOf: $(. firstStart = 0 ifTrue: [ self error: 'invalid encoding' ]. firstEnd := encoding findCloseParenthesisFor: firstStart. firstEncoding := encoding copyFrom: firstStart+1 to: firstEnd-1. firstTransform := DisplayTransform fromRemoteCanvasEncoding: firstEncoding. "decode the second encoding" secondStart := firstEnd + 1. (encoding at: secondStart) = $( ifFalse: [ ^self error: 'invalid encoding' ]. secondEnd := encoding findCloseParenthesisFor: secondStart. secondEncoding := encoding copyFrom: secondStart+1 to: secondEnd-1. secondTransform := DisplayTransform fromRemoteCanvasEncoding: secondEncoding. "put it together" ^self globalTransform: firstTransform localTransform: secondTransform! ! CompositionScanners are used to measure text and determine where line breaks and space padding should occur.! !CompositionScanner methodsFor: 'scanning' stamp: 'jm 7/22/2003 20: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])]. destX _ spaceX _ 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. self handleIndentation. leftMargin _ destX. line leftMargin: leftMargin. done _ false. [done] whileFalse: [stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'scanning' stamp: 'jm 7/22/2003 20:47'! composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph "Answer an instance of TextLineInterval that represents the next line in the paragraph." | runLength done stopCondition | destX _ spaceX _ 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" self handleIndentation. 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. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [^line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !CompositionScanner methodsFor: 'scanning' stamp: 'ar 1/8/2000 14:36'! 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' stamp: 'ar 1/9/2000 13:54'! cr "Answer true. Set up values for the text line interval currently being composed." line stop: lastIndex. spaceX _ destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:54'! 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' stamp: 'ar 1/9/2000 13:54'! 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: 'ar 1/8/2000 14:37'! placeEmbeddedObject: anchoredMorph | descent | (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. descent _ lineHeight - baseline. lineHeight _ lineHeight max: anchoredMorph height. baseline _ lineHeight - descent. ^ true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:48'! setFont super setFont. stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #space.! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'! setStopConditions "Set the font and the stop conditions for the current run." self setFont! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/9/2000 13:55'! 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' stamp: 'ar 1/9/2000 13:59'! 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 ! ! !CompositionScanner methodsFor: 'accessing' stamp: 'ar 1/8/2000 14:35'! 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: 'intialize-release' stamp: 'ar 5/17/2000 19:14'! forParagraph: aParagraph "Initialize the receiver for scanning the given paragraph." self initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle. ! ! Instances of this class hold the data resulting from compressing a sound. Each carries a reference to the codec class that created it, so that it can reconstruct a sound similar to the original in response to the message asSound. In order to facilitate integration with existing sounds, a CompressedSoundData instance can masquerade as a sound by caching a copy of its original sound and delegating the essential sound-playing protocol to that cached copy. It should probably be made a subclass of AbstractSound to complete the illusion.! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:10'! channels "Answer an array of ByteArrays containing the compressed sound data for each channel." ^ channels ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'! channels: anArray channels _ anArray. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:34'! codecName "Answer the name of the sound codec used to compress this sound. Typically, this is the name of a class that can be used to decode the sound, but it is possible that the codec has not yet been implemented or is not filed into this image." ^ codecName ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:45'! codecName: aStringOrSymbol codecName _ aStringOrSymbol asSymbol. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! firstSample "Answer the firstSample of the original sound." ^ firstSample ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! firstSample: anInteger firstSample _ anInteger. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:55'! gain "Answer the gain of the original sound." ^ gain ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:56'! gain: aNumber gain _ aNumber. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'! loopEnd "Answer index of the last sample of the loop, or nil if the original sound was not looped." ^ loopEnd ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'! loopEnd: anInteger loopEnd _ anInteger. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:11'! loopLength "Answer length of the loop, or nil if the original sound was not looped." ^ loopLength ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:35'! loopLength: anInteger loopLength _ anInteger. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'! perceivedPitch "Answer the perceived pitch of the original sound. By convention, unpitched sounds (like drum hits) are given an arbitrary pitch of 100.0." ^ perceivedPitch ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:39'! perceivedPitch: aNumber perceivedPitch _ aNumber. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 08:13'! samplingRate "Answer the samplingRate of the original sound." ^ samplingRate ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:36'! samplingRate: aNumber samplingRate _ aNumber. ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'! soundClassName "Answer the class name of the uncompressed sound." ^ soundClassName ! ! !CompressedSoundData methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:46'! soundClassName: aStringOrSymbol soundClassName _ aStringOrSymbol asSymbol. ! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:15'! asSound "Answer the result of decompressing the receiver." | codecClass | codecClass _ Smalltalk at: codecName ifAbsent: [^ self error: 'The codec for decompressing this sound is not available']. ^ (codecClass new decompressSound: self) reset ! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'! doControl cachedSound doControl ! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 08:49'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol cachedSound mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol ! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:49'! reset "This message is the cue to start behaving like a real sound in order to be played. We do this by caching a decompressed version of this sound. See also samplesRemaining." cachedSound == nil ifTrue: [cachedSound _ self asSound]. cachedSound reset ! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:44'! samples ^ self asSound samples! ! !CompressedSoundData methodsFor: 'asSound' stamp: 'di 2/17/1999 20:49'! samplesRemaining "This message is the cue that the cached sound may no longer be needed. We know it is done playing when samplesRemaining=0." | samplesRemaining | samplesRemaining _ cachedSound samplesRemaining. samplesRemaining <= 0 ifTrue: [cachedSound _ nil]. ^ samplesRemaining! ! 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: 'instruction decoding' stamp: 'jm 6/1/2003 23:18'! 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 == condition) ifTrue: [self jump: distance]! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'ar 5/25/2000 20:45'! 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:method:receiver:args: ifTrue: [answer _ receiver doPrimitive: (arguments at: 1) method: (arguments at: 2) receiver: (arguments at: 3) args: (arguments at: 4). self push: answer. ^self]. ^self send: selector to: receiver with: arguments super: superFlag! ! !ContextPart methodsFor: 'debugger access' stamp: 'ls 12/5/1999 13:43'! mclass "Answer the class in which the receiver's method was found." | mclass | self receiver class selectorAtMethod: self method setClass: [:mc | mclass _ mc ]. ^mclass! ! !ContextPart methodsFor: 'debugger access' stamp: 'di 8/31/1999 09:42'! shortStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 10) do: [:item | strm print: item; cr]]! ! !ContextPart methodsFor: 'debugger access' stamp: 'ar 7/9/1999 19:01'! sourceCode | selector methodClass | selector _ self receiver class selectorAtMethod: self method setClass: [:mclass | methodClass _ mclass]. ^self method getSourceFor: selector in: methodClass "Note: The above is a bit safer than ^ methodClass sourceCodeAt: selector which may fail if the receiver's method has been changed in the debugger (e.g., the method is no longer in the methodDict and thus the above selector is something like #Doit:with:with:with:) but the source code is still available."! ! !ContextPart methodsFor: 'debugger access' stamp: 'jm 5/23/2003 11:51'! 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' stamp: 'ls 10/10/1999 13:53'! tempNames "Answer an OrderedCollection of the names of the receiver's temporary variables, which are strings." | names | self method setTempNamesIfCached: [:n | ^n]. names _ (self mclass compilerClass new parse: self sourceCode in: self mclass notifying: nil) tempNames. self method cacheTempNames: names. ^names! ! !ContextPart methodsFor: 'controlling' stamp: 'di 10/23/1999 17:03'! 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 newForMethod: self home method) home: self home startpc: pc + 2 nargs: numArgs! ! !ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:40'! pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val _ self at: stackp. self stackp: stackp - 1. ^ val! ! !ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:39'! push: val "Push val on the receiver's stack." self stackp: stackp + 1. self at: stackp put: val! ! !ContextPart methodsFor: 'controlling' stamp: 'jm 5/15/2003 23:09'! 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]. meth _ class lookupSelector: selector. meth == nil ifTrue: [^ self send: #doesNotUnderstand: to: rcvr with: (Array with: (Message selector: selector arguments: args)) super: superFlag] ifFalse: [val _ self tryPrimitiveFor: meth receiver: rcvr args: args. val == PrimitiveFailToken ifFalse: [^ val]. ^ self activateMethod: meth withArgs: args receiver: rcvr class: class]! ! !ContextPart methodsFor: 'controlling' stamp: 'crl 2/26/1999 15:34'! terminate "Make myself unresumable." sender _ nil! ! !ContextPart methodsFor: 'printing' stamp: 'ls 10/10/1999 11:57'! printOn: aStream | selector class mclass | self method == nil ifTrue: [^ super printOn: aStream]. selector _ (class _ self receiver class) selectorAtMethod: self method setClass: [:c | mclass _ c]. 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: 'private' stamp: 'ar 5/25/2000 20:47'! doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments "Simulate a primitive method whose index is primitiveIndex. The simulated receiver and arguments are given as arguments to this message." | value | "Simulation guard" "If successful, push result and return resuming context, else ^ PrimitiveFailToken" (primitiveIndex = 19) ifTrue:[ Debugger openContext: self label:'Code simulation error' contents: self shortStack]. (primitiveIndex = 80 and: [receiver isKindOf: ContextPart]) ifTrue: [^self push: ((BlockContext newForMethod: receiver home method) home: receiver home startpc: pc + 2 nargs: (arguments at: 1))]. (primitiveIndex = 81 and: [receiver isMemberOf: BlockContext]) ifTrue: [^receiver pushArgs: arguments from: self]. primitiveIndex = 83 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: arguments allButFirst super: false]. primitiveIndex = 84 "afr 9/11/1998 19:50" ifTrue: [^ self send: arguments first to: receiver with: (arguments at: 2) super: false]. arguments size > 6 ifTrue: [^ PrimitiveFailToken]. primitiveIndex = 117 ifTrue:[value _ self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments] ifFalse:[value _ receiver tryPrimitive: primitiveIndex withArgs: arguments]. value == PrimitiveFailToken ifTrue: [^ PrimitiveFailToken] ifFalse: [^ self push: value]! ! !ContextPart methodsFor: 'private' stamp: 'di 1/11/1999 10:12'! 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." 1 to: numObjects do: [:i | self push: (anIndexableCollection at: i)]! ! !ContextPart methodsFor: 'private' stamp: 'di 10/23/1999 17:31'! stackp: newStackp "Storing into the stack pointer is a potentially dangerous thing. This primitive stores nil into any cells that become accessible as a result, and it performs the entire operation atomically." "Once this primitive is implemented, failure code should cause an error" self error: 'stackp store failure'. " stackp == nil ifTrue: [stackp _ 0]. newStackp > stackp 'effectively checks that it is a number' ifTrue: [oldStackp _ stackp. stackp _ newStackp. 'Nil any newly accessible cells' oldStackp + 1 to: stackp do: [:i | self at: i put: nil]] ifFalse: [stackp _ newStackp] "! ! !ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:41'! tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments "Hack. Attempt to execute the named primitive from the given compiled method" | selector theMethod spec | arguments size > 8 ifTrue:[^PrimitiveFailToken]. selector _ #( tryNamedPrimitive tryNamedPrimitive: tryNamedPrimitive:with: tryNamedPrimitive:with:with: tryNamedPrimitive:with:with:with: tryNamedPrimitive:with:with:with:with: tryNamedPrimitive:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with: tryNamedPrimitive:with:with:with:with:with:with:with:) at: arguments size+1. theMethod _ aReceiver class lookupSelector: selector. theMethod == nil ifTrue:[^PrimitiveFailToken]. spec _ theMethod literalAt: 1. spec replaceFrom: 1 to: spec size with: (aCompiledMethod literalAt: 1) startingAt: 1. ^aReceiver perform: selector withArguments: arguments! ! !ContextPart methodsFor: 'private' stamp: 'ar 5/25/2000 20:45'! tryPrimitiveFor: method receiver: receiver args: arguments "If this method has a primitive index, then run the primitive and return its result. Otherwise (and also if the primitive fails) return PrimitiveFailToken, as an indication that the method should be activated and run as bytecodes." | primIndex | (primIndex _ method primitive) = 0 ifTrue: [^ PrimitiveFailToken]. ^ self doPrimitive: primIndex method: method receiver: receiver args: arguments! ! !ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'! trace: aBlock "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls and returned values in the Transcript." Transcript clear. ^ self trace: aBlock on: Transcript! ! !ContextPart class methodsFor: 'examples' stamp: 'sma 4/22/2000 17:03'! trace: aBlock on: aStream "ContextPart trace: [3 factorial]" "This method uses the simulator to print calls to a file." | prev | prev _ aBlock. ^ thisContext sender runSimulated: aBlock contextAtEachStep: [:current | Sensor anyButtonPressed ifTrue: [^ nil]. current == prev ifFalse: [prev sender ifNil: [aStream space; nextPut: $^. self carefullyPrint: current top on: aStream]. aStream cr. (current depthBelow: aBlock) timesRepeat: [aStream space]. self carefullyPrint: current receiver on: aStream. aStream space; nextPutAll: current selector; flush. prev _ current]]! ! !ContextPart class methodsFor: 'examples' stamp: 'jm 5/23/2003 11:09'! trace: aBlock onFileNamed: fileName "This method uses the simulator to print calls to a file." "ContextPart trace: [3 factorial] onFileNamed: 'trace'" | aStream | aStream _ FileStream newFileNamed: fileName. self trace: aBlock on: aStream. aStream close. ! ! !ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'! initialize "A unique object to be returned when a primitive fails during simulation" PrimitiveFailToken _ Object new ! ! !ContextPart class methodsFor: 'simulation' stamp: 'di 2/10/1999 22:15'! primitiveFailToken ^ PrimitiveFailToken! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! basicNew: size self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! new self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:09'! new: size self error: 'Contexts must only be created with newForMethod:'! ! !ContextPart class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:55'! newForMethod: aMethod "This is the only method for creating new contexts, other than primitive cloning. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size from the method being activated. This is because asking a context its size (even basicSize!!) will not return the real object size but only the number of fields currently accessible, as determined by stackp." ^ super basicNew: aMethod frameSize! ! !ContextPart class methodsFor: 'private' stamp: 'jm 5/22/2003 20:32'! carefullyPrint: anObject on: aStream aStream nextPutAll: ([anObject printString] ifError: ['an unprintable ', anObject class name]) ! ! 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: 'selecting' stamp: 'ar 5/29/1998 18:32'! selection "Refer to the comment in Inspector|selection." selectionIndex = 0 ifTrue:[^'']. selectionIndex = 1 ifTrue: [^object]. selectionIndex = 2 ifTrue: [^object tempsAndValues] ifFalse: [^object tempAt: selectionIndex - 2]! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel ^ channel ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel: midiChannel channel _ midiChannel. ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! control ^ control ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! control: midiControl control _ midiControl. ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'! control: midiControl value: midiControlValue channel: midiChannel control _ midiControl. value _ midiControlValue. channel _ midiChannel. ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:02'! value ^ value ! ! !ControlChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 08:03'! value: midiControlValue value _ midiControlValue. ! ! !ControlChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'! isControlChange ^ true ! ! !ControlChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! outputOnMidiPort: aMidiPort "Output this event to the given MIDI port." aMidiPort midiCmd: 16rB0 channel: channel byte: control byte: value. ! ! !ControlChangeEvent methodsFor: 'printing' stamp: 'sma 6/1/2000 09:34'! printOn: aStream aStream nextPut: $(; print: time; nextPutAll: ': ctrl['; print: control; nextPutAll: ']='; print: value; nextPut: $)! ! 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: 'accessing' stamp: 'ar 6/5/1998 21:49'! activeController: aController "Set aController to be the currently active controller. Give the user control in it." "Simulation guard" activeController _ aController. (activeController == screenController) ifFalse: [self promote: activeController]. activeControllerProcess _ [activeController startUp. self searchForActiveController] newProcess. activeControllerProcess priority: Processor userSchedulingPriority. activeControllerProcess resume! ! !ControlManager methodsFor: 'scheduling' stamp: 'wod 6/17/1998 15:46'! findWindowSatisfying: aBlock "Present a menu of window titles, and activate the one that gets chosen" | sortAlphabetically controllers listToUse labels index | sortAlphabetically _ Sensor shiftPressed. 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: (listToUse at: index)]. ! ! !ControlManager methodsFor: 'scheduling' stamp: 'ar 11/19/1998 18:31'! 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) == nil ifTrue: [activeControllerProcess == Processor activeProcess ifTrue: [activeControllerProcess suspend]] ifFalse: [suspendingList remove: activeControllerProcess ifAbsent:[]. 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: 'ar 6/5/1998 21:48'! 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." "Simulation guard" 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: 'displaying' stamp: 'hmm 1/5/2000 07:00'! restore: aRectangle "Restore all windows visible in aRectangle" ^ self restore: aRectangle without: nil! ! !ControlManager methodsFor: 'displaying' stamp: 'jm 5/29/2003 17:57'! 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' stamp: 'hmm 12/30/1999 19:35'! restore: aRectangle without: aView "Restore all windows visible in aRectangle" Display deferUpdates: true. self restore: aRectangle below: 1 without: aView. Display deferUpdates: false; forceToScreen: aRectangle! ! !ControlManager methodsFor: 'private' stamp: 'sw 12/6/1999 23:40'! unCacheWindows scheduledControllers ifNotNil: [scheduledControllers do: [:aController | aController view uncacheBits]]! ! !ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 15:16'! shutDown "Saves space in snapshots" Smalltalk isMorphic ifFalse: [ScheduledControllers unCacheWindows]! ! !ControlManager class methodsFor: 'snapshots' stamp: 'di 2/4/1999 09:00'! startUp Smalltalk isMorphic ifFalse: [ScheduledControllers restore]! ! 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: 'basic control sequence' stamp: 'ls 7/11/1998 06:33'! 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 interActivityPause. self controlActivity. Processor yield]! ! !Controller methodsFor: 'basic control sequence' stamp: 'di 4/27/2000 20:23'! interActivityPause "if we are looping quickly, insert a short delay. Thus if we are just doing UI stuff, we won't take up much CPU" | currentTime wait | MinActivityLapse ifNotNil: [ lastActivityTime ifNotNil: [ currentTime _ Time millisecondClockValue. wait _ lastActivityTime + MinActivityLapse - currentTime. wait > 0 ifTrue: [ wait < MinActivityLapse "big waits happen after a snapshot" ifTrue: [DisplayScreen checkForNewScreenSize. (Delay forMilliseconds: wait) wait ]. ]. ]. ]. lastActivityTime _ Time millisecondClockValue.! ! !Controller methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:23'! 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 and: [sensor blueButtonPressed not and: [sensor yellowButtonPressed not]]! ! !Controller methodsFor: 'cursor' stamp: 'sw 7/13/1999 18:42'! 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 ifNotNil: [view containsPoint: sensor cursorPoint] ifNil: [false]! ! !Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'! MinActivityLapse: milliseconds "minimum time to delay between calls to controlActivity" MinActivityLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! ! !Controller class methodsFor: 'initialization' stamp: 'ls 7/13/1998 00:47'! initialize "Controller initialize" self MinActivityLapse: 10.! ! This class is a quick hack to support rounded corners in morphic. Rather than produce rounded rectangles, it tweaks the display of corners. Rather than work for any radius, it only supports a radius of 6. Rather than work for any border width, it only supports widths 0, 1 and 2. The corners, while apparently transparent, still behave opaquely to mouse clicks. Worse than this, the approach relies on the ability to extract underlying bits from the canvas prior to display. This ran afoul of top-down display, it seems, in SystemWindow spawnReframeHandle: (qv). It will also make a postscript printer very unhappy. But, hey, it's cute.! !CornerRounder methodsFor: 'all' stamp: 'di 6/24/1999 09:35'! masterMask: maskForm masterOverlay: overlayForm cornerMasks _ #(none left pi right) collect: [:dir | (maskForm rotateBy: dir centerAt: 0@0) offset: 0@0]. cornerOverlays _ #(none left pi right) collect: [:dir | (overlayForm rotateBy: dir centerAt: 0@0) offset: 0@0]. ! ! !CornerRounder methodsFor: 'all' stamp: 'ar 2/12/2000 18:33'! saveBitsUnderCornersOf: aMorph on: aCanvas | offset corner mask form | underBits _ (1 to: 4) collect: [:i | mask _ cornerMasks at: i. corner _ aMorph bounds corners at: i. i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@mask height negated]. i = 3 ifTrue: [offset _ mask extent negated]. i = 4 ifTrue: [offset _ mask width negated@0]. form _ aCanvas contentsOfArea: (corner + offset extent: mask extent). form copyBits: form boundingBox from: mask at: 0@0 clippingBox: form boundingBox rule: Form and fillColor: nil map: (Bitmap with: 16rFFFFFFFF with: 0)]. ! ! !CornerRounder methodsFor: 'all' stamp: 'ar 3/24/2000 01:10'! tweakCornersOf: aMorph on: aCanvas borderWidth: w | offset corner saveBits c fourColors c14 c23 mask nonShadowCanvas outBits | nonShadowCanvas _ aCanvas copy shadowColor: nil. w > 0 ifTrue: [c _ aMorph borderColor. fourColors _ Array new: 4 withAll: c. c == #raised ifTrue: [c _ aMorph color. w = 1 ifTrue: [c14 _ c twiceLighter. c23 _ c twiceDarker] ifFalse: [c14 _ c lighter. c23 _ c darker]. fourColors _ Array with: c14 with: c with: c23 with: c]. (c == #inset and: [aMorph owner notNil]) ifTrue: [c _ aMorph owner colorForInsets. w = 1 ifTrue: [c14 _ c twiceLighter. c23 _ c twiceDarker] ifFalse: [c14 _ c lighter. c23 _ c darker]. fourColors _ Array with: c23 with: c with: c14 with: c]]. mask _ Form extent: cornerMasks first extent depth: aCanvas depth. (1 to: 4) do: [:i | corner _ aMorph bounds corners at: i. saveBits _ underBits at: i. i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@saveBits height negated]. i = 3 ifTrue: [offset _ saveBits extent negated]. i = 4 ifTrue: [offset _ saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. nonShadowCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue: ["Paint over with border if any" aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]. ! ! !CornerRounder methodsFor: 'all' stamp: 'ar 2/12/2000 18:31'! tweakCornersOf: aMorph on: aCanvas borderWidth: w corners: cornerList "This variant has a cornerList argument, to allow some corners to be rounded and others not" | offset corner saveBits c fourColors c14 c23 insetColor mask outBits | w > 0 ifTrue: [c _ aMorph borderColor. fourColors _ Array new: 4 withAll: c. c == #raised ifTrue: [c14 _ aMorph color lighter. c23 _ aMorph color darker. fourColors _ Array with: c14 with: c23 with: c23 with: c14]. (c == #inset and: [aMorph owner notNil]) ifTrue: [insetColor _ aMorph owner colorForInsets. c14 _ insetColor lighter. c23 _ insetColor darker. fourColors _ Array with: c14 with: c23 with: c23 with: c14]]. mask _ Form extent: cornerMasks first extent depth: aCanvas depth. (1 to: 4) do: [:i | (cornerList includes: i) ifTrue: [corner _ aMorph bounds corners at: i. saveBits _ underBits at: i. i = 1 ifTrue: [offset _ 0@0]. i = 2 ifTrue: [offset _ 0@saveBits height negated]. i = 3 ifTrue: [offset _ saveBits extent negated]. i = 4 ifTrue: [offset _ saveBits width negated@0]. "Mask out corner area (painting saveBits won't clear if transparent)." mask copyBits: mask boundingBox from: (cornerMasks at: i) at: 0@0 clippingBox: mask boundingBox rule: Form over fillColor: nil map: (Bitmap with: 0 with: 16rFFFFFFFF). outBits _ aCanvas contentsOfArea: (corner + offset extent: mask extent). mask displayOn: outBits at: 0@0 rule: Form and. "Paint back corner bits." saveBits displayOn: outBits at: 0@0 rule: Form paint. "Paint back corner bits." aCanvas drawImage: outBits at: corner + offset. w > 0 ifTrue: ["Paint over with border if any" aCanvas stencil: (cornerOverlays at: i) at: corner + offset color: (fourColors at: i)]]]! ! !CornerRounder class methodsFor: 'all' stamp: 'di 6/28/1999 15:51'! initialize "CornerRounder initialize" CR0 _ CR1 _ self new masterMask: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) offset: 0@0) masterOverlay: (Form extent: 6@6 fromArray: #(2r1e26 2r110e26 2r1000e26 2r10000e26 2r10000e26 2r100000e26) offset: 0@0). CR2 _ self new masterMask: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11111e26 2r11111e26 2r111111e26) offset: 0@0) masterOverlay: (Form extent: 6@6 fromArray: #(2r1e26 2r111e26 2r1111e26 2r11100e26 2r11000e26 2r111000e26) offset: 0@0). ! ! !CornerRounder class methodsFor: 'all' stamp: 'di 3/25/2000 11:12'! rectWithinCornersOf: aRectangle "Return a single sub-rectangle that lies entirely inside corners that are made by me. Used to identify large regions of window that do not need to be redrawn." ^ aRectangle insetBy: 0@6! ! !CornerRounder class methodsFor: 'all' stamp: 'hmm 3/8/2000 17:42'! roundCornersOf: aMorph on: aCanvas displayBlock: displayBlock borderWidth: w | rounder | rounder _ CR0. w = 1 ifTrue: [rounder _ CR1]. w = 2 ifTrue: [rounder _ CR2]. rounder _ rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas. displayBlock value. rounder tweakCornersOf: aMorph on: aCanvas borderWidth: w! ! !CornerRounder class methodsFor: 'all' stamp: 'hmm 3/8/2000 17:42'! roundCornersOf: aMorph on: aCanvas displayBlock: displayBlock borderWidth: w corners: aList | rounder | rounder _ CR0. w = 1 ifTrue: [rounder _ CR1]. w = 2 ifTrue: [rounder _ CR2]. rounder _ rounder copy. rounder saveBitsUnderCornersOf: aMorph on: aCanvas. displayBlock value. rounder tweakCornersOf: aMorph on: aCanvas borderWidth: w corners: aList! ! !CrLfFileStream methodsFor: 'open/close' stamp: 'ar 1/20/98 16:15'! open: aFileName forWrite: writeMode "Open the receiver. If writeMode is true, allow write, else access will be read-only. " | result | result _ super open: aFileName forWrite: writeMode. result ifNotNil: [self detectLineEndConvention]. ^ result! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'! ascii super ascii. self detectLineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:16'! binary super binary. lineEndConvention _ nil! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 7/10/1998 23:35'! detectLineEndConvention "Detect the line end convention used in this stream. The result may be either #cr, #lf or #crlf." | char numRead pos | self isBinary ifTrue: [^ self error: 'Line end conventions are not used on binary streams']. lineEndConvention _ LineEndDefault. "Default if nothing else found" numRead _ 0. pos _ super position. [super atEnd not and: [numRead < LookAheadCount]] whileTrue: [char _ super next. char = Lf ifTrue: [super position: pos. ^ lineEndConvention _ #lf]. char = Cr ifTrue: [super peek = Lf ifTrue: [lineEndConvention _ #crlf] ifFalse: [lineEndConvention _ #cr]. super position: pos. ^ lineEndConvention]. numRead _ numRead + 1]. super position: pos. ^ lineEndConvention! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 11/5/1998 23:37'! next | char secondChar | char _ super next. self isBinary ifTrue: [^char]. char == Cr ifTrue: [secondChar _ super next. secondChar ifNotNil: [secondChar == Lf ifFalse: [self skip: -1]]. ^Cr]. char == Lf ifTrue: [^Cr]. ^char! ! !CrLfFileStream methodsFor: 'access' stamp: 'ls 12/29/1998 17:15'! next: n | string peekChar | string _ super next: n. string size = 0 ifTrue: [ ^string ]. self isBinary ifTrue: [ ^string ]. "if we just read a CR, and the next character is an LF, then skip the LF" ( string last = Character cr ) ifTrue: [ peekChar _ super next. "super peek doesn't work because it relies on #next" peekChar ~= Character lf ifTrue: [ super position: (super position - 1) ]. ]. string _ string withSqueakLineEndings. string size = n ifTrue: [ ^string ]. "string shrunk due to embedded crlfs; make up the difference" ^string, (self next: n - string size)! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! nextPut: char (lineEndConvention notNil and: [char = Cr]) ifTrue: [super nextPutAll: (LineEndStrings at: lineEndConvention)] ifFalse: [super nextPut: char]. ^ char! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! nextPutAll: aString super nextPutAll: (self convertStringFromCr: aString). ^ aString ! ! !CrLfFileStream methodsFor: 'access' stamp: 'wod 6/18/1998 13:52'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next pos | self atEnd ifTrue: [^ nil]. pos _ self position. next _ self next. self position: pos. ^ next! ! !CrLfFileStream methodsFor: 'access' stamp: 'wod 11/5/1998 14:15'! upTo: aCharacter | newStream char | newStream _ WriteStream on: (String new: 100). [(char _ self next) isNil or: [char == aCharacter]] whileFalse: [newStream nextPut: char]. ^ newStream contents ! ! !CrLfFileStream methodsFor: 'access' stamp: 'ar 1/20/98 16:18'! verbatim: aString super verbatim: (self convertStringFromCr: aString). ^ aString! ! !CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21'! convertStringFromCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Cr with: Lf]. "lineEndConvention == #crlf" inStream _ ReadStream on: aString. outStream _ WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPutAll: CrLf]]. ^ outStream contents! ! !CrLfFileStream methodsFor: 'private' stamp: 'ar 1/20/98 16:21'! convertStringToCr: aString | inStream outStream | lineEndConvention ifNil: [^ aString]. lineEndConvention == #cr ifTrue: [^ aString]. lineEndConvention == #lf ifTrue: [^ aString copy replaceAll: Lf with: Cr]. "lineEndConvention == #crlf" inStream _ ReadStream on: aString. outStream _ WriteStream on: (String new: aString size). [inStream atEnd] whileFalse: [outStream nextPutAll: (inStream upTo: Cr). (inStream atEnd not or: [aString last = Cr]) ifTrue: [outStream nextPut: Cr. inStream peek = Lf ifTrue: [inStream next]]]. ^ outStream contents! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'! defaultToCR "CrLfFileStream defaultToCR" LineEndDefault := #cr.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'! defaultToCRLF "CrLfFileStream defaultToCRLF" LineEndDefault := #crlf.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:10'! defaultToLF "CrLfFileStream defaultToLF" LineEndDefault := #lf.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'ar 1/20/98 16:13'! guessDefaultLineEndConvention "Lets try to guess the line end convention from what we know about the path name delimiter from FileDirectory." FileDirectory pathNameDelimiter = $: ifTrue:[^self defaultToCR]. FileDirectory pathNameDelimiter = $/ ifTrue:[^self defaultToLF]. FileDirectory pathNameDelimiter = $\ ifTrue:[^self defaultToCRLF]. "in case we don't know" ^self defaultToCR! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'di 2/4/1999 09:16'! initialize "CrLfFileStream initialize" Cr := Character cr. Lf := Character lf. CrLf := String with: Cr with: Lf. LineEndStrings := Dictionary new. LineEndStrings at: #cr put: (String with: Character cr). LineEndStrings at: #lf put: (String with: Character lf). LineEndStrings at: #crlf put: (String with: Character cr with: Character lf). LookAheadCount := 2048. Smalltalk addToStartUpList: self. self startUp.! ! !CrLfFileStream class methodsFor: 'class initialization' stamp: 'djp 1/28/1999 22:08'! startUp self guessDefaultLineEndConvention! ! I am a 16 x 16 dot matrix suitable for use as the Alto hardware cursor.! !Cursor methodsFor: 'displaying' stamp: 'jm 9/22/1998 23:33'! beCursorWithMask: maskForm "Primitive. Tell the interpreter to use the receiver as the current cursor image with the given mask Form. Both the receiver and the mask should have extent 16@16 and a depth of one. The mask and cursor bits are combined as follow: mask cursor effect 0 0 transparent (underlying pixel shows through) 1 1 opaque black 1 0 opaque white 0 1 invert the underlying pixel" "Essential. See Object documentation whatIsAPrimitive." self primitiveFailed ! ! !Cursor methodsFor: 'displaying' stamp: 'jm 5/23/2003 11:08'! showWhile: aBlock "Show this cursor while evaluating the given Block." | oldcursor value | oldcursor _ Sensor currentCursor. self show. value _ aBlock value. oldcursor show. ^ value ! ! !Cursor methodsFor: 'testing' stamp: 'bf 2/2/1999 19:34'! hasMask ^false! ! !Cursor methodsFor: 'converting' stamp: 'di 3/7/1999 13:40'! asCursorForm | form | form _ Form extent: self extent depth: 8. form fillShape: self fillColor: Color black at: offset negated. ^ form offset: offset! ! !Cursor methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'! withMask ^CursorWithMask derivedFrom: self! ! !Cursor class methodsFor: 'class initialization' stamp: 'di 10/8/1998 17:04'! initNormalWithMask "Cursor initNormalWithMask. Cursor normal show" "Next two lines work simply for any cursor..." self initNormal. NormalCursor _ CursorWithMask derivedFrom: NormalCursor. "But for a good looking cursor, you have to tweak things..." NormalCursor _ (CursorWithMask extent: 16@16 depth: 1 fromArray: #( 0 1073741824 1610612736 1879048192 2013265920 2080374784 2113929216 2130706432 2080374784 2080374784 1275068416 100663296 100663296 50331648 50331648 0) offset: -1@-1) setMaskForm: (Form extent: 16@16 depth: 1 fromArray: #( 3221225472 3758096384 4026531840 4160749568 4227858432 4261412864 4278190080 4286578688 4278190080 4261412864 4261412864 3472883712 251658240 125829120 125829120 50331648) offset: 0@0).! ! !Cursor class methodsFor: 'class initialization' stamp: 'di 3/6/1999 21:27'! initialize "Create all the standard cursors..." self initOrigin. self initRightArrow. self initMenu. self initCorner. self initRead. self initWrite. self initWait. BlankCursor _ Cursor new. self initXeq. self initSquare. self initNormalWithMask. self initCrossHair. self initMarker. self initUp. self initDown. self initMove. self makeCursorsWithMask. "Cursor initialize" ! ! !Cursor class methodsFor: 'class initialization' stamp: 'bf 2/2/1999 19:33'! makeCursorsWithMask "Cursor initialize;makeCursorsWithMask" self classPool associationsDo: [:var | var value hasMask ifFalse: [var value: var value withMask]] ! ! !Cursor class methodsFor: 'instance creation' stamp: 'di 10/6/1998 13:53'! new ^ self extent: 16 @ 16 fromArray: (Array new: 16 withAll: 0) offset: 0 @ 0 "Cursor new bitEdit show"! ! !Cursor class methodsFor: 'current cursor' stamp: 'di 10/6/1998 13:57'! 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 isKindOf: self) ifTrue: [CurrentCursor _ aCursor. aCursor beCursor] ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! ! !Cursor class methodsFor: 'constants' stamp: 'jm 9/29/2003 10:53'! eyeDropper "Cursor eyeDropper showWhile: [Sensor waitButton]" | cursor | cursor _ CursorWithMask extent: 16@16 fromArray: #(14 31 31 255 126 184 280 552 1088 2176 4352 8704 17408 18432 45056 16384) offset: 0@-16. cursor setMaskForm: (Form extent: 16@16 depth: 1 fromArray: #(917504 2031616 2031616 16711680 8257536 16252928 33030144 65536000 130023424 260046848 520093696 1040187392 2080374784 2013265920 4026531840 3221225472) offset: 0@0). ^ cursor ! ! !Cursor class methodsFor: 'constants' stamp: 'jm 9/29/2003 10:42'! handClosed "Cursor handOpen showWhile: [Sensor waitButton]. Cursor handClosed showWhile: [Sensor waitNoButton]" | cursor | cursor _ CursorWithMask extent: 16@16 fromArray: #(0 0 0 448 3704 4686 4105 14337 18434 16386 8194 8196 4100 2056 1032 1032) offset: -8@-8. cursor setMaskForm: (Form extent: 16@16 depth: 1 fromArray: #(0 0 0 29360128 267911168 536739840 536805376 1073676288 2147352576 2147352576 1073610752 1073479680 536608768 267911168 133693440 133693440) offset: 0@0). ^ cursor ! ! !Cursor class methodsFor: 'constants' stamp: 'jm 9/29/2003 10:38'! handOpen "Cursor handOpen showWhile: [Sensor waitButton]" | cursor | cursor _ CursorWithMask extent: 16@16 fromArray: #(384 6768 9800 9802 4685 4681 26633 38913 34818 16386 8194 8196 4100 2056 1032 1032) offset: -8@-8. cursor setMaskForm: (Form extent: 16@16 depth: 1 fromArray: #(25165824 468713472 1073217536 1073348608 536805376 536805376 1878982656 4294901760 4294836224 2147352576 1073610752 1073479680 536608768 267911168 133693440 133693440) offset: 0@0). ^ cursor ! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 3/7/1999 13:40'! asCursorForm | form | form _ Form extent: self extent depth: 8. form fillShape: maskForm fillColor: Color white. form fillShape: self fillColor: Color black at: offset negated. ^ form offset: offset! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/6/1998 15:16'! beCursor maskForm unhibernate. ^ self beCursorWithMask: maskForm! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:34'! hasMask ^true! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/8/1998 16:46'! maskForm ^ maskForm! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'di 10/8/1998 16:46'! setMaskForm: aForm maskForm _ aForm! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:30'! storeOn: aStream base: anInteger aStream nextPut: $(. super storeOn: aStream base: anInteger. aStream nextPutAll: ' setMaskForm: '. maskForm storeOn: aStream base: anInteger. aStream nextPut: $)! ! !CursorWithMask methodsFor: 'as yet unclassified' stamp: 'bf 2/2/1999 19:31'! withMask ^self! ! !CursorWithMask class methodsFor: 'as yet unclassified' stamp: 'di 2/18/1999 08:56'! derivedFrom: aForm "Cursor initNormalWithMask. Cursor normal show" "aForm is presumably a cursor" | cursor mask ext | ext _ aForm extent. cursor _ self extent: ext. cursor copy: (1@1 extent: ext) from: 0@0 in: aForm rule: Form over. mask _ Form extent: ext. (1@1) eightNeighbors do: [:p | mask copy: (p extent: ext) from: 0@0 in: aForm rule: Form under]. cursor setMaskForm: mask. cursor offset: ((aForm offset - (1@1)) max: ext negated). ^ cursor! ! I am a subclass of polygon morph whose sides are curves rather than line segments. ! !CurveMorph methodsFor: 'private' stamp: 'jm 6/5/2003 21:36'! addHandles super addHandles. self updateHandles. ! ! !CurveMorph methodsFor: 'private' stamp: 'di 1/6/1999 21:59'! coefficients "Compute an array for the coefficients. This is copied from Flegal's old code in the Spline class." | length extras verts | coefficients ifNotNil: [^ coefficients]. 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)]]. ^ coefficients! ! !CurveMorph methodsFor: 'private' stamp: 'jm 7/17/2003 22:52'! 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 | curveBounds _ vertices first corner: vertices last. coefficients _ nil. "Force recomputation" ntfPoint _ nil. self lineSegmentsDo: [:p1 :p2 | ntfPoint == nil ifTrue: [ntfPoint _ p2 truncated]. curveBounds _ curveBounds encompass: p2 truncated. ntlPoint _ p1 truncated]. ^ curveBounds expandBy: borderWidth+1//2! ! !CurveMorph methodsFor: 'private' stamp: 'ar 6/18/1999 09:36'! getVertices | vtx | vtx _ WriteStream on: Array new. self lineSegmentsDo:[:pt1 :pt2| vtx nextPut: pt1]. ^vtx contents! ! !CurveMorph methodsFor: 'private' stamp: 'di 1/6/1999 22:01'! 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 coeffs | vertices size < 1 ifTrue: [^ self]. coeffs _ self coefficients. beginPoint _ (x _ (coeffs at: 1) at: 1) @ (y _ (coeffs at: 5) at: 1). 1 to: (coeffs at: 1) size - 1 do: [:i | "taylor series coeffs" x1 _ (coeffs at: 2) at: i. y1 _ (coeffs at: 6) at: i. x2 _ ((coeffs at: 3) at: i) / 2.0. y2 _ ((coeffs at: 7) at: i) / 2.0. x3 _ ((coeffs at: 4) at: i) / 6.0. y3 _ ((coeffs at: 8) at: i) / 6.0. "guess n" n _ 5 max: (x2 abs + y2 abs * 2.0 + ((coeffs at: 3) at: i+1) abs + ((coeffs 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 _ (coeffs at: 1) at: i+1) @ (y _ (coeffs at: 5) at: i+1). endPointsBlock value: beginPoint value: endPoint. beginPoint _ endPoint]! ! !CurveMorph methodsFor: 'private' stamp: 'di 1/6/1999 22:04'! privateMoveBy: delta super privateMoveBy: delta. coefficients _ nil. "Force recomputation" ! ! !CurveMorph methodsFor: 'private' stamp: 'di 1/6/1999 22:07'! releaseCachedState super releaseCachedState. coefficients _ nil.! ! !CurveMorph methodsFor: 'private' stamp: 'di 12/17/1998 13:44'! updateHandles | midPts nextVertIx tweens newVert | midPts _ OrderedCollection new. nextVertIx _ 2. tweens _ OrderedCollection new. self lineSegmentsDo: [:p1 :p2 | tweens addLast: p2 asIntegerPoint. p2 = (vertices atWrap: nextVertIx) ifTrue: ["Found endPoint." midPts addLast: (tweens at: tweens size // 2) + (tweens at: tweens size + 1 // 2) // 2. tweens _ OrderedCollection new. nextVertIx _ nextVertIx + 1]]. midPts withIndexDo: [:midPt :vertIndex | (closed or: [vertIndex < vertices size]) ifTrue: [newVert _ handles at: vertIndex*2. newVert position: midPt - (newVert extent // 2)]].! ! !CurveMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:04'! includeInNewMorphMenu ^ true ! ! 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: startUp: initialSelection startUp 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' stamp: 'sw 8/18/1998 12:01'! title: aTitle title _ aTitle! ! !CustomMenu methodsFor: 'construction' stamp: 'sw 7/20/1999 18:47'! balloonTextForLastItem: aString "Vacuous backstop provided for compatibility with MorphicMenu"! ! !CustomMenu methodsFor: 'construction' stamp: 'jm 8/20/1998 08:34'! labels: aString font: aFont lines: anArrayOrNil "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 linesArray | labelList _ (aString findTokens: String cr) asArray. anArrayOrNil ifNil: [linesArray _ #()] ifNotNil: [linesArray _ anArrayOrNil]. 1 to: labelList size do: [:i | self add: (labelList at: i) action: (labelList at: i). (linesArray includes: i) ifTrue: [self addLine]]. font ifNotNil: [font _ aFont]. ! ! !CustomMenu methodsFor: 'construction' stamp: 'di 8/20/1998 09:24'! labels: labelList 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:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | (labelList isMemberOf: String) ifTrue: [labelArray _ labelList findTokens: String cr] ifFalse: [labelArray _ labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]. ! ! !CustomMenu methodsFor: 'invocation' stamp: 'sw 8/18/1998 12:01'! 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: title! ! !CustomMenu methodsFor: 'private' stamp: 'sw 12/10/1999 11:21'! 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" super labels: stream contents font: MenuStyle defaultFont lines: dividers! ! !CustomMenu methodsFor: 'private' stamp: 'di 4/14/1999 21:28'! preSelect: action "Pre-select and highlight the menu item associated with the given action." | i | i _ selections indexOf: action ifAbsent: [^ self]. marker ifNil: [self computeForm]. marker _ marker align: marker topLeft with: (marker left)@(frame inside top + (marker height * (i - 1))). selection _ i.! ! !CustomMenu class methodsFor: 'example' stamp: 'sw 11/8/1999 17:27'! 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 "NB: The following is equivalent to the above, but uses the compact #fromArray: consruct: (CustomMenu fromArray: #( ('apples' apples) ('oranges' oranges) - - ('peaches' peaches) - ('pears' pears) -)) startUp: #apples"! ! I am used by Morphic to keep track of the rectangular areas on the screen that need to be redrawn. ! !DamageRecorder methodsFor: 'initialization' stamp: 'jm 5/30/2003 10:22'! initialize self reset. ! ! !DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'! reset "Clear the damage list." invalidRects _ OrderedCollection new: 15. totalRepaint _ false ! ! !DamageRecorder methodsFor: 'recording' stamp: 'jm 6/16/2003 09:48'! 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." | r mergeRect | totalRepaint ifTrue: [^ self]. "planning full repaint; don't bother collecting damage" r _ (aRectangle topLeft truncated) corner: (aRectangle right ceiling@aRectangle bottom ceiling). invalidRects do: [:rect | (rect intersects: r) ifTrue: [ "merge rectangle in place (see note below) if there is any overlap" rect setOrigin: (rect origin min: r origin) truncated corner: (rect corner max: r corner) truncated. ^ self]]. invalidRects size >= 15 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 new damage rectangle to the damage list" "Note: All rectangles added to the damage list should be copies, since rectangles in this list may be extended in place." invalidRects addLast: r. ! ! Refactored to use Julian Day Numbers internally. Julian Day Numbers are the number of days which have elapsed since 24 November -4713 Gregorian. The algorithm was published in the Communications of the ACM, volume 11, Number 10, October 1968. See also: http://www.magnet.ch/serendipity/hermetic/cal_stud/jdn.htm http://www.cs.ubc.ca/spider/flinn/docs/scham/primitives/time.html ! !Date methodsFor: 'accessing' stamp: 'BP 5/21/2000 19:17'! day "Answer the day of the year represented by the receiver." ^self dayOfYear! ! !Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:28'! julianDayNumber "Answer the number of days (or part of a day) elapsed since noon GMT on January 1st, 4713 B.C." ^julianDayNumber ! ! !Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:29'! julianDayNumber: anInteger "Set the number of days (or part of a day) elapsed since noon GMT on January 1st, 4713 B.C." julianDayNumber _ anInteger. ! ! !Date methodsFor: 'accessing' stamp: 'BP 5/21/2000 16:39'! leap "Answer whether the receiver's year is a leap year." ^Date leapYear: self year! ! !Date methodsFor: 'accessing' stamp: 'jm 5/23/2003 21:19'! monthIndex "Answer the index of the month in which the receiver falls." ^ self asGregorian second ! ! !Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:05'! monthName "Answer the name of the month in which the receiver falls." ^MonthNames at: self monthIndex! ! !Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 18:05'! weekday "Answer the name of the day of the week on which the receiver falls." ^WeekDayNames at: self weekdayIndex! ! !Date methodsFor: 'accessing' stamp: 'rca 6/15/2000 14:51'! weekdayIndex "Monday=1, ... , Sunday=7" ^ (self julianDayNumber rem: 7) + 1! ! !Date methodsFor: 'accessing' stamp: 'BP 5/18/2000 19:34'! year "Answer the year in which the receiver falls." ^self asGregorian last! ! !Date methodsFor: 'arithmetic' stamp: 'BP 5/18/2000 18:46'! addDays: dayCount "Answer a Date that is dayCount days after the receiver." ^self class fromJulianDayNumber: self julianDayNumber + dayCount.! ! !Date methodsFor: 'arithmetic' stamp: 'RAH 5/23/2000 11:32'! subtractDate: aDate "Answer the number of days between the receiver and aDate." ^self julianDayNumber - aDate asJulianDayNumber! ! !Date methodsFor: 'arithmetic' stamp: 'BP 5/18/2000 18:48'! subtractDays: dayCount "Answer a Date that is dayCount days before the receiver." ^self addDays: dayCount negated.! ! !Date methodsFor: 'comparing' stamp: 'RAH 5/23/2000 11:04'! < aDate "Answer whether aDate precedes the date of the receiver." ^julianDayNumber < aDate asJulianDayNumber! ! !Date methodsFor: 'comparing' stamp: 'BP 5/18/2000 18:31'! = aDate "Answer whether aDate is the same day as the receiver." ^julianDayNumber = aDate asJulianDayNumber. ! ! !Date methodsFor: 'comparing' stamp: 'BP 5/18/2000 19:09'! hash "Hash is reimplemented because = is implemented." ^julianDayNumber hash! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 19:18'! dayOfMonth "Answer which day of the month is represented by the receiver." ^self asGregorian first! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 19:18'! dayOfYear ^self firstDayOfMonth + self dayOfMonth - 1! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/18/2000 18:05'! 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' stamp: 'BP 5/21/2000 16:40'! daysInYear "Answer the number of days in the year represented by the receiver." ^Date daysInYear: self year! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 17:28'! daysLeftInYear "Answer the number of days in the year after the date of the receiver." ^self daysInYear - self dayOfYear! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/21/2000 17:31'! firstDayOfMonth "Answer the index of the day of the year that is the first day of the receiver's month." ^(FirstDayOfMonth at: self monthIndex) + (self monthIndex > 2 ifTrue: [self leap] ifFalse: [0])! ! !Date methodsFor: 'inquiries' stamp: 'BP 5/18/2000 19:10'! previous: dayName "Answer the previous date whose weekday name is dayName." ^self subtractDays: 7 + self weekdayIndex - (self class dayOfWeek: dayName) \\ 7! ! !Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:21'! asDate ^self! ! !Date methodsFor: 'converting' stamp: 'BP 5/21/2000 17:32'! asGregorian "Return an array of integers #(dd mm yyyy)" | l n i j dd mm yyyy | l _ self julianDayNumber + 68569. n _ (4 * l) // 146097. l _ l - ( (146097 * n + 3) // 4 ). i _ (4000 * (l + 1) ) // 1461001. l _ l - ( (1461 * i) // 4 ) + 31. j _ (80 *l) // 2447. dd _ l - ( (2447 * j) // 80 ). l _ j // 11. mm _ j + 2 - (12 * l). yyyy _ 100 * (n -49) + i + l. ^Array with: dd with: mm with: yyyy.! ! !Date methodsFor: 'converting' stamp: 'BP 5/21/2000 19:19'! asJulianDayNumber ^self julianDayNumber ! ! !Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:05'! 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: 'converting' stamp: 'BP 5/18/2000 18:05'! month ^ Month fromDate: self! ! !Date methodsFor: 'converting' stamp: 'BP 5/18/2000 18:05'! week ^ Week fromDate: self! ! !Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:05'! 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' stamp: 'BP 5/18/2000 18:22'! printFormat: formatArray "Answer a String describing the receiver using the argument formatArray." | aStream | aStream _ WriteStream on: (String new: 16). self printOn: aStream format: formatArray. ^aStream contents! ! !Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:05'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !Date methodsFor: 'printing' stamp: 'jm 5/23/2003 21:20'! printOn: aStream format: formatArray "Print a description of the receiver on aStream using the format denoted 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" | gregorian twoDigits element monthFormat | gregorian _ self asGregorian. twoDigits _ formatArray size > 6 and: [ (formatArray at: 7) > 1 ]. 1 to: 3 do: [ :i | element _ formatArray at: i. element = 1 ifTrue: [ twoDigits ifTrue: [ aStream nextPutAll: (gregorian first asString padded: #left to: 2 with: $0) ] ifFalse: [ gregorian first printOn: aStream ] ]. element = 2 ifTrue: [ monthFormat _ formatArray at: 5. monthFormat = 1 ifTrue: [ twoDigits ifTrue: [ aStream nextPutAll: (gregorian second asString padded: #left to: 2 with: $0) ] ifFalse: [ gregorian second printOn: aStream ]. ]. monthFormat = 2 ifTrue: [ aStream nextPutAll: ((MonthNames at: gregorian second) copyFrom: 1 to: 3) ]. monthFormat = 3 ifTrue: [ aStream nextPutAll: (MonthNames at: gregorian second) ]. ]. element = 3 ifTrue: [ (formatArray at: 6) = 1 ifTrue: [ gregorian last printOn: aStream ] ifFalse: [ aStream nextPutAll: ((gregorian last \\ 100) asString padded: #left to: 2 with: $0) ]. ]. i < 3 ifTrue: [ (formatArray at: 4) ~= 0 ifTrue: [ aStream nextPut: (formatArray at: 4) asCharacter ] ]. ].! ! !Date methodsFor: 'printing' stamp: 'BP 5/18/2000 18:05'! storeOn: aStream aStream nextPutAll: '(', self class name, ' readFromString: '; print: self printString; nextPut: $)! ! !Date methodsFor: 'obsolete' stamp: 'BP 5/21/2000 17:24'! day: dayInteger year: yearInteger self error: 'obsolete' ! ! !Date methodsFor: 'obsolete' stamp: 'BP 5/21/2000 17:30'! firstDayOfMonthIndex: monthIndex "Answer the day of the year (an Integer) that is the first day of my month" self error: 'obsolete'! ! !Date methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:23'! mmddyy "Please use mmddyyyy instead, so dates in 2000 will be unambiguous" ^ self printFormat: #(2 1 3 $/ 1 2)! ! !Date class methodsFor: 'class initialization' stamp: 'BP 5/18/2000 18:59'! 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' stamp: 'BP 5/21/2000 17:36'! fromDays: dayCount "Answer an instance of me which is dayCount days after January 1, 1901. Works for negative days before 1901. Works over a huge range, both BC and AD." ^self fromJulianDayNumber: dayCount + 2415386 "Julian Day Number of 1 Jan 1901" ! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/18/2000 18:38'! fromJulianDayNumber: aJulianDayNumber ^self new julianDayNumber: aJulianDayNumber.! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 19:26'! fromSeconds: seconds "Answer an instance of me which is 'seconds' seconds after January 1, 1901." ^self fromDays: seconds // SecondsInDay! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/18/2000 18:57'! fromString: aString "Answer an instance of created from a string with format DD.MM.YYYY." ^self readFrom: (ReadStream on: aString). ! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/18/2000 19:02'! newDay: day month: month year: year "Arguments day, month and year are all integers, except month may be a string Two digit dates are always from 1900. 1/1/01 will NOT mean 2001." | monthIndex daysInMonth p q r s | year < 100 ifTrue: [ ^self newDay: day month: month year: 1900 + year]. monthIndex _ month isInteger ifTrue: [month] ifFalse: [self indexOfMonth: month]. monthIndex = 2 ifTrue: [ daysInMonth _ (DaysInMonth at: monthIndex) + (self leapYear: year) ] ifFalse: [ daysInMonth _ DaysInMonth at: monthIndex ]. (day < 1 or: [day > daysInMonth]) ifTrue: [ self error: 'illegal day in month' ]. p _ (monthIndex - 14) quo: 12. q _ year + 4800 + p. r _ monthIndex - 2 - (12 * p). s _ (year + 4900 + p) quo: 100. ^self fromJulianDayNumber: ( (1461 * q) quo: 4 ) + ( (367 * r) quo: 12 ) - ( (3 * s) quo: 4 ) + ( day - 32075 ). ! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/22/2000 16:46'! newDay: dayCount year: referenceYear "Answer an instance of me which is dayCount days after the beginning of the year referenceYear." | day year daysInYear date | 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) ]. date _ self newDay: 1 month: 1 year: year. ^date addDays: (day - 1). ! ! !Date class methodsFor: 'instance creation' stamp: 'BP 5/21/2000 16:48'! 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' stamp: 'BP 5/21/2000 19:26'! today "Answer an instance of me representing the day and year right now." ^self dateAndTimeNow first! ! !Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'! dateAndTimeNow "Answer an Array whose first element is Date today and second element is Time now." ^Time dateAndTimeNow! ! !Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:59'! 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' stamp: 'BP 5/18/2000 19:00'! 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' stamp: 'BP 5/18/2000 18:05'! daysInYear: yearInteger "Answer the number of days in the year, yearInteger." ^365 + (self leapYear: yearInteger)! ! !Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 18:05'! 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' stamp: 'BP 5/18/2000 18:05'! 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' stamp: 'BP 5/18/2000 18:05'! leapYear: yearInteger "Answer 1 if the year yearInteger is a leap year; answer 0 if it is not." | adjustedYear | adjustedYear := yearInteger > 0 ifTrue: [yearInteger] ifFalse: [(yearInteger + 1) negated "There is no year 0!!!!"]. (adjustedYear \\ 4 ~= 0 or: [adjustedYear \\ 100 = 0 and: [adjustedYear \\ 400 ~= 0]]) ifTrue: [^0] ifFalse: [^1]! ! !Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 19:01'! nameOfDay: dayIndex "Answer a symbol representing the name of the day indexed by dayIndex, 1-7." ^WeekDayNames at: dayIndex! ! !Date class methodsFor: 'general inquiries' stamp: 'BP 5/18/2000 19:01'! nameOfMonth: monthIndex "Answer a String representing the name of the month indexed by monthIndex, 1-12." ^MonthNames at: monthIndex! ! !Date class methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:05'! absoluteDaysToYear: gregorianYear "Computes the number of days from (or until) January 1 of the year 1 A.D. upto (or since) January 1 of a given year. [Alan Lovejoy]" | days yearDelta quadCenturies centuries quadYears years isInADEra | days := 0. isInADEra := gregorianYear > 0. gregorianYear = 0 ifTrue: [gregorianYear = -1]. "There is no year 0" isInADEra ifTrue: [yearDelta := gregorianYear - 1] ifFalse: [yearDelta := (gregorianYear + 1) negated]. quadCenturies := yearDelta // 400. yearDelta := yearDelta rem: 400. centuries := yearDelta // 100. yearDelta := yearDelta rem: 100. quadYears := yearDelta // 4. years := yearDelta rem: 4. days := (quadCenturies * 146097 "days per quad century") + (centuries * 36524 "days per century") + (quadYears * 1461 "days per quad year") + (years * 365). isInADEra ifFalse: [days := days + 366. "1 B.C. is a leap year" days := days negated]. ^ days! ! !Date class methodsFor: 'obsolete' stamp: 'BP 5/18/2000 18:05'! yearAndDaysFromDays: days into: aTwoArgBlock "Compute the Gregorian year, and the day of the year, from the number of days since (or until) January 1 of the year 1 A.D. Return the values in a block. [Alan Lovejoy]" | quadCentury year dayInYear isInADEra century quadYear | dayInYear := days. isInADEra := days >= 0. isInADEra ifTrue: [year := 0] ifFalse: [dayInYear := dayInYear abs. dayInYear >= 366 "days per leap year" ifTrue: [year := 1. dayInYear := dayInYear - 366] "Subtract the year 1 B.C." ifFalse: [year := 0]]. quadCentury := dayInYear // 146097 "days per quad century". dayInYear := dayInYear \\ 146097 "days per quad century". century := dayInYear // 36524 "days per century". dayInYear := dayInYear \\ 36524 "days per century". quadYear := dayInYear // 1461 "days per quad year". dayInYear := dayInYear \\ 1461 "days per quad year". dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 1 AD or 2 BC" dayInYear := dayInYear - 365 "days per standard year". year := year + 1. dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 2 AD or 3 BC" dayInYear := dayInYear - 365 "days per standard year". year := year + 1. dayInYear >= 365 "days per standard year" ifTrue: ["e.g., 3 AD or 4 BC" dayInYear := dayInYear - 365 "days per standard year". year := year + 1. dayInYear >= 366 "days per leap year" ifTrue: [ "e.g., 4 AD or 5 BC (although this won't occur in the AD case)" dayInYear := dayInYear - 366 "days per leap year". year := year + 1]]]]. year := year + (quadCentury * 400) + (century * 100) + (quadYear * 4) + 1. isInADEra ifFalse: [ year := year negated. dayInYear > 0 ifTrue: [ (Date leapYear: year) = 1 ifTrue: [dayInYear := 366 "days per leap year" - dayInYear] ifFalse: [dayInYear := 365 "days per standard year" - dayInYear]]]. ^ aTwoArgBlock value: year value: dayInYear+1 "the way Dates do it"! ! I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. Special note on recursive errors: Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. * A recursive error is detected. * The current project is queried for an isolationHead * Changes in the isolationHead are revoked * The parent project of isolated project is returned to * The debugger is opened there and execution resumes. If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 10:00'! buildMVCDebuggerViewLabel: aString minSize: aPoint | topView stackListView stackCodeView rcvrVarView rcvrValView ctxtVarView ctxtValView deltaY underPane annotationPane buttonsView | 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 menuTitleSelector: #messageListSelectorTitle. stackListView window: (0 @ 0 extent: 150 @ 50). topView addSubView: stackListView. deltaY _ 0. Preferences useAnnotationPanes ifTrue: [annotationPane _ PluggableTextView on: self text: #annotation accept: nil readSelection: nil menu: nil. annotationPane window: (0@0 extent: 150@self optionalAnnotationHeight). topView addSubView: annotationPane below: stackListView. deltaY _ deltaY + self optionalAnnotationHeight. underPane _ annotationPane] ifFalse: [underPane _ stackListView]. Preferences optionalButtons ifTrue: [buttonsView _ self buildMVCOptionalButtonsButtonsView. buttonsView borderWidth: 1. topView addSubView: buttonsView below: underPane. underPane _ buttonsView. deltaY _ deltaY + self optionalButtonHeight]. stackCodeView _ PluggableTextView on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. stackCodeView window: (0 @ 0 extent: 150 @ (75 - deltaY)). topView addSubView: stackCodeView below: underPane. rcvrVarView _ PluggableListView on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:. rcvrVarView window: (0 @ 0 extent: 25 @ (50 - deltaY)). 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 - deltaY)). 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 - deltaY)). 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 - deltaY)). topView addSubView: ctxtValView toRightOf: ctxtVarView. topView label: aString. topView minimumSize: aPoint. ^ topView! ! !Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:12'! buildMVCNotifierButtonView | aView bHeight priorButton buttonView | aView _ View new model: self. bHeight _ self notifierButtonHeight. aView window: (0@0 extent: 350@bHeight). priorButton _ nil. self preDebugButtonQuads do: [:aSpec | buttonView _ PluggableButtonView on: self getState: nil action: aSpec second.. buttonView label: aSpec first; insideColor: (Color perform: aSpec third) muchLighter lighter; borderWidthLeft: 1 right: 1 top: 0 bottom: 0; window: (0@0 extent: 117@bHeight). priorButton ifNil: [aView addSubView: buttonView] ifNotNil: [aView addSubView: buttonView toRightOf: priorButton]. priorButton _ buttonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 08:36'! buildMVCNotifierViewLabel: aString message: messageString minSize: aPoint | topView aStringHolderView buttonView x y bHeight | topView _ StandardSystemView new model: self. topView borderWidth: 1. buttonView _ self buildMVCNotifierButtonView. topView addSubView: buttonView. aStringHolderView _ PluggableTextView on: self text: #contents accept: #doNothing: readSelection: #contentsSelection menu: #debugProceedMenu:. aStringHolderView editString: messageString; askBeforeDiscardingEdits: false. x _ 350 max: (aPoint x). y _ ((4 * 15) + 16) max: (aPoint y - 16 - self optionalButtonHeight). bHeight _ self optionalButtonHeight. y _ y - bHeight. aStringHolderView window: (0@0 extent: x@y). topView addSubView: aStringHolderView below: buttonView; label: aString; minimumSize: aPoint. ^ topView! ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/28/1999 11:38'! buildMVCOptionalButtonsButtonsView | aView bHeight offset aButtonView wid pairs windowWidth previousView | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 150. aView window: (0@0 extent: windowWidth@bHeight). offset _ 0. pairs _ self optionalButtonPairs. previousView _ nil. pairs do: [:pair | aButtonView _ PluggableButtonView on: self getState: nil action: pair last. pair last = pairs last last ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ windowWidth // (pairs size)]. aButtonView label: pair first asParagraph; insideColor: Color red muchLighter lighter; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. pair last = pairs first last ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^ aView! ! !Debugger methodsFor: 'initialize' stamp: 'tk 1/3/2000 12:57'! buildMorphicNotifierLabelled: label message: messageString | notifyPane window contentTop extentV | window _ (PreDebugWindow labelled: label) model: self. "Preferences optionalMorphicButtons" true ifTrue: [contentTop _ 0.2. window addMorph: (self buttonRowForPreDebugWindow: window) frame: (0@0 corner: 1 @ contentTop). extentV _ 156] ifFalse: [extentV _ 116. contentTop _ 0]. notifyPane _ PluggableTextMorph on: self text: nil accept: nil readSelection: nil menu: #debugProceedMenu:. notifyPane editString: messageString; askBeforeDiscardingEdits: false. window addMorph: notifyPane frame: (0@contentTop corner: 1@1). ^ window openInWorldExtent: 450 @ extentV! ! !Debugger methodsFor: 'initialize' stamp: 'jm 6/5/2003 18:27'! buttonRowForPreDebugWindow: aDebugWindow | aRow aButton | aRow _ AlignmentMorph newRow hResizing: #spaceFill. aRow isSticky: true. aButton _ SimpleButtonMorph new target: aDebugWindow. aButton color: Color transparent; borderWidth: 1. aRow addMorphBack: (AlignmentMorph newSpacer: self defaultBackgroundColor). self preDebugButtonQuads do: [:quad | aButton _ aButton fullCopy. aButton actionSelector: quad second. aButton label: quad first. aButton submorphs first color: (Color colorFrom: quad third). aButton setBalloonText: quad fourth. aRow addMorphBack: aButton. aRow addMorphBack: (AlignmentMorph newSpacer: self defaultBackgroundColor)]. ^ aRow ! ! !Debugger methodsFor: 'initialize' stamp: 'sw 12/28/1999 13:07'! notifierButtonHeight ^ 18! ! !Debugger methodsFor: 'initialize' stamp: 'sw 1/12/2000 16:47'! openFullMorphicLabel: labelString | window aListMorph codeTop aTextMorph | self expandStack. window _ (SystemWindow labelled: labelString) model: self. aListMorph _ PluggableListMorph on: self list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu:shifted: keystroke: #contextStackKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 corner: 1@0.3). Preferences useAnnotationPanes ifFalse: [codeTop _ 0.3] ifTrue: [aTextMorph _ PluggableTextMorph on: self text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.3 corner: 1@0.35). codeTop _ 0.35]. Preferences optionalButtons ifTrue: [window addMorph: self optionalButtonRow frame: ((0@codeTop corner: 1 @ (codeTop + 0.1))). codeTop _ codeTop + 0.1]. window addMorph: (PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0 @ codeTop corner: 1 @ 0.7). window addMorph: ((PluggableListMorph on: self receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) doubleClickSelector: #inspectSelection) 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:) doubleClickSelector: #inspectSelection) 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: 'ls 3/5/2000 14:20'! openFullNoSuspendLabel: aString "Create and schedule a full debugger with the given label. Do not terminate the current active process." | topView | Smalltalk isMorphic ifTrue: [self openFullMorphicLabel: aString. ^ Project current spawnNewProcessIfThisIsUI: interruptedProcess]. topView _ self buildMVCDebuggerViewLabel: aString minSize: 300@200. topView controller openNoTerminate. ^ topView ! ! !Debugger methodsFor: 'initialize' stamp: 'jm 10/7/2002 05:54'! 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." "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." | msg topView p | Sensor flushKeyboard. savedCursor _ Sensor currentCursor. Sensor currentCursor: Cursor normal. msg _ msgString. (label beginsWith: 'Space is low') ifTrue: [msg _ self lowSpaceChoices, msgString]. Smalltalk isMorphic ifTrue: [self buildMorphicNotifierLabelled: label message: msg. ^ Project current spawnNewProcessIfThisIsUI: interruptedProcess]. Display fullScreen. topView _ self buildMVCNotifierViewLabel: label message: msg minSize: 350@((14 * 5) + 16 + self optionalButtonHeight). 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' stamp: 'sbw 12/23/1999 09:50'! optionalAnnotationHeight ^ 10! ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 08:31'! optionalButtonHeight ^ 10! ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/23/1999 09:28'! optionalButtonPairs ^ #(('Proceed' proceed) ('Restart' restart) ('Send' send) ('Step' doStep) ('Full Stack' fullStack) ('Where' where) ('Browse' browseMethodFull))! ! !Debugger methodsFor: 'initialize' stamp: 'jm 10/13/2002 18:05'! optionalButtonRow | aRow aButton | aRow _ AlignmentMorph newRow. aRow isSticky: true. aRow setProperty: #clipToOwnerWidth toValue: true. aButton _ SimpleButtonMorph new target: self. aButton color: Color lightRed; borderWidth: 1; borderColor: Color red darker. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonPairs do: [:pair | aButton _ PluggableButtonMorph on: self getState: nil action: pair second. aButton useRoundedCorners; label: pair first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0)]. ^ aRow! ! !Debugger methodsFor: 'initialize' stamp: 'sbw 12/22/1999 16:20'! preDebugButtonQuads ^ #(('Proceed' proceed blue 'continue execution' ) ('Abandon' abandon black 'close this window') ('Debug' debug red 'bring up a debugger'))! ! !Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'! release self windowIsClosing. super release. ! ! !Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:30'! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. interruptedProcess terminate. interruptedProcess _ nil. interruptedController _ nil. contextStack _ nil. contextStackTop _ nil. receiverInspector _ nil. contextVariablesInspector _ nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'accessing' stamp: 'di 10/9/1998 17:15'! 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: [^ String new]. ^ contents copy! ! !Debugger methodsFor: 'notifier menu' stamp: 'sma 4/30/2000 09:24'! debug "Open a full DebuggerView." | topView | topView _ self topView. topView model: nil. "so close won't release me." Smalltalk isMorphic ifTrue: [self breakDependents. 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)' stamp: 'sw 11/6/1999 22:58'! selectedMessage "Answer the source code of the currently selected context." contents _ [self selectedContext sourceCode] ifError: [ :err :rcvr | 'ERROR "',(err reject: [ :each | each == $"]),'"' ]. Preferences browseWithPrettyPrint ifTrue: [contents _ self selectedClass compilerClass new format: contents in: self selectedClass notifying: nil decorated: Preferences colorWhenPrettyPrinting]. ^ contents _ contents asText makeSelectorBoldIn: self selectedClass! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:04'! abandon "abandon the debugger from its pre-debug notifier" self abandon: self topView! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 12/28/1999 13:05'! abandon: aTopView "abandon the notifier represented by aTopView" aTopView controller close! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 10/12/1999 17:41'! 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. VersionsBrowser browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass meta: self selectedClass isMeta category: self selectedMessageCategoryName selector: selector! ! !Debugger methodsFor: 'context stack menu' stamp: 'sw 5/8/2000 03:02'! contextStackMenu: aMenu shifted: shifted ^ shifted ifFalse: [aMenu labels: 'fullStack (f) restart (r) proceed (p) step (t) send (e) where (w) peel to first like this senders of... (n) implementors of... (m) inheritance (i) versions (v) inst var refs... inst var defs... class var refs... class variables class refs (N) browse full (b) file out more...' lines: #(7 11 13 16 18) selections: #(fullStack restart proceed doStep send where peelToFirst browseSendersOfMessages browseMessages methodHierarchy browseVersions browseInstVarRefs browseInstVarDefs browseClassVarRefs browseClassVariables browseClassRefs browseMethodFull fileOutMessage shiftedYellowButtonActivity)] ifTrue: [aMenu labels: 'browse class hierarchy browse class browse method (O) implementors of sent messages change sets with this method inspect instances inspect subinstances revert to previous version remove from current change set revert and forget more...' lines: #(5 7 10) selections: #(classHierarchy browseClass openSingleMessageBrowser browseAllMessages findMethodInChangeSets inspectInstances inspectSubInstances revertToPreviousVersion removeFromCurrentChanges revertAndForget unshiftedYellowButtonActivity)] ! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 1/14/1999 09:18'! doStep "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: #contentsSelection]] ifFalse: [currentContext completeCallee: currentContext step. self changed: #contentsSelection. self updateInspectors]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 7/18/1999 23:01'! peelToFirst "Peel the stack back to the second occurance of the currently selected message. Very useful for an infinite recursion. Gets back to the second call so you can see one complete recursion cycle, and how it was called at the beginning. Also frees a lot of space!!" | upperGuy meth second | contextStackIndex = 0 ifTrue: [^ self beep]. "self okToChange ifFalse: [^ self]." upperGuy _ contextStack at: contextStackIndex. meth _ upperGuy method. contextStackIndex+1 to: contextStack size do: [:ind | (contextStack at: ind) method == meth ifTrue: [ second _ upperGuy. upperGuy _ contextStack at: ind]]. second ifNil: [second _ upperGuy]. self resetContext: second. interruptedProcess popTo: self selectedContext.! ! !Debugger methodsFor: 'code pane' stamp: 'jm 11/24/2003 17:44'! 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 _ Compiler new parse: contents 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: 'dependents access' stamp: 'di 1/14/1999 09:28'! step "Update the inspectors." receiverInspector ifNotNil: [receiverInspector step]. contextVariablesInspector ifNotNil: [contextVariablesInspector step]. ! ! !Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:25'! wantsSteps ^ true! ! !Debugger methodsFor: 'private' stamp: 'sw 9/23/1999 15:58'! contextStackIndex: anInteger oldContextWas: oldContext | newMethod | contextStackIndex _ anInteger. anInteger = 0 ifTrue: [tempNames _ sourceMap _ contents _ nil. self changed: #contextStackIndex. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^self]. (newMethod _ oldContext == nil or: [oldContext method ~~ self selectedContext method]) ifTrue: [tempNames _ sourceMap _ nil. contents _ self selectedMessage. self contentsChanged. 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' stamp: 'jm 10/7/2002 05:53'! process: aProcess controller: aController context: aContext super initialize. Smalltalk at: #MessageTally ifPresent: [:c | c new close]. contents _ nil. interruptedProcess _ aProcess. interruptedController _ aController. contextStackTop _ aContext. self newStack: (contextStackTop stackOfSize: 1). contextStackIndex _ 1. externalInterrupt _ false. selectingPC _ true. ! ! !Debugger methodsFor: 'private' stamp: 'jm 10/7/2002 05:52'! resumeProcess: aTopView Smalltalk isMorphic ifFalse: [aTopView erase]. savedCursor ifNotNil: [Sensor currentCursor: savedCursor]. interruptedProcess suspendedContext method == (Process compiledMethodAt: #terminate) ifFalse: [contextStackIndex > 1 ifTrue: [interruptedProcess popTo: self selectedContext] ifFalse: [interruptedProcess install: self selectedContext]. Smalltalk isMorphic ifTrue: [Project current resumeProcess: interruptedProcess] ifFalse: [ScheduledControllers activeControllerNoTerminate: interruptedController andProcess: interruptedProcess]]. "if old process was terminated, just terminate current one" interruptedProcess _ nil. "Before delete, so release doesn't terminate it" Smalltalk isMorphic ifTrue: [aTopView delete. World displayWorld] ifFalse: [aTopView controller closeAndUnscheduleNoErase]. Smalltalk installLowSpaceWatcher. "restart low space handler" Processor terminateActive ! ! !Debugger class methodsFor: 'class initialization' stamp: 'di 1/14/1999 09:17'! initialize ErrorRecursion _ false. ContextStackKeystrokes _ Dictionary new at: $e put: #send; at: $t put: #doStep; 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 10/7/2002 05:55'! context: aContext "Answer an instance of me for debugging the active process starting with the given context." ^ self new process: Processor activeProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers inActiveControllerProcess]) ifTrue: [ScheduledControllers activeController] ifFalse: [nil]) context: aContext ! ! !Debugger class methodsFor: 'opening' stamp: 'jm 10/7/2002 05:56'! 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." "Simulation guard" ErrorRecursion not & Preferences logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext to: 'SqueakDebug.log']. 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: 'ar 5/1/1999 09:25'! 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 | "Simulation guard" debugger _ self new. debugger process: interruptedProcess controller: ((Smalltalk isMorphic not and: [ScheduledControllers activeControllerProcess == interruptedProcess]) ifTrue: [ScheduledControllers activeController]) context: interruptedProcess suspendedContext. debugger externalInterrupt: true. Preferences logDebuggerStackToFile ifTrue: [(aString includesSubString: 'Space') & (aString includesSubString: 'low') ifTrue: [ Smalltalk logError: aString inContext: debugger interruptedContext to:'LowSpaceDebug.log']]. ^ debugger openNotifierContents: debugger interruptedContext shortStack label: aString ! ! 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: 'instruction decoding' stamp: 'di 2/5/2000 09:34'! doPop stack isEmpty ifTrue: ["Ignore pop in first leg of ifNil for value" ^ self]. stack last == CaseFlag ifTrue: [stack removeLast] ifFalse: [statements addLast: stack removeLast].! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'di 2/6/2000 08:46'! jump: dist if: condition | savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump elseJump condHasValue b isIfNil saveStack | 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]. pc _ savePc. ifExpr _ stack removeLast. (stack size > 0 and: [stack last == IfNilFlag]) ifTrue: [stack removeLast. isIfNil _ true] ifFalse: [isIfNil _ false]. saveStack _ stack. stack _ OrderedCollection new. thenBlock _ self blockTo: elseStart. condHasValue _ hasValue or: [isIfNil]. "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: ["Must be a while loop... 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." stack _ saveStack. 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: ["Must be a conditional..." elseBlock _ self blockTo: thenJump. elseJump _ exit. "if elseJump is backwards, it is not part of the elseExpr" elseJump < elsePc ifTrue: [pc _ lastPc]. isIfNil ifTrue: [cond _ constructor codeMessage: ifExpr ifNilReceiver selector: (sign ifTrue: [constructor codeSelector: #ifNotNil: code: #macro] ifFalse: [constructor codeSelector: #ifNil: code: #macro]) arguments: (Array with: thenBlock)] ifFalse: [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])]. stack _ saveStack. condHasValue ifTrue: [stack addLast: cond] ifFalse: [statements addLast: cond]]! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'th 3/17/2000 20:48'! methodReturnTop | last | last _ stack removeLast "test test" asReturnNode. 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' stamp: 'di 1/29/2000 08:38'! send: selector super: superFlag numArgs: numArgs | args rcvr selNode msgNode messages | 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: ["May actually be a cascade or an ifNil: for value." self willJumpIfFalse ifTrue: "= generated by a case macro" [selector == #= ifTrue: [" = signals a case statement..." statements addLast: args first. stack addLast: rcvr. "restore CascadeFlag" ^ self]. selector == #== ifTrue: [" == signals an ifNil: for value..." stack removeLast; removeLast. rcvr _ stack removeLast. stack addLast: IfNilFlag; addLast: (constructor codeMessage: rcvr selector: selNode arguments: args). ^ self]. self error: 'bad case: ', selector] ifFalse: [(self willJumpIfTrue and: [selector == #==]) ifTrue: [" == signals an ifNotNil: for value..." stack removeLast; removeLast. rcvr _ stack removeLast. stack addLast: IfNilFlag; addLast: (constructor codeMessage: rcvr selector: selNode arguments: args). ^ self]. 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 _ constructor codeMessage: rcvr selector: selNode arguments: args]. stack addLast: msgNode]! ! !Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 11:06'! convertToDoLoop "If statements contains the pattern var _ startExpr. [var <= limit] whileTrue: [...statements... var _ var + incConst] then replace this by startExpr to: limit by: incConst do: [:var | ...statements...]" | initStmt toDoStmt limitStmt | statements size < 2 ifTrue: [^ self]. initStmt _ statements at: statements size-1. (toDoStmt _ statements last toDoFromWhileWithInit: initStmt) == nil ifTrue: [^ self]. initStmt variable scope: -1. "Flag arg as block temp" statements removeLast; removeLast; addLast: toDoStmt. "Attempt further conversion of the pattern limitVar _ limitExpr. startExpr to: limitVar by: incConst do: [:var | ...statements...] to startExpr to: limitExpr by: incConst do: [:var | ...statements...]" statements size < 2 ifTrue: [^ self]. limitStmt _ statements at: statements size-1. ((limitStmt isMemberOf: AssignmentNode) and: [limitStmt variable isTemp and: [limitStmt variable == toDoStmt arguments first and: [self methodRefersOnlyOnceToTemp: limitStmt variable fieldOffset]]]) ifFalse: [^ self]. toDoStmt arguments at: 1 put: limitStmt value. limitStmt variable scope: -2. "Flag limit var so it won't print" statements removeLast; removeLast; addLast: toDoStmt. ! ! !Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 08:49'! interpretNextInstructionFor: client | code varNames | "Change false here will trace all state in Transcript." true ifTrue: [^ super interpretNextInstructionFor: client]. varNames _ Decompiler allInstVarNames. code _ (self method at: pc) radix: 16. Transcript cr; cr; print: pc; space; nextPutAll: '<' , (code copyFrom: 4 to: code size) , '>'. 8 to: varNames size do: [:i | i <= 10 ifTrue: [Transcript cr] ifFalse: [Transcript space; space]. Transcript nextPutAll: (varNames at: i); nextPutAll: ': '; print: (self instVarAt: i)]. Transcript endEntry. ^ super interpretNextInstructionFor: client! ! !Decompiler methodsFor: 'private' stamp: 'di 2/6/2000 10:55'! methodRefersOnlyOnceToTemp: offset | nRefs byteCode extension scanner | nRefs _ 0. offset <= 15 ifTrue: [byteCode _ 16 + offset. (InstructionStream on: method) scanFor: [:instr | instr = byteCode ifTrue: [nRefs _ nRefs + 1]. nRefs > 1]] ifFalse: [extension _ 64 + offset. scanner _ InstructionStream on: method. scanner scanFor: [:instr | (instr = 128 and: [scanner followingByte = extension]) ifTrue: [nRefs _ nRefs + 1]. nRefs > 1]]. ^ nRefs = 1 ! ! !Decompiler methodsFor: 'private' stamp: 'di 12/26/1998 21:29'! quickMethod | | method isReturnSpecial ifTrue: [^ constructor codeBlock: (Array with: (constTable at: method primitive - 255)) returns: true]. method isReturnField ifTrue: [^ constructor codeBlock: (Array with: (constructor codeInst: method returnField)) returns: true]. self error: 'improper short method'! ! !Decompiler class methodsFor: 'class initialization' stamp: 'di 1/28/2000 22:21'! initialize CascadeFlag _ 'cascade'. "A unique object" CaseFlag _ 'case'. "Ditto" ArgumentFlag _ 'argument'. "Ditto" IfNilFlag _ 'ifNil'. "Ditto" "Decompiler initialize"! ! I construct the node tree for a Decompiler.! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'! codeBlock: statements returns: returns ^ BlockNode statements: statements returns: returns! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'di 11/19/1999 11:06'! codeCascade: receiver messages: messages ^ (BraceNode new matchBraceStreamReceiver: receiver messages: messages) ifNil: [CascadeNode new receiver: receiver messages: messages]! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:35'! codeEmptyBlock ^ BlockNode withJust: NodeNil! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'! codeMessage: receiver selector: selector arguments: arguments | symbol node | symbol _ selector key. (node _ BraceNode new matchBraceWithReceiver: receiver selector: symbol arguments: arguments) ifNotNil: [^ node]. (node _ self decodeIfNilWithReceiver: receiver selector: symbol arguments: arguments) ifNotNil: [^ node]. ^ MessageNode new receiver: receiver selector: selector arguments: arguments precedence: symbol precedence! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 2/5/2000 12:37'! codeMethod: selector block: block tempVars: vars primitive: primitive class: class | node | node _ self codeSelector: selector code: nil. tempVars _ vars. ^MethodNode new selector: node arguments: (tempVars copyFrom: 1 to: nArgs) precedence: selector 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' stamp: 'di 1/28/2000 21:23'! decodeIfNilWithReceiver: receiver selector: selector arguments: arguments selector == #ifTrue:ifFalse: ifFalse: [^ nil]. (receiver isMessage: #== receiver: nil arguments: [:argNode | argNode == NodeNil]) ifFalse: [^ nil]. ^ (MessageNode new receiver: receiver selector: (SelectorNode new key: #ifTrue:ifFalse: code: #macro) arguments: arguments precedence: 3) noteSpecialSelector: #ifNil:ifNotNil:! ! !DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:30'! flush "Force compression" self deflateBlock.! ! !DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/31/1999 18:00'! initialize blockStart _ nil. blockPosition _ 0. hashValue _ 0. self initializeHashTables.! ! !DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:32'! initializeHashTables hashHead _ WordArray new: 1 << HashBits. hashTail _ WordArray new: WindowSize. ! ! !DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 17:33'! on: aCollection self initialize. super on: (aCollection species new: WindowSize * 2).! ! !DeflateStream methodsFor: 'initialize-release' stamp: 'ar 12/28/1999 17:34'! on: aCollection from: firstIndex to: lastIndex "Not for DeflateStreams please" ^self shouldNotImplement! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! goodMatchLength "Return the length that is considered to be a 'good' match. Higher values will result in better compression but take more time." ^MaxMatch "Best compression"! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:00'! hashChainLength "Return the max. number of hash chains to traverse. Higher values will result in better compression but take more time." ^4096 "Best compression"! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 17:33'! nextPutAll: aCollection | start count max | aCollection species = collection species ifFalse:[ aCollection do:[:ch| self nextPut: ch]. ^aCollection]. start _ 1. count _ aCollection size. [count = 0] whileFalse:[ position = writeLimit ifTrue:[self deflateBlock]. max _ writeLimit - position. max > count ifTrue:[max _ count]. collection replaceFrom: position+1 to: position+max with: aCollection startingAt: start. start _ start + max. count _ count - max. position _ position + max]. ^aCollection! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'! pastEndPut: anObject self deflateBlock. ^self nextPut: anObject! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 20:24'! compare: here with: matchPos min: minLength "Compare the two strings and return the length of matching characters. minLength is a lower bound for match lengths that will be accepted. Note: here and matchPos are zero based." | length | "First test if we can actually get longer than minLength" (collection at: here+minLength+1) = (collection at: matchPos+minLength+1) ifFalse:[^0]. (collection at: here+minLength) = (collection at: matchPos+minLength) ifFalse:[^0]. "Then test if we have an initial match at all" (collection at: here+1) = (collection at: matchPos+1) ifFalse:[^0]. (collection at: here+2) = (collection at: matchPos+2) ifFalse:[^1]. "Finally do the real comparison" length _ 3. [length <= MaxMatch and:[ (collection at: here+length) = (collection at: matchPos+length)]] whileTrue:[length _ length + 1]. ^length - 1! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/31/1999 18:00'! deflateBlock "Deflate the current contents of the stream" | flushNeeded lastIndex | (blockStart == nil) ifTrue:[ "One time initialization for the first block" 1 to: MinMatch-1 do:[:i| self updateHashAt: i]. blockStart _ 0]. [blockPosition < position] whileTrue:[ (position + MaxMatch > writeLimit) ifTrue:[lastIndex _ writeLimit - MaxMatch] ifFalse:[lastIndex _ position]. flushNeeded _ self deflateBlock: lastIndex-1 chainLength: self hashChainLength goodMatch: self goodMatchLength. flushNeeded ifTrue:[ self flushBlock. blockStart _ blockPosition]. "Make room for more data" self moveContentsToFront]. ! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 18:05'! deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch "Continue deflating the receiver's collection from blockPosition to lastIndex. Note that lastIndex must be at least MaxMatch away from the end of collection" | here matchResult flushNeeded hereMatch hereLength newMatch newLength hasMatch | blockPosition > lastIndex ifTrue:[^false]. "Nothing to deflate" hasMatch _ false. here _ blockPosition. [here <= lastIndex] whileTrue:[ hasMatch ifFalse:[ "Find the first match" matchResult _ self findMatch: here lastLength: MinMatch-1 lastMatch: here chainLength: chainLength goodMatch: goodMatch. self insertStringAt: here. "update hash table" hereMatch _ matchResult bitAnd: 16rFFFF. hereLength _ matchResult bitShift: -16]. "Look ahead if there is a better match at the next position" matchResult _ self findMatch: here+1 lastLength: hereLength lastMatch: hereMatch chainLength: chainLength goodMatch: goodMatch. newMatch _ matchResult bitAnd: 16rFFFF. newLength _ matchResult bitShift: -16. "Now check if the next match is better than the current one. If not, output the current match (provided that the current match is at least MinMatch long)" (hereLength >= newLength and:[hereLength >= MinMatch]) ifTrue:[ self assert:[self validateMatchAt: here from: hereMatch to: hereMatch + hereLength - 1]. "Encode the current match" flushNeeded _ self encodeMatch: hereLength distance: here - hereMatch. "Insert all strings up to the end of the current match. Note: The first string has already been inserted." 1 to: hereLength-1 do:[:i| self insertStringAt: (here _ here + 1)]. hasMatch _ false. here _ here + 1. ] ifFalse:[ "Either the next match is better than the current one or we didn't have a good match after all (e.g., current match length < MinMatch). Output a single literal." flushNeeded _ self encodeLiteral: (collection byteAt: (here + 1)). here _ here + 1. (here <= lastIndex and:[flushNeeded not]) ifTrue:[ "Cache the results for the next round" self insertStringAt: here. hasMatch _ true. hereMatch _ newMatch. hereLength _ newLength]. ]. flushNeeded ifTrue:[blockPosition _ here. ^true]. ]. blockPosition _ here. ^false! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:45'! findMatch: here lastLength: lastLength lastMatch: lastMatch chainLength: maxChainLength goodMatch: goodMatch "Find the longest match for the string starting at here. If there is no match longer than lastLength return lastMatch/lastLength. Traverse at most maxChainLength entries in the hash table. Stop if a match of at least goodMatch size has been found." | matchResult matchPos distance chainLength limit bestLength length | "Compute the default match result" matchResult _ (lastLength bitShift: 16) bitOr: lastMatch. "There is no way to find a better match than MaxMatch" lastLength >= MaxMatch ifTrue:[^matchResult]. "Start position for searches" matchPos _ hashHead at: (self updateHashAt: here + MinMatch) + 1. "Compute the distance to the (possible) match" distance _ here - matchPos. "Note: It is required that 0 < distance < MaxDistance" (distance > 0 and:[distance < MaxDistance]) ifFalse:[^matchResult]. chainLength _ maxChainLength. "Max. nr of match chain to search" here > MaxDistance "Limit for matches that are too old" ifTrue:[limit _ here - MaxDistance] ifFalse:[limit _ 0]. "Best match length so far (current match must be larger to take effect)" bestLength _ lastLength. ["Compare the current string with the string at match position" length _ self compare: here with: matchPos min: bestLength. "Truncate accidental matches beyound stream position" (here + length > position) ifTrue:[length _ position - here]. "Ignore very small matches if they are too far away" (length = MinMatch and:[(here - matchPos) > (MaxDistance // 4)]) ifTrue:[length _ MinMatch - 1]. length > bestLength ifTrue:["We have a new (better) match than before" "Compute the new match result" matchResult _ (length bitShift: 16) bitOr: matchPos. bestLength _ length. "There is no way to find a better match than MaxMatch" bestLength >= MaxMatch ifTrue:[^matchResult]. "But we may have a good, fast match" bestLength > goodMatch ifTrue:[^matchResult]. ]. (chainLength _ chainLength - 1) > 0] whileTrue:[ "Compare with previous entry in hash chain" matchPos _ hashTail at: (matchPos bitAnd: WindowMask) + 1. matchPos <= limit ifTrue:[^matchResult]. "Match position is too old" ]. ^matchResult! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:37'! flushBlock "Flush a deflated block"! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:46'! insertStringAt: here "Insert the string at the given start position into the hash table. Note: The hash value is updated starting at MinMatch-1 since all strings before have already been inserted into the hash table (and the hash value is updated as well)." | prevEntry | hashValue _ self updateHashAt: (here + MinMatch). prevEntry _ hashHead at: hashValue+1. hashHead at: hashValue+1 put: here. hashTail at: (here bitAnd: WindowMask)+1 put: prevEntry.! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:48'! updateHash: nextValue "Update the running hash value based on the next input byte. Return the new updated hash value." ^((hashValue bitShift: HashShift) bitXor: nextValue) bitAnd: HashMask.! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/29/1999 17:47'! updateHashAt: here "Update the hash value at position here (one based)" ^self updateHash: (collection byteAt: here)! ! !DeflateStream methodsFor: 'deflating' stamp: 'ar 12/28/1999 17:43'! validateMatchAt: pos from: startPos to: endPos | here | here _ pos. startPos+1 to: endPos+1 do:[:i| (collection at: i) = (collection at: (here _ here + 1)) ifFalse:[^self error:'Not a match']]. ^true! ! !DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! encodeLiteral: literal "Encode the given literal. Return true if the current block needs to be flushed." ^false! ! !DeflateStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:04'! encodeMatch: matchLength distance: matchDistance "Encode a match of the given length and distance. Return true if the current block should be flushed." ^false! ! !DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 17:50'! moveContentsToFront "Move the contents of the receiver to the front" | delta | delta _ (blockPosition - WindowSize). delta <= 0 ifTrue:[^self]. "Move collection" collection replaceFrom: 1 to: collection size - delta with: collection startingAt: delta+1. position _ position - delta. "Move hash table entries" blockPosition _ blockPosition - delta. blockStart _ blockStart - delta. self updateHashTable: hashHead delta: delta. self updateHashTable: hashTail delta: delta.! ! !DeflateStream methodsFor: 'private' stamp: 'ar 12/29/1999 20:15'! updateHashTable: table delta: delta | pos | 1 to: table size do:[:i| "Discard entries that are out of range" (pos _ table at: i) >= delta ifTrue:[table at: i put: pos - delta] ifFalse:[table at: i put: 0]].! ! !DeflateStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 00:24'! initialize "DeflateStream initialize" #( WindowSize WindowMask MaxDistance MinMatch MaxMatch HashBits HashMask HashShift ) do:[:sym| ZipConstants declare: sym from: Undeclared. ]. WindowSize _ 16r8000. WindowMask _ WindowSize - 1. MaxDistance _ WindowSize. MinMatch _ 3. MaxMatch _ 258. HashBits _ 15. HashMask _ (1 << HashBits) - 1. HashShift _ (HashBits + MinMatch - 1) // MinMatch. ! ! !Delay class methodsFor: 'instance creation' stamp: 'di 6/16/1999 23:04'! forSeconds: aNumber "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." aNumber < 0 ifTrue: [self error: 'delay times cannot be negative']. ^ self new setDelay: (aNumber * 1000) asInteger forSemaphore: Semaphore new ! ! !Delay class methodsFor: 'utilities' stamp: 'jm 6/22/2003 08:17'! waitMSecs: mSecs "Delay for the given number of milliseconds. For convenience." (Delay forMilliseconds: mSecs) wait. ! ! !Delay class methodsFor: 'testing' stamp: 'ar 9/6/1999 17:05'! anyActive "Return true if there is any delay currently active" ^ActiveDelay notNil! ! 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' stamp: 'tk 4/9/1999 10:22'! associationDeclareAt: aKey "Return an existing association, or create and return a new one. Needed as a single message by ImageSegment.prepareToBeSaved." | existing | ^ self associationAt: aKey ifAbsent: [ (Undeclared includesKey: aKey) ifTrue: [existing _ Undeclared associationAt: aKey. Undeclared removeKey: aKey. self add: existing] ifFalse: [self add: aKey -> false]]! ! !Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 14:59'! at: key ifAbsent: aBlock "Answer the value associated with the key or, if key isn't found, answer the result of evaluating aBlock." | assoc | assoc _ array at: (self findElementOrNil: key). assoc ifNil: [^ aBlock value]. ^ assoc value! ! !Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:01'! at: key ifAbsentPut: aBlock "Return the value at the given key. If key is not included in the receiver store the result of evaluating aBlock as new value." ^ self at: key ifAbsent: [self at: key put: aBlock value]! ! !Dictionary methodsFor: 'accessing' stamp: 'sma 5/12/2000 15:00'! 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 assoc | index _ self findElementOrNil: key. assoc _ array at: index. assoc ifNil: [self atNewIndex: index put: (Association key: key value: anObject)] ifNotNil: [assoc value: anObject]. ^ anObject! ! !Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'! keyAtIdentityValue: value "Answer the key that is the external name for the argument, value. If there is none, answer nil. Note: There can be multiple keys with the same value. Only one is returned." ^self keyAtIdentityValue: value ifAbsent: [self errorValueNotFound]! ! !Dictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:16'! keyAtIdentityValue: 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. Note: There can be multiple keys with the same value. Only one is returned." self associationsDo: [:association | value == association value ifTrue: [^association key]]. ^exceptionBlock value! ! !Dictionary methodsFor: 'accessing' stamp: 'di 3/8/2000 09:12'! keysSortedSafely "Answer a SortedCollection containing the receiver's keys." | sortedKeys | sortedKeys _ SortedCollection new: self size. sortedKeys sortBlock: [ :x :y | "Should really be use compareSafely..." (((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 ] ] ]. self keysDo: [ :aKey | sortedKeys add: aKey. ]. ^ sortedKeys ! ! !Dictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 07:28'! values "Answer a Collection containing the receiver's values." | out | out _ WriteStream on: (Array new: self size). self valuesDo: [:value | out nextPut: value]. ^ out contents! ! !Dictionary methodsFor: 'testing' stamp: 'bf 8/20/1999 15:07'! hasContentsInExplorer ^self isEmpty not! ! !Dictionary methodsFor: 'removing' stamp: 'di 4/4/2000 11:47'! keysAndValuesRemove: keyValueBlock "Removes all entries for which keyValueBlock returns true." "When removing many items, you must not do it while iterating over the dictionary, since it may be changing. This method takes care of tallying the removals in a first pass, and then performing all the deletions afterward. Many places in the sytem could be simplified by using this method." | removals | removals _ OrderedCollection new. self associationsDo: [:assoc | (keyValueBlock value: assoc key value: assoc value) ifTrue: [removals add: assoc key]]. removals do: [:aKey | self removeKey: aKey]! ! !Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 08:04'! keysAndValuesDo: aBlock ^self associationsDo:[:assoc| aBlock value: assoc key value: assoc value].! ! !Dictionary methodsFor: 'enumerating' stamp: 'ar 7/11/1999 07:29'! valuesDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association value]! ! !Dictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:52'! printElementsOn: aStream aStream nextPut: $(. self keysSortedSafely do: [:key | aStream print: key; nextPutAll: '->'; print: (self at: key); space]. aStream nextPut: $)! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'di 3/8/2000 09:14'! calculateKeyArray "Recalculate the KeyArray from the object being inspected" keyArray _ object keysSortedSafely asArray. selectionIndex _ 0. ! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:25'! contentsIsString "Hacked so contents empty when deselected" ^ (selectionIndex = 0)! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'ar 12/7/1999 18:12'! selection selectionIndex = 0 ifTrue: [^ '']. ^ object at: (keyArray at: selectionIndex) ifAbsent:[nil]! ! !DictionaryInspector methodsFor: 'menu' stamp: 'di 4/28/1999 11:32'! 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 clipboardTextPut: sel asText. "no undo allowed"! ! I represent an entry in a directory for either a file or a subdirectory. ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 22:29'! at: index "compatibility interface" "self halt: 'old-style access to DirectoryEntry'" index = 1 ifTrue: [ ^self name ]. index = 2 ifTrue: [ ^self creationTime ]. index = 3 ifTrue: [ ^self modificationTime ]. index = 4 ifTrue:[ ^self isDirectory ]. index = 5 ifTrue:[ ^self fileSize ]. self error: 'invalid index specified'.! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 21:37'! creationTime "time the entry was created. (what's its type?)" ^creationTime! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 21:38'! fileSize "size of the entry, if it's a file" ^fileSize! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 21:38'! isDirectory "whether this entry represents a directory" ^dirFlag! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 21:37'! modificationTime "time the entry was last modified" ^modificationTime! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 21:37'! name "name of the entry" ^name! ! !DirectoryEntry methodsFor: 'accessing' stamp: 'ls 7/15/1998 22:16'! size ^5! ! !DirectoryEntry methodsFor: 'private' stamp: 'jm 11/14/2003 12:41'! privateName: aString creationTime: cTime modificationTime: mTime isDirectory: isDir fileSize: fSize name _ aString. creationTime _ cTime. modificationTime _ mTime. dirFlag _ isDir. fileSize _ fSize. ! ! !DirectoryEntry class methodsFor: 'instance creation' stamp: 'jm 11/14/2003 12:39'! fromArray: anArray ^ self new privateName: (anArray at: 1) creationTime: (anArray at: 2) modificationTime: (anArray at: 3) isDirectory: (anArray at: 4) fileSize: (anArray at: 5) ! ! The abstract protocol for most display primitives that are used by Views for presenting information on the screen.! !DisplayObject methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:24'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's display area." ^ self computeBoundingBox ! ! !DisplayObject methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:23'! computeBoundingBox "Answer the rectangular area that represents the boundaries of the receiver's area for displaying information. Clients generally send 'boundingBox' instead of this message." self subclassResponsibility ! ! !DisplayObject methodsFor: 'displaying' stamp: 'jm 11/25/2002 16:18'! display "Display the receiver on the Display at 0@0 using the paint rule." self displayOn: Display at: 0@0 rule: Form paint. ! ! !DisplayObject methodsFor: 'displaying' stamp: 'jm 5/25/2003 12:04'! displayAt: aDisplayPoint "Display the receiver located at aDisplayPoint with default settings for the displayMedium, rule and halftone." self displayOn: Display at: aDisplayPoint. ! ! !DisplayObject methodsFor: 'animation' stamp: 'jm 5/29/2003 17:58'! 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. Display deferUpdates: true. self displayOn: Display at: location rule: Form paint. Display deferUpdates: false; forceToScreen: (location extent: self extent). [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. bufferBlt copyForm: self to: rect2 origin - bothRects origin rule: Form paint. Display deferUpdates: true. Display copy: bothRects from: 0@0 in: buffer rule: Form over. Display deferUpdates: false; forceToScreen: bothRects] ifFalse: [ "when no overlap, do the simple thing (both rects might be too big)" Display deferUpdates: true. 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. Display deferUpdates: false; forceToScreen: (location extent: save1 extent); forceToScreen: (newLoc extent: self extent)]. location _ newLoc. rect1 _ rect2]]. ^ save1 displayOn: Display at: location ! ! My instances are used to scan text and display it on the screen or in a hidden form.! !DisplayScanner methodsFor: 'scanning' stamp: 'jm 7/23/2003 01:50'! 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 startIndex string lastPos | line _ textLine. morphicOffset _ offset. leftMargin _ (line leftMarginForAlignment: textStyle alignment) + offset x. destX _ runX _ 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. self handleIndentation. done _ false. string _ text string. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "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: 'jm 7/22/2003 20:49'! 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 startIndex string lastPos | "leftInRun is the # of characters left to scan in the current run; when 0, it is time to call 'self setStopConditions'" leftInRun _ 0. self initializeFromParagraph: aParagraph clippedBy: visibleRectangle. ignoreColorChanges _ false. paragraph _ aParagraph. foregroundColor _ paragraphColor _ aParagraph foregroundColor. backgroundColor _ aParagraph backgroundColor. aParagraph backgroundColor isTransparent ifTrue: [fillBlt _ nil] ifFalse: [fillBlt _ bitBlt 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. destX _ (runX _ 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. string _ text string. self handleIndentation. [done] whileFalse:[ startIndex _ lastIndex. lastPos _ destX@destY. stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ font displayString: string on: bitBlt from: startIndex to: lastIndex at: lastPos kern: kern]. "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: 'ar 5/17/2000 17:36'! placeEmbeddedObject: anchoredMorph (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset] ifFalse: [destY _ lineY. runX _ destX. anchoredMorph displayOn: bitBlt destForm at: destX - anchoredMorph width @ destY]. ^ true! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 17:36'! 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 + font height); height: (lineY + lineHeight) - (destY + font height); copyBits. ! ! !DisplayScanner methodsFor: 'private' stamp: 'jm 5/29/2003 17:58'! initializeFromParagraph: aParagraph clippedBy: clippingRectangle super initializeFromParagraph: aParagraph clippedBy: clippingRectangle. bitBlt _ BitBlt toForm: aParagraph destinationForm. bitBlt fillColor: aParagraph fillColor. "sets halftoneForm" bitBlt combinationRule: aParagraph rule. bitBlt clipRect: clippingRectangle. ! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 19:26'! setDestForm: df bitBlt setDestForm: df.! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 18:57'! setFont foregroundColor _ paragraphColor. super setFont. "Sets font and emphasis bits, and maybe foregroundColor" font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: backgroundColor. text ifNotNil:[destY _ lineY + line baseline - font ascent]! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 5/17/2000 20:25'! setPort: aBitBlt "Install the BitBlt to use" bitBlt _ aBitBlt. bitBlt sourceForm: nil. "Make sure font installation won't be confused" ! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode text _ t. textStyle _ ts. foregroundColor _ paragraphColor _ foreColor. (backgroundColor _ backColor) isTransparent ifFalse: [fillBlt _ blt. fillBlt fillColor: backgroundColor]. ignoreColorChanges _ shadowMode! ! !DisplayScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:51'! textColor: textColor ignoreColorChanges ifTrue: [^ self]. foregroundColor _ textColor! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 5/19/2000 14:46'! characterNotInFont "See the note in CharacterScanner>>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 lastPos | saveIndex _ lastIndex. lastPos _ destX @ destY. illegalAsciiString _ String with: (font maxAscii + 1) asCharacter. stopCondition _ self scanCharactersFrom: 1 to: 1 in: illegalAsciiString rightX: rightMargin stopConditions: stopConditions kern: kern. font displayString: illegalAsciiString on: bitBlt from: 1 to: 1 at: lastPos kern: kern. lastIndex _ saveIndex + 1. stopCondition ~= (stopConditions at: EndOfRun) ifTrue: [^self perform: stopCondition] ifFalse: [lastIndex = runStopIndex ifTrue: [^self perform: (stopConditions at: EndOfRun)]. ^false] ! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:42'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." lastIndex_ lastIndex + 1. ^false! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:42'! 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: 'ar 1/9/2000 13:56'! 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: 'ar 5/17/2000 17:36'! 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 _ oldX + spaceWidth + (line justifiedPadFor: spaceCount). fillBlt == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'jm 7/23/2003 16:20'! plainTab | oldX | oldX _ destX. super plainTab. fillBlt ifNotNil: [ fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]. ! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 5/18/2000 16:47'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. textStyle alignment = Justified ifTrue:[ "Make a local copy of stop conditions so we don't modify the default" stopConditions == DefaultStopConditions ifTrue:[stopConditions _ stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace]! ! !DisplayScanner methodsFor: 'stop conditions' stamp: 'ar 5/17/2000 17:36'! 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: font height; copyBits]. lastIndex _ lastIndex + 1. ^ false! ! !DisplayScanner methodsFor: 'quick print' stamp: 'ar 5/18/2000 18:00'! drawString: aString at: aPoint "Draw the given string." destX _ aPoint x asInteger. destY _ aPoint y asInteger. self primScanCharactersFrom: 1 to: aString size in: aString rightX: bitBlt clipX + bitBlt clipWidth + font maxWidth stopConditions: stopConditions kern: kern. font displayString: aString on: bitBlt from: 1 to: lastIndex at: aPoint kern: kern.! ! !DisplayScanner methodsFor: 'quick print' stamp: 'ar 5/17/2000 17:41'! lineHeight "Answer the height of the font used by QuickPrint." ^ font height! ! !DisplayScanner methodsFor: 'quick print' stamp: 'jm 5/29/2003 17:58'! quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor "Initialize myself." bitBlt _ BitBlt toForm: aForm. backgroundColor _ Color transparent. paragraphColor _ textColor. font _ aStrikeFont ifNil: [TextStyle defaultFont]. emphasisCode _ 0. kern _ 0. indentationLevel _ 0. self setFont. "Override cbrule and map" bitBlt combinationRule: Form paint. bitBlt colorMap: (Bitmap with: 0 "Assumes 1-bit deep fonts" with: (textColor pixelValueForDepth: bitBlt destForm depth)). bitBlt clipRect: aRectangle.! ! !DisplayScanner methodsFor: 'quick print' stamp: 'ar 5/18/2000 18:00'! stringWidth: aString "Answer the width of the given string." destX _ destY _ 0. aString ifNil: [^ 0]. self primScanCharactersFrom: 1 to: aString size in: aString rightX: 99999 "virtual infinity" stopConditions: stopConditions kern: kern. ^ destX " (1 to: 10) collect: [:i | QuickPrint new stringWidth: (String new: i withAll: $A)] "! ! !DisplayScanner methodsFor: 'quick print' stamp: 'jm 8/30/2003 21:47'! stringWidth: aString from: startIndex to: endIndex "Answer the width of the given string between the given indices." destX _ destY _ 0. aString ifNil: [^ 0]. self primScanCharactersFrom: startIndex to: endIndex in: aString rightX: 99999 "virtual infinity" stopConditions: stopConditions kern: kern. ^ destX ! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'! defaultFont ^ TextStyle defaultFont! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'! quickPrintOn: aForm "Create an instance to print on the given form in the given rectangle." ^(super new) quickPrintOn: aForm box: aForm boundingBox font: self defaultFont color: Color black! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:39'! quickPrintOn: aForm box: aRectangle "Create an instance to print on the given form in the given rectangle." ^(super new) quickPrintOn: aForm box: aRectangle font: self defaultFont color: Color black! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'! quickPrintOn: aForm box: aRectangle font: aStrikeFont "Create an instance to print on the given form in the given rectangle." ^(super new) quickPrintOn: aForm box: aRectangle font: aStrikeFont color: Color black! ! !DisplayScanner class methodsFor: 'queries' stamp: 'ar 5/17/2000 17:40'! quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor "Create an instance to print on the given form in the given rectangle." ^ (super new) quickPrintOn: aForm box: aRectangle font: aStrikeFont color: textColor! ! !DisplayScanner class methodsFor: 'queries' stamp: 'jm 8/30/2003 21:48'! quickPrintOn: aForm font: aStrikeFont "Create an instance to print on the given form in the given rectangle." ^ super new quickPrintOn: aForm box: aForm boundingBox font: aStrikeFont color: Color black! ! !DisplayScanner class methodsFor: 'examples' stamp: 'ar 5/17/2000 17:41'! example "This will quickly print all the numbers from 1 to 100 on the display, and then answer the default width and height of the string 'hello world'." "NewDisplayScanner example" | scanner | scanner _ self quickPrintOn: Display. 0 to: 99 do: [: i | scanner drawString: i printString at: (i//10*20) @ (i\\10*12) ]. ^ (scanner stringWidth: 'hello world') @ (scanner lineHeight)! ! 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' stamp: 'jm 5/25/2003 11:48'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aColor "Copy the given rectangular area from sourceForm into myself at the given destination point using the given combination rule and fill color." (BitBlt destForm: self sourceForm: sourceForm fillColor: aColor combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: (clipRect intersect: clippingBox)) copyBits. ! ! !DisplayScreen methodsFor: 'displaying' stamp: 'jm 5/29/2003 17:58'! 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: 'other' stamp: 'RAA 11/27/1999 15:48'! displayChangeSignature ^DisplayChangeSignature! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 2/11/1999 18:14'! forceToScreen "Force the entire display area to the screen" ^self forceToScreen: self boundingBox! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:44'! newDepth: pixelSize " Display newDepth: 8. Display newDepth: 1. " (self supportsDisplayDepth: pixelSize) ifFalse:[^self inform:'Display depth ', pixelSize printString, ' is not supported on this system']. self newDepthNoRestore: pixelSize. self restore.! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/1/1999 11:03'! restore Smalltalk isMorphic ifTrue: [World fullRepaintNeeded] ifFalse: [ScheduledControllers unCacheWindows; restore].! ! !DisplayScreen methodsFor: 'other' stamp: 'sma 4/30/2000 09:27'! restoreAfter: aBlock "Evaluate the block, wait for a mouse click, and then restore the screen." aBlock value. Sensor waitButton. Smalltalk isMorphic ifTrue: [World fullRepaintNeeded] ifFalse: [(ScheduledControllers restore; activeController) view emphasize]! ! !DisplayScreen methodsFor: 'other' stamp: 'bf 9/18/1999 19:46'! supportedDisplayDepths "Return all pixel depths supported on the current host platform." ^#(1 2 4 8 16 32) select: [:d | self supportsDisplayDepth: d]! ! !DisplayScreen methodsFor: 'other' stamp: 'ar 5/5/1999 23:45'! supportsDisplayDepth: pixelDepth "Return true if this pixel depth is supported on the current host platform. Primitive. Optional." ^#(1 2 4 8 16 32) includes: pixelDepth! ! !DisplayScreen methodsFor: 'private' stamp: 'di 3/3/1999 10:00'! copyFrom: aForm "Take on all state of aForm, with complete sharing" super copyFrom: aForm. clippingBox _ super boundingBox! ! !DisplayScreen methodsFor: 'private' stamp: 'ar 5/25/2000 23:43'! findAnyDisplayDepth "Return any display depth that is supported on this system." ^self findAnyDisplayDepthIfNone:[ "Ugh .... now this is a biggie - a system that does not support any of the Squeak display depths at all." Smalltalk logError:'Fatal error: This system has no support for any display depth at all.' inContext: thisContext to: 'SqueakDebug.log'. Smalltalk quitPrimitive. "There is no way to continue from here" ].! ! !DisplayScreen methodsFor: 'private' stamp: 'ar 5/25/2000 23:44'! findAnyDisplayDepthIfNone: aBlock "Return any display depth that is supported on this system. If there is none, evaluate aBlock." #(1 2 4 8 16 32) do:[:bpp| (self supportsDisplayDepth: bpp) ifTrue:[^bpp]. ]. ^aBlock value! ! !DisplayScreen methodsFor: 'private' stamp: 'di 4/15/1999 10:58'! 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 ifFalse: [ScheduledControllers scheduledWindowControllers do: [:aController | "This should be refined..." aController view cacheBitsAsTwoTone ifFalse: [area _ area + aController view windowBox area]]]. need _ (area * (pixelSize-depth) // 8) "new bytes needed" + Smalltalk lowSpaceThreshold. (Smalltalk garbageCollectMost <= need and: [Smalltalk garbageCollect <= need]) ifTrue: [self error: 'Insufficient free space']]. self setExtent: self extent depth: pixelSize. Smalltalk isMorphic ifFalse: [ScheduledControllers updateGray]. DisplayScreen startUp! ! !DisplayScreen methodsFor: 'private' stamp: 'jm 6/3/1998 13:00'! primRetryShowRectLeft: 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' stamp: 'jm 6/3/1998 13:02'! 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. If this fails, retry integer coordinates." "if this fails, coerce coordinates to integers and try again" self primRetryShowRectLeft: l truncated right: r rounded top: t truncated bottom: b rounded. ! ! !DisplayScreen methodsFor: 'private' stamp: 'RAA 11/27/1999 15:48'! setExtent: aPoint depth: bitsPerPixel "DisplayScreen startUp" "This method is critical. If the setExtent fails, there will be no proper display on which to show the error condition..." "ar 5/1/1999: ... and that is exactly why we check for the available display depths first." "RAA 27 Nov 99 - if depth and extent are the same and acceptable, why go through this. also - record when we change so worlds can tell if it is time to repaint" (depth == bitsPerPixel and: [aPoint = self extent and: [self supportsDisplayDepth: bitsPerPixel]]) ifFalse: [ bits _ nil. "Free up old bitmap in case space is low" DisplayChangeSignature _ (DisplayChangeSignature ifNil: [0]) + 1. (self supportsDisplayDepth: bitsPerPixel) ifTrue:[super setExtent: aPoint depth: bitsPerPixel] ifFalse:["Search for a suitable depth" super setExtent: aPoint depth: self findAnyDisplayDepth]. ]. clippingBox _ super boundingBox! ! !DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/26/2000 00:07'! release "I am no longer Display. Release any resources if necessary"! ! !DisplayScreen methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 11:25'! shutDown "Minimize Display memory saved in image" self setExtent: 240@120 depth: depth! ! !DisplayScreen class methodsFor: 'display box access' stamp: 'sma 4/30/2000 09:25'! checkForNewScreenSize Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. Smalltalk isMorphic ifTrue: [World restoreDisplay] ifFalse: [ScheduledControllers restore; searchForActiveController]! ! !DisplayScreen class methodsFor: 'display box access' stamp: 'sma 4/28/2000 19:07'! depth: depthInteger width: widthInteger height: heightInteger fullscreen: aBoolean "Force Squeak's window (if there's one) into a new size and depth." "DisplayScreen depth: 8 width: 1024 height: 768 fullscreen: false" self primitiveFail! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'! shutDown "Minimize Display memory saved in image" Display shutDown.! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'di 3/1/1999 17:04'! startUp "DisplayScreen startUp" Display setExtent: self actualScreenSize depth: Display depth. Display beDisplay! ! 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: 'displaying' stamp: 'di 2/2/1999 17:12'! 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 = Form over and: [backColor isTransparent]) ifTrue: [Form paint] ifFalse: [ruleInteger]) fillColor: aForm! ! !DisplayText methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:22'! 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: 'private' stamp: 'jm 7/4/2003 10:40'! composeForm | m form1 | Smalltalk isMorphic ifTrue: [ m _ TextMorph new contentsAsIs: text. form1 _ m imageForm: 1 forRectangle: m fullBounds. form _ (ColorForm extent: form1 extent) offset: offset; colors: (Array with: (backColor == nil ifTrue: [Color transparent] ifFalse: [backColor]) with: (foreColor == nil ifTrue: [Color black] ifFalse: [foreColor])). form1 displayOn: form] ifFalse: [ form _ self asParagraph asForm]. ! ! !DisplayText class methodsFor: 'examples' stamp: 'mjg 4/28/2000 14:31'! example "Continually prints two lines of text wherever you point with the cursor and press any mouse button. Terminate by pressing any button on the mouse." | 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."! ! I represent a view of an instance of DisplayText.! This class represents a base for generic transformations of 2D points between different coordinate systems (including scaling and rotation). The transformations map objects between one coordinate system and another where it is assumed that a nested hierarchy of transformations can be defined. It is assumed that transformations deal with Integer points. All transformations should return Integer coordinates (even though float points may be passed in as argument). Compositions of transformations MUST work in the following order. A 'global' transformation (the argument in #composedWithGlobal:) is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, whereas a 'local' transformation (e.g., the argument in #composedWithLocal:) takes place between the receiver ('global') and any 'local' points. For the transformation methods this means that combining a global and a local transformation will result in the following order: globalPointToLocal: globalPoint "globalPoint -> globalTransform -> localTransform -> locaPoint" ^localTransform globalPointToLocal: (globalTransform globalPointToLocal: globalPoint) localPointToGlobal: localPoint "localPoint -> localTransform -> globalTransform -> globalPoint" ^globalTransform localPointToGlobal: (localTransform localPointToGlobal: localPoint) ! !DisplayTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:18'! setIdentity "Initialize the receiver to the identity transformation (e.g., not affecting points)" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'accessing' stamp: 'ar 11/2/1998 19:43'! inverseTransformation "Return the inverse transformation of the receiver" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:47'! isCompositeTransform "Return true if the receiver is a composite transformation. Composite transformations may have impact on the accuracy." ^false! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:17'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^false! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 22:48'! isMorphicTransform "Return true if the receiver is a MorphicTransform, that is specifies the transformation values explicitly." ^false! ! !DisplayTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 16:16'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:15'! composedWithGlobal: aTransformation "Return the composition of the receiver and the global transformation passed in. A 'global' transformation is defined as a transformation that takes place between the receiver (the 'local') transformation and any 'global' point computations, e.g., for the methods globalPointToLocal: globalPoint globalPoint -> globalTransform -> localTransform -> locaPoint localPointToGlobal: localPoint localPoint -> localTransform -> globalTransform -> globalPoint " ^aTransformation composedWithLocal: self! ! !DisplayTransform methodsFor: 'composing' stamp: 'ar 11/2/1998 16:41'! composedWithLocal: aTransformation "Return the composition of the receiver and the local transformation passed in. A 'local' transformation is defined as a transformation that takes place between the receiver (the 'global') transformation and any 'local' point computations, e.g., for the methods globalPointToLocal: globalPoint globalPoint -> globalTransform -> localTransform -> locaPoint localPointToGlobal: localPoint localPoint -> localTransform -> globalTransform -> globalPoint " self isIdentity ifTrue:[^ aTransformation]. aTransformation isIdentity ifTrue:[^ self]. ^ CompositeTransform new globalTransform: self localTransform: aTransformation! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:17'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! globalPointsToLocal: inArray "Transform all the points of inArray from global into local coordinates" ^inArray collect:[:pt| self globalPointToLocal: pt]! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:18'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'transforming points' stamp: 'ar 11/9/1998 14:35'! localPointsToGlobal: inArray "Transform all the points of inArray from local into global coordinates" ^inArray collect:[:pt| self localPointToGlobal: pt]! ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^Rectangle encompassing: (self globalPointsToLocal: aRectangle corners)! ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'ar 11/2/1998 16:19'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^Rectangle encompassing: (self localPointsToGlobal: aRectangle corners)! ! !DisplayTransform methodsFor: 'transforming rects' stamp: 'di 10/25/1999 12:49'! sourceQuadFor: aRectangle ^ aRectangle innerCorners collect: [:p | self globalPointToLocal: p]! ! !DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:59'! asCompositeTransform "Represent the receiver as a composite transformation" ^CompositeTransform new globalTransform: self localTransform: self species identity! ! !DisplayTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:01'! asMatrixTransform2x3 "Represent the receiver as a 2x3 matrix transformation" ^self subclassResponsibility! ! !DisplayTransform methodsFor: 'encoding' stamp: 'ls 10/9/1999 18:56'! encodeForRemoteCanvas "encode this transform into a string for use by a RemoteCanvas" ^self subclassResponsibility! ! !DisplayTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'! fromRemoteCanvasEncoding: encoded | type | "decode a transform from the given encoded string" type _ (ReadStream on: encoded) upTo: $,. type = 'Morphic' ifTrue: [ ^MorphicTransform fromRemoteCanvasEncoding: encoded ]. type = 'Matrix' ifTrue: [ ^MatrixTransform2x3 fromRemoteCanvasEncoding: encoded ]. type = 'Composite' ifTrue: [ ^CompositeTransform fromRemoteCanvasEncoding: encoded ]. ^self error: 'invalid transform encoding'! ! !DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'! identity ^self new setIdentity! ! !DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'di 6/18/1998 08:57'! checkName: aFileName fixErrors: fixing "Check if the file name contains any invalid characters" | fName badChars hasBadChars | fName _ super checkName: aFileName fixErrors: fixing. badChars _ #( $: $< $> $| $/ $\ $? $* $") asSet. hasBadChars _ fName includesAnyOf: badChars. (hasBadChars and:[fixing not]) ifTrue:[^self error:'Invalid file name']. hasBadChars ifFalse:[^ fName]. ^ fName collect: [:char | (badChars includes: char) ifTrue:[$#] ifFalse:[char]]! ! !DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'ar 12/18/1999 00:52'! fullPathFor: path "Return the fully-qualified path name for the given file." path isEmpty ifTrue:[^pathName]. (path at: 1) = $\ ifTrue:[ (path size >= 2 and:[(path at: 2) = $\]) ifTrue:[^path]. "e.g., \\pipe\" ^(pathName copyFrom: 1 to: 2), path "e.g., \windows\"]. (path size >= 2 and:[(path at: 2) = $: and:[path first isLetter]]) ifTrue:[^path]. "e.g., c:" ^pathName, self slash, path! ! !DosFileDirectory methodsFor: 'as yet unclassified' stamp: 'bf 3/21/2000 17:06'! setPathName: pathString "Ensure pathString is absolute - relative directories aren't supported on all platforms." (pathString isEmpty or: [pathString first = $\ or: [pathString size >= 2 and: [pathString second = $: and: [pathString first isLetter]]]]) ifTrue: [^ super setPathName: pathString]. self error: 'Fully qualified path expected'! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'! isCaseSensitive "Return true if file names are treated case sensitive" ^false! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'sma 3/24/2000 11:15'! isDrive: fullName ^ (fullName size = 2 and: [fullName first isLetter and: [fullName last = $:]]) or: [(fullName beginsWith: '\\') and: [(fullName occurrencesOf: $\) <= 3]]! ! !DosFileDirectory class methodsFor: 'platform specific' stamp: 'sma 3/24/2000 11:15'! splitName: fullName to: pathAndNameBlock (self isDrive: fullName) ifTrue: [^ pathAndNameBlock value: fullName value: '']. ^ super splitName: fullName to: pathAndNameBlock! ! I illustrate the click/drag/double-click capabilities of Morphic. To make a morph respond to a double-click or distinguish between a single click and a drag operation, it should: (1) Respond "true" to #handlesMouseDown: (2) In the mouseDown: method, send #waitForClicksOrDrag:event: to the hand. (3) Reimplement #click: to react to single-clicked mouse-down. (4) Reimplement #doubleClick: to make the appropriate response to a double-click. (5) Reimplement #drag: to react to non-clicks (i.e. dragging). This message is sent continuously until the button is released. You can check the event argument to react differently on the first, intermediate, and final calls.! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 16:51'! balloonText ^ 'Double-click on me to change my color; single-click on me to change border color; hold mouse down within me to grow (if I''m red) or shrink (if I''m blue).'! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 16:46'! click: evt self showBalloon: 'click'. self borderColor: (self borderColor = Color black ifTrue: [Color yellow] ifFalse: [Color black]) ! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'bf 9/28/1999 20:55'! doubleClick: evt self showBalloon: 'doubleClick'. self color: ((color = Color blue) ifTrue: [Color red] ifFalse: [Color blue]) ! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/14/1999 16:05'! handlesMouseDown: evt ^ true! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'sw 9/23/1999 17:55'! initialize super initialize. self color: Color red! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'bf 9/28/1999 17:20'! mouseDown: evt "Do nothing upon mouse-down except inform the hand to watch for a double-click; wait until an ensuing click:, doubleClick:, or drag: message gets dispatched" evt hand waitForClicksOrDrag: self event: evt! ! !DoubleClickExample methodsFor: 'as yet unclassified' stamp: 'mir 6/12/2000 17:53'! startDrag: evt "We'll get a mouseDown first, some mouseMoves, and a mouseUp event last" | oldCenter | evt isMouseDown ifTrue: [self showBalloon: 'drag (mouse down)'. self world displayWorld. (Delay forMilliseconds: 750) wait]. evt isMouseUp ifTrue: [self showBalloon: 'drag (mouse up)']. (evt isMouseUp or: [evt isMouseDown]) ifFalse: [self showBalloon: 'drag (mouse still down)']. (self containsPoint: evt cursorPoint) ifFalse: [^ self]. oldCenter _ self center. color = Color red ifTrue: [self extent: self extent + (1@1)] ifFalse: [self extent: ((self extent - (1@1)) max: (16@16))]. self center: oldCenter! ! I provide a drop-down menu of selections. If my target object is not nil, I update my display string, get a menu of possible choices, and inform the target of a menu selection by sending customizable selectors. ! !DropDownSelectionMorph methodsFor: 'initialization' stamp: 'jm 6/28/2003 12:43'! initialize | m | super initialize. self extent: 72@20. self borderWidth: 1. self color: Color transparent. self useRoundedCorners. fitToLabel _ true. target _ nil. getLabelSelector _ getMenuSelector _ menuChoiceSelector _ nil. m _ ImageMorph new form: DropDownForm. m position: (self position + (5@5)). self addMorph: m. labelMorph _ StringMorph new contents: 'January'. labelMorph position: (self position + (15@3)). self addMorph: labelMorph. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:06'! fitToLabel: aBoolean fitToLabel _ aBoolean. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 13:31'! fixedExtent: aPoint "Turn off label fitting and set my (now fixed) dimensions." fitToLabel _ false. self extent: aPoint. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:38'! getLabelSelector: aSymbolOrNil getLabelSelector _ aSymbolOrNil. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:38'! getMenuSelector: aSymbolOrNil getMenuSelector _ aSymbolOrNil. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:24'! labelString: aString labelMorph contents: aString. fitToLabel ifTrue: [ self extent: (labelMorph bottomRight - self topLeft) + (7@5)]. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:43'! menuChoiceSelector: aSymbolOrNil menuChoiceSelector _ aSymbolOrNil. ! ! !DropDownSelectionMorph methodsFor: 'accessing' stamp: 'jm 6/28/2003 12:39'! target: anObjectOrNil target _ anObjectOrNil. ! ! !DropDownSelectionMorph methodsFor: 'events' stamp: 'jm 6/28/2003 12:47'! handlesMouseDown: evt ^ true ! ! !DropDownSelectionMorph methodsFor: 'events' stamp: 'jm 6/28/2003 22:15'! mouseDown: evt | menu choice | (menu _ self getMenuFromTarget) ifNil: [^ self beep]. choice _ menu build; startUpWithCaption: nil at: (evt cursorPoint x + 2)@(self top + 8). choice notNil & menuChoiceSelector notNil ifTrue: [ target perform: menuChoiceSelector with: choice. self step]. ! ! !DropDownSelectionMorph methodsFor: 'stepping' stamp: 'jm 6/28/2003 12:39'! step | newLabel | ((target == nil) or: [getLabelSelector == nil]) ifTrue: [^ nil]. newLabel _ target perform: getLabelSelector. newLabel ifNil: [^ self]. newLabel _ newLabel asString. newLabel = labelMorph contents ifFalse: [self labelString: newLabel]. ! ! !DropDownSelectionMorph methodsFor: 'private' stamp: 'jm 6/28/2003 12:14'! getMenuFromTarget ((target == nil) or: [getMenuSelector == nil]) ifTrue: [^ nil]. ^ target perform: getMenuSelector ! ! !DropDownSelectionMorph class methodsFor: 'as yet unclassified' stamp: 'jm 6/28/2003 09:28'! initialize "self initialize" DropDownForm _ Form extent: 7@4 depth: 1 fromArray: #(4261412864 2080374784 939524096 268435456) offset: 0@0. ! ! !DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'sw 3/6/1999 09:34'! morphicWindow | 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). ^ window ! ! !DualChangeSorter methodsFor: 'as yet unclassified' stamp: 'sma 4/30/2000 09:29'! open | topView | Smalltalk isMorphic | Sensor leftShiftDown ifTrue: [^ self openAsMorph]. 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: 'as yet unclassified' stamp: 'sw 3/6/1999 09:34'! openAsMorph ^ self morphicWindow openInWorld ! ! I am used to compute the shape of circles and ellispes. ! !EllipseMidpointTracer methodsFor: 'initialize' stamp: 'ar 6/28/1999 15:33'! on: aRectangle rect _ aRectangle. a _ rect width // 2. b _ rect height // 2. x _ 0. y _ b. aSquared _ a * a. bSquared _ b * b. d1 _ bSquared - (aSquared * b) + (0.25 * aSquared). d2 _ nil. inFirstRegion _ true.! ! !EllipseMidpointTracer methodsFor: 'computing' stamp: 'ar 6/28/1999 15:35'! stepInY "Step to the next y value" inFirstRegion ifTrue:[ "In the upper region we must step until we reach the next y value" [(aSquared * (y-0.5)) > (bSquared * (x+1))] whileTrue:[ d1 < 0.0 ifTrue:[d1 _ d1 + (bSquared * (2*x+3)). x _ x + 1] ifFalse:[d1 _ d1 + (bSquared * (2*x+3)) + (aSquared * (-2*y+2)). y _ y - 1. ^x _ x + 1]]. "Stepping into second region" d2 _ (bSquared * (x + 0.5) squared) + (aSquared * (y-1) squared) - (aSquared * bSquared). inFirstRegion _ false. ]. "In the lower region each step is a y-step" d2 < 0.0 ifTrue:[d2 _ d2 + (bSquared * (2*x+2)) + (aSquared * (-2*y+3)). x _ x + 1] ifFalse:[d2 _ d2 + (aSquared * (-2*y+3))]. y _ y - 1. ^x! ! I draw myself as an ellipse or circle with a border. ! !EllipseMorph methodsFor: 'initialization' stamp: 'jm 10/9/2002 05:53'! initialize super initialize. borderColor _ Color black. borderWidth _ 1. color _ Color yellow. ! ! !EllipseMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 06:02'! doesBevels ^ false ! ! !EllipseMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 07:31'! isRectangular ^ false ! ! !EllipseMorph methodsFor: 'drawing' stamp: 'jm 11/24/2002 11:02'! drawOn: aCanvas aCanvas fillOval: bounds color: color borderWidth: borderWidth borderColor: borderColor. ! ! !EllipseMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! A selection menu in which individual selections are allowed to have different emphases. Emphases allowed are: bold, italic, struckThrough, and plain. Provide an emphasis array, with one element per selection, to use. Refer to the class method #example.! !EmphasizedMenu methodsFor: 'emphasis' stamp: 'di 4/13/1999 16:27'! onlyBoldItem: itemNumber "Set up emphasis such that all items are plain except for the given item number. " emphases _ (Array new: selections size) atAllPut: #plain. emphases at: itemNumber put: #bold! ! !EmphasizedMenu methodsFor: 'private' stamp: 'sw 4/5/1999 13:59'! setEmphasis "Set up the receiver to reflect the emphases in the emphases array. " | selStart selEnd currEmphasis | labelString _ labelString asText. emphases isEmptyOrNil ifTrue: [^ self]. selStart _ 1. 1 to: selections size do: [:line | selEnd _ selStart + (selections at: line) size - 1. ((currEmphasis _ emphases at: line) size > 0 and: [currEmphasis ~~ #plain]) ifTrue: [labelString addAttribute: (TextEmphasis perform: currEmphasis) from: selStart to: selEnd]. selStart _ selEnd + 2]! ! !EmphasizedMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:14'! selections: selList emphases: emphList "Answer an instance of the receiver with the given selections and emphases." ^ (self selections: selList) emphases: emphList "Example: (EmphasizedMenu selections: #('how' 'well' 'does' 'this' 'work?') emphases: #(bold plain italic struckOut plain)) startUp"! ! !EmphasizedMenu class methodsFor: 'examples' stamp: 'sma 5/28/2000 16:16'! example1 "EmphasizedMenu example1" ^ (self selections: #('how' 'well' 'does' 'this' 'work?' ) emphases: #(#bold #plain #italic #struckOut #plain )) startUpWithCaption: 'A Menu with Emphases'! ! !EmphasizedMenu class methodsFor: 'examples' stamp: 'sma 5/28/2000 16:17'! example3 "EmphasizedMenu example3" ^ (self selectionAndEmphasisPairs: #('how' #bold 'well' #plain 'does' #italic 'this' #struckOut 'work' #plain)) startUpWithCaption: 'A Menu with Emphases'! ! I encode names and literals into tree nodes with byte codes for the compiler. Byte codes for literals are not assigned until the tree-sizing pass of the compiler, because only then is it known which literals are actually needed. I also keep track of sourceCode ranges during parsing and code generation so I can provide an inverse map for the debugger.! !Encoder methodsFor: 'initialize-release' stamp: 'di 12/4/1999 22:22'! init: aClass context: aContext notifying: req | node n homeNode indexNode | requestor _ req. class _ aClass. nTemps _ 0. supered _ false. self initScopeAndLiteralTables. n _ -1. class allInstVarNames do: [:variable | node _ VariableNode new name: variable index: (n _ n + 1) type: LdInstType. scopeTable at: variable put: node]. aContext == nil ifFalse: [homeNode _ self bindTemp: 'homeContext'. "first temp = aContext passed as arg" n _ 0. aContext tempNames do: [:variable | indexNode _ self encodeLiteral: (n _ n + 1). node _ MessageAsTempNode new receiver: homeNode selector: #tempAt: arguments: (Array with: indexNode) precedence: 3 from: self. scopeTable at: variable put: node]]. sourceRanges _ Dictionary new: 32. globalSourceRanges _ OrderedCollection new: 32. ! ! !Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 20:09'! encodeVariable: name ^ self encodeVariable: name sourceRange: nil ifUnknown: [ self undeclared: name ]! ! !Encoder methodsFor: 'encoding' stamp: 'sma 12/22/1999 11:28'! encodeVariable: name ifUnknown: action | varNode | varNode _ scopeTable at: name ifAbsent: [self lookupInPools: name ifFound: [:assoc | ^self global: assoc name: name]. ^action value]. (varNode isTemp and: [varNode scope < 0]) ifTrue: [^self notify: 'out of scope']. ^varNode! ! !Encoder methodsFor: 'encoding' stamp: 'di 12/4/1999 22:39'! encodeVariable: name sourceRange: range ifUnknown: action | varNode | varNode _ scopeTable at: name ifAbsent: [(self lookupInPools: name ifFound: [:assoc | varNode _ self global: assoc name: name]) ifTrue: [varNode] ifFalse: [action value]]. name first isUppercase ifTrue: [globalSourceRanges addLast: { name. range. false }]. ^ varNode! ! !Encoder methodsFor: 'encoding' stamp: 'di 1/7/2000 15:24'! sharableLitIndex: literal "Special access prevents multiple entries for post-allocated super send special selectors" | p | p _ literalStream originalContents indexOf: literal. p = 0 ifFalse: [^ p-1]. ^ self litIndex: literal ! ! !Encoder methodsFor: 'encoding' stamp: 'jm 10/31/2002 08:14'! undeclared: name | sym | Transcript show: ' (' , name , ' is Undeclared) '. sym _ name asSymbol. Undeclared at: sym put: nil. ^ self global: (Undeclared associationAt: sym) name: sym ! ! !Encoder methodsFor: 'temps' stamp: 'di 10/12/1999 16:53'! bindAndJuggle: name | node nodes first thisCode | node _ self reallyBind: name. "Declared temps must precede block temps for decompiler and debugger to work right" nodes _ self tempNodes. (first _ nodes findFirst: [:n | n scope > 0]) > 0 ifTrue: [node == nodes last ifFalse: [self error: 'logic error']. thisCode _ (nodes at: first) code. first to: nodes size - 1 do: [:i | (nodes at: i) key: (nodes at: i) key code: (nodes at: i+1) code]. nodes last key: nodes last key code: thisCode]. ^ node! ! !Encoder methodsFor: 'temps' stamp: 'crl 2/26/1999 12:18'! bindBlockTemp: name "Declare a temporary block variable; complain if it's not a field or class variable." | node | node _ scopeTable at: name ifAbsent: [^self reallyBind: name]. node isTemp ifTrue: [ node scope >= 0 ifTrue: [^ self notify: 'Name already used in this method']. node scope: 0] ifFalse: [^self notify: 'Name already used in this class']. ^node ! ! !Encoder methodsFor: 'temps' stamp: 'ar 7/12/1999 00:24'! bindTemp: name "Declare a temporary; error not if a field or class variable." scopeTable at: name ifPresent:[:node| "When non-interactive raise the error only if its a duplicate" (node isTemp or:[requestor interactive]) ifTrue:[^self notify:'Name is already defined'] ifFalse:[Transcript show: '(', name, ' is shadowed)']]. ^self reallyBind: name! ! !Encoder methodsFor: 'results' stamp: 'ar 2/13/1999 21:18'! associationFor: aClass | name | name _ Smalltalk keyAtIdentityValue: aClass ifAbsent: [^Association new value: aClass]. ^Smalltalk associationAt: name! ! !Encoder methodsFor: 'results' stamp: 'di 10/12/1999 16:12'! tempNames ^ self tempNodes collect: [:node | (node isMemberOf: MessageAsTempNode) ifTrue: [scopeTable keyAtValue: node] ifFalse: [node key]]! ! !Encoder methodsFor: 'results' stamp: 'di 10/12/1999 15:31'! tempNodes | tempNodes | tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code]. scopeTable associationsDo: [:assn | assn value isTemp ifTrue: [tempNodes add: assn value]]. ^ tempNodes! ! !Encoder methodsFor: 'results' stamp: 'di 10/12/1999 17:15'! unusedTempNames | unused name | unused _ OrderedCollection new. scopeTable associationsDo: [:assn | (assn value isUnusedTemp) ifTrue: [name _ assn value key. name ~= 'homeContext' ifTrue: [unused add: name]]]. ^ unused! ! !Encoder methodsFor: 'source mapping' stamp: 'di 12/4/1999 22:27'! globalSourceRanges ^ globalSourceRanges! ! !Encoder methodsFor: 'private' stamp: 'jm 10/30/2002 20:52'! lookupInPools: varName ifFound: assocBlock Symbol hasInterned: varName ifTrue: [:sym | (class scopeHas: sym ifTrue: assocBlock) ifTrue: [^ true]. ^ false]. ^ class scopeHas: varName ifTrue: assocBlock. "Maybe a string in a pool **Eliminate this**" ! ! !Envelope methodsFor: 'accessing' stamp: 'jm 8/17/1998 15:20'! attackTime "Return the time taken by the attack phase." ^ (points at: loopStartIndex) x ! ! !Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:10'! centerPitch: aNumber "Set the center pitch of a pitch-controlling envelope. This default implementation does nothing." ! ! !Envelope methodsFor: 'accessing' stamp: 'jm 8/19/1998 09:07'! duration: seconds "Set the note duration to the given number of seconds." "Details: The duration is reduced by 19 mSec to ensure proper cutoffs even when the sound starts playing between doControl epochs." "Note: This is a hack. With a little additional work on the envelope logic, it should be possible to reduce or eliminate this fudge factor. In particular, an envelope should use the time remaining, rather than time-since-start to determine when to enter its decay phase. In addition, an envelope must be able to cut off in minimum time (~5-10 msec) if there isn't enough time to do their normal decay. All of this is to allow instruments with leisurely decays to play very short notes if necessary (say, when fast-forwarding through a score)." | attack decay endTime | endMSecs _ (seconds * 1000.0) asInteger - 19. attack _ self attackTime. decay _ self decayTime. endMSecs > (attack + decay) ifTrue: [endTime _ endMSecs - decay] ifFalse: [ endMSecs >= attack ifTrue: [endTime _ attack] ifFalse: [endTime _ endMSecs]]. self sustainEnd: (endTime max: 0). ! ! !Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 17:03'! name ^ self updateSelector allButLast ! ! !Envelope methodsFor: 'accessing' stamp: 'jm 8/13/1998 18:13'! volume: aNumber "Set the maximum volume of a volume-controlling envelope. This default implementation does nothing." ! ! By John M McIntosh johnmci@smalltalkconsulting.com This class was written to mange the external semaphore table. When I was writing a Socket test server I discovered various race conditions on the access to the externalSemaphore table. This new class uses class side methods to restrict access using a mutex semaphore. It seemed cleaner to deligate the reponsibility here versus adding more code and another class variable to SystemDictionary Note that in Smalltalk recreateSpecialObjectsArray we still directly play with the table.! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:36'! clearExternalObjects "Clear the array of objects that have been registered for use in non-Smalltalk code." ProtectTable critical: [Smalltalk specialObjectsArray at: 39 put: Array new]. ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 21:01'! externalObjects ^ProtectTable critical: [Smalltalk specialObjectsArray at: 39].! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:44'! registerExternalObject: anObject ^ ProtectTable critical: [self safelyRegisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:57'! safelyRegisterExternalObject: anObject "Register the given object in the external objects array and return its index. If it is already there, just return its index." | objects firstEmptyIndex obj sz newObjects | objects _ Smalltalk specialObjectsArray at: 39. "find the first empty slot" firstEmptyIndex _ 0. 1 to: objects size do: [:i | obj _ objects at: i. obj == anObject ifTrue: [^ i]. "object already there, just return its index" (obj == nil and: [firstEmptyIndex = 0]) ifTrue: [firstEmptyIndex _ i]]. "if no empty slots, expand the array" firstEmptyIndex = 0 ifTrue: [ sz _ objects size. newObjects _ objects species new: sz + 20. "grow linearly" newObjects replaceFrom: 1 to: sz with: objects startingAt: 1. firstEmptyIndex _ sz + 1. Smalltalk specialObjectsArray at: 39 put: newObjects. objects _ newObjects]. objects at: firstEmptyIndex put: anObject. ^ firstEmptyIndex ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:59'! safelyUnregisterExternalObject: anObject "Unregister the given object in the external objects array. Do nothing if it isn't registered. JMM change to return if we clear the element, since it should only appear once in the array" | objects | anObject ifNil: [^ self]. objects _ Smalltalk specialObjectsArray at: 39. 1 to: objects size do: [:i | (objects at: i) == anObject ifTrue: [objects at: i put: nil. ^self]]. ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'JMM 6/6/2000 20:45'! unregisterExternalObject: anObject ProtectTable critical: [self safelyUnregisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'JMM 6/6/2000 20:32'! initialize ProtectTable _ Semaphore forMutualExclusion! ! This class implements the Fast Fourier Transform roughly as described on page 367 of "Theory and Application of Digital Signal Processing" by Rabiner and Gold. Each instance caches tables used for transforming a given size (n = 2^nu samples) of data. It would have been cleaner using complex numbers, but often the data is all real.! !FFT methodsFor: 'initialization' stamp: 'jm 8/25/1999 21:59'! n ^ n ! ! !FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'! imagData ^ imagData ! ! !FFT methodsFor: 'testing' stamp: 'jm 8/1/1998 13:08'! realData ^ realData ! ! !FFT methodsFor: 'testing' stamp: 'jm 8/16/1998 17:36'! samplesPerCycleForIndex: i "Answer the number of samples per cycle corresponding to a power peak at the given index. Answer zero if i = 1, since an index of 1 corresponds to the D.C. component." | windowSize | windowSize _ 2 raisedTo: nu. (i < 1 or: [i > (windowSize // 2)]) ifTrue: [^ self error: 'index is out of range']. i = 1 ifTrue: [^ 0]. "the D.C. component" ^ windowSize asFloat / (i - 1) ! ! !FFT methodsFor: 'plugin-testing' stamp: 'ar 10/10/1998 21:53'! pluginPrepareData "The FFT plugin requires data to be represented in WordArrays or FloatArrays" sinTable _ sinTable asFloatArray. permTable _ permTable asWordArray. realData _ realData asFloatArray. imagData _ imagData asFloatArray.! ! !FFT methodsFor: 'plugin-testing' stamp: 'ar 10/10/1998 21:53'! pluginTest "Display restoreAfter: [(FFT new nu: 12) pluginTest]." "Test on an array of 256 samples" "Initialize to pure (co)Sine Wave, plot, transform, plot, invert and plot again" self realData: ((1 to: n) collect: [:i | (Float pi * (i-1) / (n/8)) cos]). self plot: realData in: (100@20 extent: 256@60). self pluginPrepareData. Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: true]); endEntry. self plot: realData in: (100@100 extent: 256@60). self plot: imagData in: (100@180 extent: 256@60). Transcript cr; print: (Time millisecondsToRun:[self pluginTransformData: false]); endEntry. self plot: realData in: (100@260 extent: 256@60)! ! !FFT methodsFor: 'plugin-testing' stamp: 'jm 10/2/2002 13:50'! pluginTransformData: forward "Do FFT transform in the given direction." self primitiveFailed. ! ! !FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:10'! initializeHammingWindow: alpha "Initialize the windowing function to the generalized Hamming window. See F. Richard Moore, Elements of Computer Music, p. 100. An alpha of 0.54 gives the Hamming window, 0.5 gives the hanning window." | v midPoint | window _ FloatArray new: n. midPoint _ (n + 1) / 2.0. 1 to: n do: [:i | v _ alpha + ((1.0 - alpha) * (2.0 * Float pi * ((i - midPoint) / n)) cos). window at: i put: v]. ! ! !FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 16:42'! initializeTriangularWindow "Initialize the windowing function to the triangular, or Parzen, window. See F. Richard Moore, Elements of Computer Music, p. 100." | v | window _ FloatArray new: n. 0 to: (n // 2) - 1 do: [:i | v _ i / ((n // 2) - 1). window at: (i + 1) put: v. window at: (n - i) put: v]. ! ! !FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:40'! setSize: anIntegerPowerOfTwo "Initialize variables and tables for performing an FFT on the given number of samples. The number of samples must be an integral power of two (e.g. 1024). Prepare data for use with the fast primitive." self nu: (anIntegerPowerOfTwo log: 2) asInteger. n = anIntegerPowerOfTwo ifFalse: [self error: 'size must be a power of two']. sinTable _ sinTable asFloatArray. permTable _ permTable asWordArray. realData _ FloatArray new: n. imagData _ FloatArray new: n. self initializeHammingWindow: 0.54. "0.54 for Hamming, 0.5 for hanning" ! ! !FFT methodsFor: 'bulk processing' stamp: 'jm 9/8/1999 17:55'! transformDataFrom: anIndexableCollection startingAt: index "Forward transform a block of real data taken from from the given indexable collection starting at the given index. Answer a block of values representing the normalized magnitudes of the frequency components." | j real imag out | j _ 0. index to: index + n - 1 do: [:i | realData at: (j _ j + 1) put: (anIndexableCollection at: i)]. realData *= window. imagData _ FloatArray new: n. self pluginTransformData: true. "compute the magnitudes of the complex results" "note: the results are in bottom half; the upper half is just its mirror image" real _ realData copyFrom: 1 to: (n / 2). imag _ imagData copyFrom: 1 to: (n / 2). out _ (real * real) + (imag * imag). 1 to: out size do: [:i | out at: i put: (out at: i) sqrt]. ^ out ! ! !FFT class methodsFor: 'instance creation' stamp: 'jm 8/25/1999 12:49'! new: anIntegerPowerOfTwo "Answer a new FFT instance for transforming data packets of the given size." ^ self new setSize: anIntegerPowerOfTwo ! ! !FMBassoonSound methodsFor: 'as yet unclassified' stamp: 'jm 5/30/1999 21:17'! setPitch: pitchNameOrNumber dur: d loudness: l "Select a modulation ratio and modulation envelope scale based on my pitch." | p modScale | p _ self nameOrNumberToPitch: pitchNameOrNumber. modScale _ 9.4. p > 100.0 ifTrue: [modScale _ 8.3]. p > 150.0 ifTrue: [modScale _ 6.4]. p > 200.0 ifTrue: [modScale _ 5.2]. p > 300.0 ifTrue: [modScale _ 3.9]. p > 400.0 ifTrue: [modScale _ 2.8]. p > 600.0 ifTrue: [modScale _ 1.7]. envelopes size > 0 ifTrue: [ envelopes do: [:e | (e updateSelector = #modulation:) ifTrue: [e scale: modScale]]]. super setPitch: p dur: d loudness: l. ! ! !FMClarinetSound methodsFor: 'initialization' stamp: 'jm 5/30/1999 10:10'! setPitch: pitchNameOrNumber dur: d loudness: l "Select a modulation ratio and modulation envelope scale based on my pitch." | p modScale | p _ self nameOrNumberToPitch: pitchNameOrNumber. p < 262.0 ifTrue: [modScale _ 25.0. self ratio: 4] ifFalse: [modScale _ 20.0. self ratio: 2]. p > 524.0 ifTrue: [modScale _ 8.0]. envelopes size > 0 ifTrue: [ envelopes do: [:e | (e updateSelector = #modulation:) ifTrue: [e scale: modScale]]]. super setPitch: p dur: d loudness: l. ! ! !FMSound methodsFor: 'initialization' stamp: 'jm 7/5/1998 11:44'! initialize super initialize. waveTable _ SineTable. scaledWaveTableSize _ waveTable size * ScaleFactor. self setPitch: 440.0 dur: 1.0 loudness: 0.2. ! ! !FMSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:08'! setPitch: pitchNameOrNumber dur: d loudness: vol "(FMSound pitch: 'a4' dur: 2.5 loudness: 0.4) play" super setPitch: pitchNameOrNumber dur: d loudness: vol. modulation ifNil: [modulation _ 0.0]. multiplier ifNil: [multiplier _ 0.0]. self pitch: (self nameOrNumberToPitch: pitchNameOrNumber). self reset. ! ! !FMSound methodsFor: 'initialization' stamp: 'jm 9/20/1998 10:10'! setWavetable: anArray "(AbstractSound lowMajorScaleOn: (FMSound new setWavetable: AA)) play" | samples p dur vol | "copy the array into a SoundBuffer if necessary" anArray class isPointers ifTrue: [samples _ SoundBuffer fromArray: anArray] ifFalse: [samples _ anArray]. p _ self pitch. dur _ self duration. vol _ self loudness. waveTable _ samples. scaledWaveTableSize _ waveTable size * ScaleFactor. self setPitch: p dur: dur loudness: vol. ! ! !FMSound methodsFor: 'accessing' stamp: 'jm 9/9/1998 07:49'! duration: seconds super duration: seconds. count _ initialCount _ (seconds * self samplingRate) rounded. ! ! !FMSound methodsFor: 'accessing' stamp: 'jm 8/7/1998 15:45'! pitch ^ (self samplingRate asFloat * scaledIndexIncr / ScaleFactor) asFloat / waveTable size ! ! !FMSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:55'! stopAfterMSecs: mSecs "Terminate this sound this note after the given number of milliseconds." count _ (mSecs * self samplingRate) // 1000. ! ! !FMSound class methodsFor: 'class initialization' stamp: 'jm 7/6/1998 10:26'! initialize "Build a sine wave table." "FMSound initialize" | tableSize radiansPerStep peak | tableSize _ 4000. SineTable _ SoundBuffer newMonoSampleCount: tableSize. radiansPerStep _ (2.0 * Float pi) / tableSize asFloat. peak _ ((1 bitShift: 15) - 1) asFloat. "range is +/- (2^15 - 1)" 1 to: tableSize do: [:i | SineTable at: i put: (peak * (radiansPerStep * (i - 1)) sin) rounded]. ! ! !FMSound class methodsFor: 'class initialization' stamp: 'jm 7/5/1998 14:22'! sineTable "Answer a SoundBuffer containing one complete cycle of a sine wave." ^ SineTable ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! bass1 "FMSound bass1 play" "(FMSound lowMajorScaleOn: FMSound bass1) play" | snd | snd _ FMSound new modulation: 0 ratio: 0. snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.95). ^ snd setPitch: 220 dur: 1.0 loudness: 0.3 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 20:37'! bassoon1 "FMSound bassoon1 play" "(FMSound lowMajorScaleOn: FMSound bassoon1) play" | snd p env | snd _ FMBassoonSound new ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 40@0.45; add: 90@1.0; add: 180@0.9; add: 270@1.0; add: 320@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). p _ OrderedCollection new. p add: 0@0.2; add: 40@0.9; add: 90@0.6; add: 270@0.6; add: 320@0.5. env _ Envelope points: p loopStart: 3 loopEnd: 4. env updateSelector: #modulation:; scale: 5.05. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! brass1 "FMSound brass1 play" "(FMSound lowMajorScaleOn: FMSound brass1) play" | snd p env | snd _ FMSound new modulation: 0 ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 30@0.8; add: 90@1.0; add: 120@0.9; add: 220@0.7; add: 320@0.9; add: 360@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 4 loopEnd: 6). p _ OrderedCollection new. p add: 0@0.5; add: 60@1.0; add: 120@0.8; add: 220@0.65; add: 320@0.8; add: 360@0.0. env _ Envelope points: p loopStart: 3 loopEnd: 5. env target: snd; updateSelector: #modulation:; scale: 5.0. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! brass2 "FMSound brass2 play" "(FMSound lowMajorScaleOn: FMSound brass2) play" | snd p env | snd _ FMSound new modulation: 1 ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 20@1.0; add: 40@0.9; add: 100@0.7; add: 160@0.9; add: 200@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). p _ OrderedCollection new. p add: 0@0.5; add: 30@1.0; add: 40@0.8; add: 100@0.7; add: 160@0.8; add: 200@0.0. env _ Envelope points: p loopStart: 3 loopEnd: 5. env updateSelector: #modulation:; scale: 5.0. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:10'! clarinet "FMSound clarinet play" "(FMSound lowMajorScaleOn: FMSound clarinet) play" | snd p env | snd _ FMSound new modulation: 0 ratio: 2. p _ OrderedCollection new. p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). p _ OrderedCollection new. p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0. env _ Envelope points: p loopStart: 2 loopEnd: 3. env updateSelector: #modulation:; scale: 10.0. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 5/30/1999 10:20'! clarinet2 "FMSound clarinet2 play" "(FMSound lowMajorScaleOn: FMSound clarinet2) play" | snd p env | snd _ FMClarinetSound new modulation: 0 ratio: 2. p _ OrderedCollection new. p add: 0@0.0; add: 60@1.0; add: 310@1.0; add: 350@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). p _ OrderedCollection new. p add: 0@0.0167; add: 60@0.106; add: 310@0.106; add: 350@0.0. env _ Envelope points: p loopStart: 2 loopEnd: 3. env updateSelector: #modulation:; scale: 10.0. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:02'! flute1 "FMSound flute1 play" "(FMSound majorScaleOn: FMSound flute1) play" | snd p | snd _ FMSound new. p _ OrderedCollection new. p add: 0@0; add: 20@1.0; add: 100@1.0; add: 120@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! mellowBrass "FMSound mellowBrass play" "(FMSound lowMajorScaleOn: FMSound mellowBrass) play" | snd p env | snd _ FMSound new modulation: 0 ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 70@0.325; add: 120@0.194; add: 200@0.194; add: 320@0.194; add: 380@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 3 loopEnd: 5). p _ OrderedCollection new. p add: 0@0.1; add: 70@0.68; add: 120@0.528; add: 200@0.519; add: 320@0.528; add: 380@0.0. env _ Envelope points: p loopStart: 3 loopEnd: 5. env updateSelector: #modulation:; scale: 5.0. snd addEnvelope: env. ^ snd setPitch: 220.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:00'! oboe1 "FMSound oboe1 play" "(FMSound majorScaleOn: FMSound oboe1) play" | snd p | snd _ FMSound new modulation: 1 ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 1/14/1999 12:56'! organ1 "FMSound organ1 play" "(FMSound majorScaleOn: FMSound organ1) play" | snd p | snd _ FMSound new. p _ OrderedCollection new. p add: 0@0; add: 60@1.0; add: 110@0.8; add: 200@1.0; add: 250@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 4). ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 13:00'! randomWeird1 "FMSound randomWeird1 play" | snd p | snd _ FMSound new. snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96). p _ Array with: 0@0 with: 100@1.0 with: 250@0.7 with: 400@1.0 with: 500@0. snd addEnvelope: (PitchEnvelope points: p loopStart: 2 loopEnd: 4). ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5 ! ! !FMSound class methodsFor: 'instruments' stamp: 'jm 8/14/1998 12:57'! randomWeird2 "FMSound randomWeird2 play" | snd | snd _ FMSound new. snd addEnvelope: (VolumeEnvelope exponentialDecay: 0.96). snd addEnvelope: (PitchEnvelope exponentialDecay: 0.98). ^ snd setPitch: (150 + 2000 atRandom) dur: 2.0 loudness: 0.5 ! ! A minimal FTP client program. Could store all state in inst vars, and use an instance to represent the full state of a connection in progress. But simpler to do all that in one method and have it be a complete transaction. Always operates in passive mode (PASV). All connections are initiated from client in order to get through firewalls. See ServerDirectory openFTP, ServerDirectory getFileNamed:, ServerDirectory putFile:named: for examples of use. See TCP/IP, second edition, by Dr. Sidnie Feit, McGraw-Hill, 1997, Chapter 14, p311.! ]style[(259 1 89 23 2 29 2 30 27 6 74)f1,f1-,f1,f1LServerDirectory openFTP;,f1,f1LServerDirectory getFileNamed:;,f1,f1LServerDirectory putFile:named:;,f1,f1b,f1! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:13'! dataSocket ^ dataSocket! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:13'! dataSocket: dd dataSocket _ dd! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 21:56'! getAllData "Reel in all data until the server closes the connection. Return a RWBinaryOrTextStream. Don't know how much is coming." | buf response bytesRead | buf _ String new: 4000. response _ RWBinaryOrTextStream on: (String new: 4000). [(self dataAvailable | self isConnected)] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. 1 to: bytesRead do: [:ii | response nextPut: (buf at: ii)]. "Any way to do this so we do not have to recopy?" ]. response reset. "position: 0." ^ response! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 15:03'! getAllDataWhileWatching: otherSocket "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Return a RWBinaryOrTextStream. Don't know how much is coming." | buf response bytesRead | buf _ String new: 4000. response _ RWBinaryOrTextStream on: (String new: 4000). [self isConnected | self dataAvailable] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ otherSocket responseError ifTrue: [self destroy. ^ #error:]. Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. 1 to: bytesRead do: [:ii | response nextPut: (buf at: ii)]. "Any way to do this so we do not have to recopy?" ]. response reset. "position: 0." ^ response! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 15:05'! getDataTo: dataStream whileWatching: otherSocket "Reel in all data until the server closes the connection. At the same time, watch for errors on otherSocket. Don't know how much is coming. Put the data on the stream." | buf bytesRead | buf _ String new: 4000. [self isConnected | self dataAvailable] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ otherSocket responseError ifTrue: [self destroy. ^ #error:]. Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. 1 to: bytesRead do: [:ii | dataStream nextPut: (buf at: ii)]. "Any way to do this so we do not have to recopy?" ]. dataStream reset. "position: 0." ^ dataStream! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 3/23/2000 22:10'! getOnlyBuffer: ubuffer whileWatching: otherSocket "Reel in all data until the buffer is full. At the same time, watch for errors on otherSocket. Caller will break the connection after we have the data." | bytesRead ind | ind _ 1. [self isConnected | self dataAvailable] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ otherSocket responseError ifTrue: [self destroy. ^ #error:]. Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: ubuffer startingAt: ind count: ubuffer size - ind + 1. (ind _ ind + bytesRead) > ubuffer size ifTrue: [^ ubuffer]. ]. ^ ubuffer "file was shorter"! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'di 3/29/1999 17:18'! lookFor: beginning "Get the response from the server. If 1xx, in progress. If 2xx, success. If 3xx, intermediate point successful. 4xx, transient error. 5xx, true error. If 4 or 5, put up dialog, kill the socket, and return the response string. Return true the string in beginning is at the front of what came back. Ignore any 2xx response that is not what we want, but print it." | resp what all | (readAhead ~~ nil and: [readAhead size > 0]) ifTrue: [resp _ readAhead removeFirst] "response already came in" ifFalse: [ all _ self getResponseUpTo: CrLf. resp _ all at: 1. "150 Opening binary mode data conn" readAhead _ (all at: 3) findBetweenSubStrs: (Array with: CrLf)]. resp size > 0 ifTrue: [ resp first isDigit ifFalse: [ ^self lookFor: beginning ]. "we're in the middle of a line, not the end." #XXX. "this should be fixed..." (resp at: 4) == $- ifTrue: [^ self lookFor: beginning]. "is a comment" (resp beginsWith: beginning) ifTrue: [^ true]. "exactly what we wanted" ] ifFalse: [resp _ '[timeout]']. what _ (PopUpMenu labels: 'OK\ debug ' withCRs) startUpWithCaption: 'Server reported this error:\' withCRs, resp. what = 2 ifTrue: [self halt]. self destroy. ^ resp ! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 7/8/1999 14:29'! lookSoftlyFor: beginning "Get the response from the server. Return true the string in beginning is at the front of what came back. Don't kill the socket if we fail. Users wants to try another password." | resp what all | (readAhead ~~ nil and: [readAhead size > 0]) ifTrue: [resp _ readAhead removeFirst] "response already came in" ifFalse: [ all _ self getResponseUpTo: CrLf. resp _ all at: 1. "150 Opening binary mode data conn" readAhead _ (all at: 3) findBetweenSubStrs: (Array with: CrLf)]. resp size > 0 ifTrue: [ resp first isDigit ifFalse: [ ^self lookFor: beginning ]. "we're in the middle of a line, not the end." #XXX. "this should be fixed..." (resp at: 4) == $- ifTrue: [^ self lookFor: beginning]. "is a comment" (resp beginsWith: beginning) ifTrue: [^ true]. "exactly what we wanted" ] ifFalse: [resp _ '[timeout]']. what _ (PopUpMenu labels: 'OK\ debug ' withCRs) startUpWithCaption: 'Server reported this error:\' withCRs, resp. what = 2 ifTrue: [self halt]. ^ resp ! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:12'! portNum ^ portNum! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 12/26/97 22:12'! portNum: anInteger portNum _ anInteger! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 11:59'! responseCheck "If data is waiting, do a responseOK to catch any error reports." self dataAvailable ifTrue: [^ self responseOK]. ^ true "all OK so far"! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 1/5/98 12:28'! responseError "If data is waiting, Check it to catch any error reports. Keep all responses in a queue for caller to examine later." | all what | self dataAvailable ifTrue: [ all _ self getResponseUpTo: CrLf. readAhead ifNil: [readAhead _ OrderedCollection new]. readAhead addLast: (all at: 1). "150 Opening binary mode data conn" readAhead addAll: ((all at: 3) findBetweenSubStrs: (Array with: CrLf)). readAhead do: [:resp | ((resp at: 1) == $5) | ((resp at: 1) == $4) ifTrue: [ what _ (PopUpMenu labels: 'OK\ debug ' withCRs) startUpWithCaption: 'Server reported this error:\' withCRs, resp. what = 2 ifTrue: [self halt]. self sendCommand: 'QUIT'. readAhead _ nil. "clear queue" self responseOK. "221" self destroy. ^ true]]]. ^ false "all OK so far"! ! !FTPSocket methodsFor: 'as yet unclassified' stamp: 'mjg 5/7/1999 13:54'! responseOK "Get the response from the server. If 1xx, in progress. If 2xx, success. If 3xx, intermediate point successful. 4xx, transient error. 5xx, true error. If 4 or 5, put up dialog and kill the socket. Return true if OK, the error string if not." | resp what all | readAhead isNil ifTrue: [readAhead _ '']. readAhead size > 0 ifTrue: [resp _ readAhead removeFirst] "response already came in" ifFalse: [ all _ self getResponseUpTo: CrLf. resp _ all at: 1. "150 Opening binary mode data conn" readAhead _ (all at: 3) findBetweenSubStrs: (Array with: CrLf)]. "Transcript show: resp; cr." resp size > 0 ifTrue: [((resp at: 1) == $5) | ((resp at: 1) == $4) ifFalse: [^ true]] "All is well" ifFalse: [resp _ '[timeout]']. what _ (PopUpMenu labels: 'OK\ debug ' withCRs) startUpWithCaption: 'Server reported this error:\' withCRs, resp. what = 2 ifTrue: [self halt]. self destroy. ^ resp! ! !FTPSocket methodsFor: 'finalization' stamp: 'ar 3/21/98 18:19'! actAsExecutor super actAsExecutor. dataSocket := nil.! ! The sole purpose of this class is to allow the Browser code pane to evaluate the class variables of the class whose method it is showing. It does this by stuffing a pointer to the classpool dictionary of the class being shown into its own classpool. It does this just around a doIt in the code pane. An instance of FakeClasspool is then used as the receiver of the doIt.! False defines the behavior of its single instance, false -- logical negation. Notice how the truth-value checks become direct message sends, without the need for explicit testing. Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! This class adds the following optimizations to the basic Inflate decompression: a) Bit reversed access If we want to fetch the bits efficiently then we have them in the wrong bit order (e.g., when we should fetch 2r100 we would get 2r001). But since the huffman tree lookup determines the efficiency of the decompression, reversing the bits before traversal is expensive. Therefore the entries in each table are stored in REVERSE BIT ORDER. This is achieved by a reverse increment of the current table index in the huffman table construction phase (see method increment:bits:). According to my measures this speeds up the implementation by about 30-40%. b) Inplace storage of code meanings and extra bits Rather than looking up the meaning for each code during decompression of blocks we store the appropriate values directly in the huffman tables, using a pre-defined mapping. Even though this does not make a big difference in speed, it cleans up the code and allows easier translation into primitive code (which is clearly one goal of this implementation). c) Precomputed huffman tables for fixed blocks So we don't have to compute the huffman tables from scratch. The precomputed tables are not in our superclass to avoid double storage (and my superclass is more intended for documentation anyways).! !FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/22/1999 01:30'! decompressBlock: llTable with: dTable "Process the compressed data in the block. llTable is the huffman table for literal/length codes and dTable is the huffman table for distance codes." | value extra length distance oldPos oldBits oldBitPos | [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ "Back up stuff if we're running out of space" oldBits _ bitBuf. oldBitPos _ bitPos. oldPos _ sourcePos. value _ self decodeValueFrom: llTable. value < 256 ifTrue:[ "A literal" collection byteAt: (readLimit _ readLimit + 1) put: value. ] ifFalse:["length/distance or end of block" value = 256 ifTrue:["End of block" state _ state bitAnd: StateNoMoreData. ^self]. "Compute the actual length value (including possible extra bits)" extra _ (value bitShift: -16) - 1. length _ value bitAnd: 16rFFFF. extra > 0 ifTrue:[length _ length + (self nextBits: extra)]. "Compute the distance value" value _ self decodeValueFrom: dTable. extra _ (value bitShift: -16). distance _ value bitAnd: 16rFFFF. extra > 0 ifTrue:[distance _ distance + (self nextBits: extra)]. (readLimit + length >= collection size) ifTrue:[ bitBuf _ oldBits. bitPos _ oldBitPos. sourcePos _ oldPos. ^self]. collection replaceFrom: readLimit+1 to: readLimit + length + 1 with: collection startingAt: readLimit - distance + 1. readLimit _ readLimit + length. ]. ].! ! !FastInflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:15'! processFixedBlock litTable _ FixedLitTable. distTable _ FixedDistTable. state _ state bitOr: BlockProceedBit. self proceedFixedBlock.! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! distanceMap ^DistanceMap! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! increment: value bits: nBits "Increment value in reverse bit order, e.g. for a 3 bit value count as follows: 000 / 100 / 010 / 110 001 / 101 / 011 / 111 See the class comment why we need this." | result bit | result _ value. "Test the lowest bit first" bit _ 1 << (nBits - 1). "If the currently tested bit is set then we need to turn this bit off and test the next bit right to it" [(result bitAnd: bit) = 0] whileFalse:[ "Turn off current bit" result _ result bitXor: bit. "And continue testing the next bit" bit _ bit bitShift: -1]. "Turn on the right-most bit that we haven't touched in the loop above" ^result bitXor: bit! ! !FastInflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:26'! literalLengthMap ^LiteralLengthMap! ! !FastInflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:02'! nextSingleBits: n "Fetch the bits all at once" ^self nextBits: n.! ! !FastInflateStream class methodsFor: 'class initialization' stamp: 'ar 12/21/1999 23:00'! initialize "FastInflateStream initialize" | low high | "Init literal/length map" low _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258 ). high _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0 0). LiteralLengthMap _ WordArray new: 256 + 32. 1 to: 257 do:[:i| LiteralLengthMap at: i put: i-1]. 1 to: 29 do:[:i| LiteralLengthMap at: 257+i put: (low at:i) + ( (high at: i) + 1 << 16)]. "Init distance map" high _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). low _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577). DistanceMap _ WordArray new: 32. 1 to: 30 do:[:i| DistanceMap at: i put: (low at: i) + ( (high at: i) << 16)]. "Init fixed block huffman tables" FixedLitTable _ self basicNew huffmanTableFrom: FixedLitCodes mappedBy: LiteralLengthMap. FixedDistTable _ self basicNew huffmanTableFrom: FixedDistCodes mappedBy: DistanceMap.! ! I provide fast JPEG compression and decompression. I require the VM extension JPEGReadWriter2Plugin, which is usually installed in same directory as the Squeak virtual machine. JPEGReadWriter2Plugin is based on LIBJPEG library. This sentence applies to that library: "This software is based in part on the work of the Independent JPEG Group". The LIBJPEG license allows it to be used free for any purpose so long as its origin and copyright are acknowledged. You can read more about LIBJPEG and get the complete source code at www.ijg.org. ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 10/27/2002 11:04'! compress: aForm quality: quality "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high)." ^ self compress: aForm quality: quality progressive: false ! ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 7/16/2003 13:57'! compress: aForm quality: quality progressive: progressiveFlag "Encode the given Form and answer the compressed ByteArray. Quality goes from 0 (low) to 100 (high). If progressiveFlag is true, then create a progressive-scan JPEG which is a bit larger but causes a low-resolution version to appear in browsers while the rest of the data is being fetched." | sourceForm jpegCompressStruct jpegErrorMgr2Struct buffer byteCount | aForm unhibernate. "Odd width images of depth 16 give problems; avoid them. Make sure depth is 16 or 32." sourceForm _ (aForm depth = 32) | (aForm width even & (aForm depth = 16)) ifTrue: [aForm] ifFalse: [aForm asFormOfDepth: 32]. jpegCompressStruct _ ByteArray new: self primJPEGCompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. buffer _ ByteArray new: 2 * sourceForm width * sourceForm height. "larger than compressed size..." byteCount _ self primJPEGWriteImage: jpegCompressStruct onByteArray: buffer form: sourceForm quality: quality progressiveJPEG: progressiveFlag errorMgr: jpegErrorMgr2Struct. byteCount = 0 ifTrue: [self error: 'buffer too small for compressed data']. ^ buffer copyFrom: 1 to: byteCount ! ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 11/13/2002 10:22'! uncompress: aByteArray "Uncompress an image from the given ByteArray and return the resulting 32-bit Form." ^ self uncompress: aByteArray doDithering: false ! ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 10/27/2002 08:26'! uncompress: aByteArray doDithering: ditherFlag "Uncompress an image from the given ByteArray and return the resulting Form. If ditherFlag = true, do ordered dithering into a Form of depth 16. Otherwise, return a Form of depth 32." | jpegDecompressStruct jpegErrorMgr2Struct w h result | jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w _ self primImageWidth: jpegDecompressStruct. h _ self primImageHeight: jpegDecompressStruct. (ditherFlag and: [w odd not]) "odd width images of depth 16 do not work" ifTrue: [result _ Form extent: w@h depth: 16] ifFalse: [result _ Form extent: w@h depth: 32]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: result doDithering: ditherFlag errorMgr: jpegErrorMgr2Struct. ^ result ! ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 10/27/2002 11:05'! uncompress: aByteArray into: aForm "Uncompress an image from the given ByteArray into the given Form. Fail if the given Form has the wrong dimensions or depth < 16. If aForm has depth 16, do ordered dithering." self uncompress: aByteArray into: aForm doDithering: (aForm depth = 16). ! ! !FastJPEG class methodsFor: 'image operations' stamp: 'jm 10/27/2002 08:02'! uncompress: aByteArray into: aForm doDithering: ditherFlag "Uncompress an image from the given ByteArray into the given Form. Fail if aForm has the wrong dimensions or depth < 16. If aForm has depth 16 and ditherFlag = true, do ordered dithering." | jpegDecompressStruct jpegErrorMgr2Struct w h | aForm unhibernate. jpegDecompressStruct _ ByteArray new: self primJPEGDecompressStructSize. jpegErrorMgr2Struct _ ByteArray new: self primJPEGErrorMgr2StructSize. self primJPEGReadHeader: jpegDecompressStruct fromByteArray: aByteArray errorMgr: jpegErrorMgr2Struct. w _ self primImageWidth: jpegDecompressStruct. h _ self primImageHeight: jpegDecompressStruct. ((aForm width = w) & (aForm height = h)) ifFalse: [ ^ self error: 'form dimensions do not match']. "odd width images of depth 16 give problems; avoid them" w odd ifTrue: [ aForm depth = 32 ifFalse: [^ self error: 'must use depth 32 with odd width']] ifFalse: [ ((aForm depth = 16) | (aForm depth = 32)) ifFalse: [^ self error: 'must use depth 16 or 32']]. self primJPEGReadImage: jpegDecompressStruct fromByteArray: aByteArray onForm: aForm doDithering: ditherFlag errorMgr: jpegErrorMgr2Struct. ! ! !FastJPEG class methodsFor: 'testing' stamp: 'jm 10/26/2002 22:24'! isPluginPresent ^ self primJPEGPluginIsPresent ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 10/30/2002 19:28'! primImageHeight: aJPEGCompressStruct self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primImageWidth: aJPEGCompressStruct self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGCompressStructSize self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGDecompressStructSize self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGErrorMgr2StructSize self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 10/27/2002 07:53'! primJPEGPluginIsPresent ^ false ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jmv 12/7/2001 13:45'! primJPEGReadImage: aJPEGDecompressStruct fromByteArray: source onForm: form doDithering: ditherFlag errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !FastJPEG class methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !FileContentsBrowser methodsFor: 'accessing'! contents self updateInfoView. (editSelection == #newClass and:[self selectedPackage notNil]) ifTrue: [^self selectedPackage packageInfo]. editSelection == #editClass ifTrue:[^self modifiedClassDefinition]. ^super contents! ! !FileContentsBrowser methodsFor: 'accessing'! contents: input notifying: aController "The retrieved information has changed and its source must now be updated. The information can be a variety of things, depending on the list selections (such as templates for class or message definition, methods) or the user menu commands (such as definition, comment, hierarchy). Answer the result of updating the source." | aString aText theClass | aString _ input asString. aText _ input asText. 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 == #editMessageCategories ifTrue: [^ self changeMessageCategories: aString]. self inform:'You cannot change the current selection'. ^false ! ! !FileContentsBrowser methodsFor: 'accessing'! packages ^packages! ! !FileContentsBrowser methodsFor: 'accessing'! packages: aDictionary packages := aDictionary.! ! !FileContentsBrowser methodsFor: 'accessing'! selectedPackage | cat | cat := self selectedSystemCategoryName. cat isNil ifTrue:[^nil]. ^self packages at: cat asString ifAbsent:[nil]! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'! removeClass | class | classListIndex = 0 ifTrue: [^ self]. class _ self selectedClass. (self confirm:'Are you certain that you want to delete the class ', class name, '?') ifFalse:[^self]. self selectedPackage removeClass: class. self classListIndex: 0. self changed: #classList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:46'! removeMessage | messageName | messageListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. messageName _ self selectedMessageName. (self selectedClassOrMetaClass confirmRemovalOf: messageName) ifFalse:[^false]. self selectedClassOrMetaClass removeMethod: self selectedMessageName. self messageListIndex: 0. self setClassOrganizer. "In case organization not cached" self changed: #messageList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:51'! 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?']) ifFalse: [^ self]. self selectedClassOrMetaClass removeCategory: messageCategoryName. self messageCategoryListIndex: 0. self changed: #messageCategoryList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:52'! removePackage systemCategoryListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (self confirm: 'Are you sure you want to remove this package and all its classes?') ifFalse:[^self]. (systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) do:[:el| systemOrganizer removeElement: el]. self packages removeKey: self selectedPackage packageName. systemOrganizer removeCategory: self selectedSystemCategoryName. self systemCategoryListIndex: 0. self changed: #systemCategoryList! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'! removeUnmodifiedCategories | theClass | self okToChange ifFalse: [^self]. theClass _ self selectedClass. theClass isNil ifTrue: [^self]. Cursor wait showWhile: [theClass removeUnmodifiedMethods: theClass selectors. theClass metaClass removeUnmodifiedMethods: theClass metaClass selectors]. self messageCategoryListIndex: 0. self changed: #messageCategoryList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:37'! removeUnmodifiedClasses | packageList | self okToChange ifFalse:[^self]. packageList := self selectedPackage isNil ifTrue:[self packages] ifFalse:[Array with: self selectedPackage]. packageList do:[:package| package classes copy do:[:theClass| Cursor wait showWhile:[ theClass removeAllUnmodified. ]. theClass hasChanges ifFalse:[ package removeClass: theClass. ]. ]]. self classListIndex: 0. self changed: #classList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 2/3/1999 18:47'! removeUnmodifiedMethods | theClass cat | self okToChange ifFalse:[^self]. theClass := self selectedClassOrMetaClass. theClass isNil ifTrue:[^self]. cat := self selectedMessageCategoryName. cat isNil ifTrue:[^self]. Cursor wait showWhile:[ theClass removeUnmodifiedMethods: (theClass organization listAtCategoryNamed: cat). ]. self messageListIndex: 0. self changed: #messageList.! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'sma 5/6/2000 18:48'! browseMethodFull | myClass | (myClass _ self selectedClassOrMetaClass) ifNotNil: [Browser fullOnClass: myClass realClass selector: self selectedMessageName]! ! !FileContentsBrowser 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 or:[self selectedPackage isNil]) ifTrue: [^Array new] ifFalse: [^self selectedPackage classes keys asSortedCollection].! ! !FileContentsBrowser methodsFor: 'class list'! findClass | pattern foundClass classNames index foundPackage | self okToChange ifFalse: [^ self classNotFound]. pattern _ (FillInTheBlank request: 'Class Name?') asLowercase. pattern isEmpty ifTrue: [^ self]. classNames := Set new. self packages do:[:p| classNames addAll: p classes keys]. classNames := classNames asArray select: [:n | (n asLowercase indexOfSubCollection: pattern startingAt: 1) > 0]. classNames isEmpty ifTrue: [^ self]. index _ classNames size == 1 ifTrue: [1] ifFalse: [(PopUpMenu labelArray: classNames lines: #()) startUp]. index = 0 ifTrue: [^ self]. foundPackage := nil. foundClass := nil. self packages do:[:p| (p classes includesKey: (classNames at: index)) ifTrue:[ foundClass := p classes at: (classNames at: index). foundPackage := p]]. foundClass isNil ifTrue:[^self]. self systemCategoryListIndex: (self systemCategoryList indexOf: foundPackage packageName asSymbol). self classListIndex: (self classList indexOf: foundClass name). ! ! !FileContentsBrowser methodsFor: 'class list' stamp: 'wod 5/24/1998 20:37'! renameClass | oldName newName | classListIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. oldName _ self selectedClass name. newName _ (self request: 'Please type new class name' initialAnswer: oldName) asSymbol. (newName isEmpty or:[newName = oldName]) ifTrue: [^ self]. (self selectedPackage classes includesKey: newName) ifTrue: [^ self error: newName , ' already exists in the package']. systemOrganizer classify: newName under: self selectedSystemCategoryName. systemOrganizer removeElement: oldName. self selectedPackage renameClass: self selectedClass to: newName. self changed: #classList. self classListIndex: ((systemOrganizer listAtCategoryNamed: self selectedSystemCategoryName) indexOf: newName). ! ! !FileContentsBrowser methodsFor: 'class list'! selectedClass "Answer the class that is currently selected. Answer nil if no selection exists." self selectedClassName == nil ifTrue: [^nil]. ^self selectedPackage classAt: self selectedClassName! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'sw 11/9/1999 19:26'! selectedMessage "Answer a copy of the source code for the selected message selector." | class selector | class _ self selectedClassOrMetaClass. selector _ self selectedMessageName. contents _ class sourceCodeAt: selector. Preferences browseWithPrettyPrint ifTrue: [contents _ Compiler new format: contents in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. self showDiffs ifTrue: [contents _ self methodDiffFor: contents class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated]. ^ contents asText makeSelectorBoldIn: class! ! !FileContentsBrowser methodsFor: 'diffs' stamp: 'sma 5/6/2000 18:08'! methodDiffFor: aString class: aPseudoClass selector: selector meta: meta | theClass source | theClass _ Smalltalk at: aPseudoClass name ifAbsent: [^ aString copy]. meta ifTrue: [theClass _ theClass class]. (theClass includesSelector: selector) ifFalse: [^ aString copy]. source _ theClass sourceCodeAt: selector. ^ Cursor wait showWhile: [TextDiffBuilder buildDisplayPatchFrom: source to: aString]! ! !FileContentsBrowser methodsFor: 'diffs'! modifiedClassDefinition | pClass rClass old new diff | pClass := self selectedClassOrMetaClass. pClass hasDefinition ifFalse:[^pClass definition]. rClass := Smalltalk at: self selectedClass name asSymbol ifAbsent:[nil]. rClass isNil ifTrue:[^pClass definition]. self metaClassIndicated ifTrue:[ rClass := rClass class]. old := rClass definition. new := pClass definition. Cursor wait showWhile:[ diff := ClassDiffBuilder buildDisplayPatchFrom: old to: new ]. ^diff! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut'! fileInClass Cursor read showWhile:[ self selectedClass fileIn. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'! fileInMessage self selectedMessageName ifNil: [^self]. Cursor read showWhile: [ self selectedClassOrMetaClass fileInMethod: self selectedMessageName. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'! fileInMessageCategories Cursor read showWhile:[ self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 12:50'! fileInPackage Cursor read showWhile:[ self selectedPackage fileIn. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'sma 4/22/2000 20:51'! fileIntoNewChangeSet | p ff | (p _ self selectedPackage) ifNil: [^ self beep]. ff _ StandardFileStream readOnlyFileNamed: p fullPackageName. ChangeSorter newChangesFromStream: ff named: p packageName! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut'! fileOutClass Cursor write showWhile:[ self selectedClass fileOut. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 6/16/1998 17:14'! fileOutMessage self selectedMessageName ifNil: [^self]. Cursor write showWhile: [ self selectedClassOrMetaClass fileOutMethod: self selectedMessageName].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 2/3/1999 18:46'! fileOutMessageCategories Cursor write showWhile:[ self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'fileIn/fileOut' stamp: 'wod 5/13/1998 14:19'! fileOutPackage Cursor write showWhile:[ self selectedPackage fileOut. ].! ! !FileContentsBrowser methodsFor: 'infoView' stamp: 'sma 5/6/2000 19:19'! extraInfo ^ (self methodDiffFor: (self selectedClassOrMetaClass sourceCodeAt: self selectedMessageName) class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated) unembellished ifTrue: [' - identical'] ifFalse: [' - modified']! ! !FileContentsBrowser methodsFor: 'infoView'! infoString ^infoString isNil ifTrue:[infoString := StringHolder new] ifFalse:[infoString]! ! !FileContentsBrowser methodsFor: 'infoView' stamp: 'sma 5/6/2000 18:26'! infoViewContents | theClass | editSelection == #newClass ifTrue: [^ self packageInfo: self selectedPackage]. self selectedClass isNil ifTrue: [^ '']. theClass _ Smalltalk at: self selectedClass name asSymbol ifAbsent: []. editSelection == #editClass ifTrue: [^ theClass notNil ifTrue: ['Class exists already in the system'] ifFalse: ['New class']]. editSelection == #editMessage ifFalse: [^ '']. (theClass notNil and: [self metaClassIndicated]) ifTrue: [theClass _ theClass class]. ^ (theClass notNil and: [theClass includesSelector: self selectedMessageName]) ifTrue: ['Method already exists' , self extraInfo] ifFalse: ['New method']! ! !FileContentsBrowser methodsFor: 'infoView'! packageInfo: p | nClasses newClasses oldClasses | p isNil ifTrue:[^'']. nClasses := newClasses := oldClasses := 0. p classes do:[:cls| nClasses := nClasses + 1. (Smalltalk includesKey: (cls name asSymbol)) ifTrue:[oldClasses := oldClasses + 1] ifFalse:[newClasses := newClasses + 1]]. ^nClasses printString,' classes (', newClasses printString, ' new / ', oldClasses printString, ' modified)'! ! !FileContentsBrowser methodsFor: 'infoView' stamp: 'wod 5/19/1998 17:34'! updateInfoView Smalltalk isMorphic ifTrue: [self changed: #infoViewContents] ifFalse: [ self infoString contents: self infoViewContents. self infoString changed].! ! !FileContentsBrowser methodsFor: 'metaclass'! selectedClassOrMetaClass "Answer the selected class or metaclass." self metaClassIndicated ifTrue: [^ self selectedClass metaClass] ifFalse: [^ self selectedClass]! ! !FileContentsBrowser methodsFor: 'metaclass'! setClassOrganizer "Install whatever organization is appropriate" | theClass | classOrganizer _ nil. metaClassOrganizer _ nil. classListIndex = 0 ifTrue: [^ self]. classOrganizer _ (theClass _ self selectedClass) organization. metaClassOrganizer _ theClass metaClass organization. ! ! !FileContentsBrowser methodsFor: 'other' stamp: 'wod 5/25/1998 00:46'! browseSenders "Create and schedule a message set browser on all senders of the currently selected message selector. Do nothing if no message is selected." messageListIndex ~= 0 ifTrue: [Smalltalk browseAllCallsOn: self selectedMessageName]! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sw 10/12/1999 17:42'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | (selector _ self selectedMessageName) ifNotNil: [class _ self selectedClassOrMetaClass. (class exists and: [class realClass includesSelector: selector]) ifTrue: [VersionsBrowser browseVersionsOf: (class realClass compiledMethodAt: selector) class: class realClass meta: class realClass isMeta category: self selectedMessageCategoryName selector: selector]]! ! !FileContentsBrowser methodsFor: 'other'! changeMessageCategories: aString "The characters in aString represent an edited version of the the message categories for the selected class. Update this information in the system and inform any dependents that the categories have been changed. This message is invoked because the user had issued the categories command and edited the message categories. Then the user issued the accept command." self classOrMetaClassOrganizer changeFromString: aString. self unlock. self editClass. self classListIndex: classListIndex. ^ true! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'! methodHierarchy (self selectedClassOrMetaClass isNil or: [self selectedClassOrMetaClass hasDefinition]) ifFalse: [super methodHierarchy]! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'sma 2/6/2000 12:03'! createViews "Create a pluggable version of all the views for a Browser, including views and controllers." | hasSingleFile width topView packageListView classListView switchView messageCategoryListView messageListView browserCodeView infoView | showDiffs _ true. Smalltalk isMorphic ifTrue: [^ self openAsMorph]. (hasSingleFile _ self packages size = 1) ifTrue: [width _ 150] ifFalse: [width _ 200]. (topView _ StandardSystemView new) model: self; borderWidth: 1. "label and minSize taken care of by caller" hasSingleFile ifTrue: [ self systemCategoryListIndex: 1. packageListView _ PluggableListView on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #packageListMenu: keystroke: #packageListKey:from:. packageListView window: (0 @ 0 extent: width @ 12)] ifFalse: [ packageListView _ PluggableListView on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #packageListMenu: keystroke: #packageListKey:from:. packageListView window: (0 @ 0 extent: 50 @ 70)]. topView addSubView: packageListView. classListView _ PluggableListView on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:. classListView window: (0 @ 0 extent: 50 @ 62). hasSingleFile ifTrue: [topView addSubView: classListView below: packageListView] ifFalse: [topView addSubView: classListView toRightOf: packageListView]. 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: 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: width@110). topView addSubView: browserCodeView below: (hasSingleFile ifTrue: [switchView] ifFalse: [packageListView]). infoView _ StringHolderView new model: self infoString; window: (0@0 extent: width@12); borderWidth: 1. topView addSubView: infoView below: browserCodeView. ^ topView ! ! !FileContentsBrowser methodsFor: 'creation' stamp: 'sma 2/6/2000 11:59'! openAsMorph "Create a pluggable version of all the views for a Browser, including views and controllers." | window aListExtent next | window _ (SystemWindow labelled: 'later') model: self. self packages size = 1 ifTrue: [ aListExtent _ 0.333333 @ 0.34. self systemCategoryListIndex: 1. window addMorph: (PluggableListMorph on: self list: #systemCategorySingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #packageListMenu: keystroke: #packageListKey:from:) frame: (0@0 extent: 1.0@0.06). next := 0@0.06] ifFalse: [ aListExtent _ 0.25 @ 0.4. window addMorph: (PluggableListMorph on: self list: #systemCategoryList selected: #systemCategoryListIndex changeSelected: #systemCategoryListIndex: menu: #packageListMenu: keystroke: #packageListKey:from:) frame: (0@0 extent: aListExtent). next := aListExtent x @ 0]. window addMorph: (PluggableListMorph on: self list: #classList selected: #classListIndex changeSelected: #classListIndex: menu: #classListMenu: keystroke: #classListKey:from:) frame: (next extent: aListExtent - (0.0 @ 0.05)). window addMorph: self buildMorphicSwitches frame: (next + (0 @ (aListExtent y - 0.05)) extent: aListExtent x @ 0.05). next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageCategoryList selected: #messageCategoryListIndex changeSelected: #messageCategoryListIndex: menu: #messageCategoryMenu:) frame: (next extent: aListExtent). next := next + (aListExtent x @ 0). window addMorph: (PluggableListMorph on: self list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu: keystroke: #messageListKey:from:) frame: (next extent: aListExtent). window addMorph: (PluggableTextMorph on: self text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@0.4 corner: 1@0.94). window addMorph: (PluggableTextMorph on: self text: #infoViewContents accept: nil readSelection: nil menu: nil) frame: (0@0.94 corner: 1@1). ^ window ! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'sw 11/9/1999 18:26'! addModelItemsToWindowMenu: aMenu aMenu addLine. aMenu add: (self showDiffs ifTrue: ['stop showing diffs'] ifFalse: ['start showing diffs']) target: self action: #toggleDiffing ! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'sma 5/6/2000 18:36'! classListMenu: aMenu ^ aMenu labels: 'definition comment browse full (b) class refs (N) fileIn fileOut rename... remove remove existing' lines: #(2 4 6 8) selections: #(editClass editComment browseMethodFull browseClassRefs fileInClass fileOutClass renameClass removeClass removeUnmodifiedCategories) ! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'wod 5/13/1998 17:39'! messageCategoryMenu: aMenu ^ aMenu labels: 'fileIn fileOut reorganize add item... rename... remove remove existing' lines: #(2 3 6) selections: #(fileInMessageCategories fileOutMessageCategories editMessageCategories addCategory renameCategory removeMessageCategory removeUnmodifiedMethods)! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'jm 9/25/2006 22:02'! messageListMenu: aMenu ^ aMenu labels: 'fileIn fileOut senders (n) implementors (m) method inheritance versions (v) remove' lines: #(2 6) selections: #(fileInMessage fileOutMessage browseSenders browseImplementors methodHierarchy browseVersions removeMessage).! ! !FileContentsBrowser methodsFor: 'menus' stamp: 'sma 4/22/2000 20:52'! packageListMenu: aMenu ^ aMenu labels: 'find class... (f) fileIn file into new changeset fileOut remove remove existing' lines: #(1 4 5) selections: #(findClass fileInPackage fileIntoNewChangeSet fileOutPackage removePackage removeUnmodifiedClasses)! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:48'! classListKey: aChar from: view aChar == $b ifTrue: [^ self browseMethodFull]. aChar == $N ifTrue: [^ self browseClassRefs]. self packageListKey: aChar from: view! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 5/6/2000 18:50'! messageListKey: aChar from: view aChar == $b ifTrue: [^ self browseMethodFull]. super messageListKey: aChar from: view! ! !FileContentsBrowser methodsFor: 'keys' stamp: 'sma 2/6/2000 12:05'! packageListKey: aChar from: view aChar == $f ifTrue: [^ self findClass]. self arrowKey: aChar from: view! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'wod 5/13/1998 18:17'! browseFile: aFilename self browseFiles: (Array with: aFilename).! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'wod 5/14/1998 23:40'! browseFiles: fileList | package organizer packageDict browser | Cursor wait showWhile: [ packageDict _ Dictionary new. organizer _ SystemOrganizer defaultList: Array new. fileList do: [:fileName | package _ FilePackage fromFileNamed: fileName. packageDict at: package packageName put: package. organizer classifyAll: package classes keys under: package packageName]. (browser := self new) systemOrganizer: organizer; packages: packageDict]. self openBrowserView: browser createViews label: 'Package Browser'. ! ! !FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 01:01'! fullPathFor: path ^path isEmpty ifTrue:[pathName] ifFalse:[path]! ! !FileDirectory methodsFor: 'path access' stamp: 'ar 12/18/1999 00:36'! slash ^self class slash! ! !FileDirectory methodsFor: 'enumeration' stamp: 'wod 6/16/1998 15:07'! statsForDirectoryTree: rootedPathName "Return the size statistics for the entire directory tree starting at the given root. The result is a three element array of the form: (). This method also serves as an example of how recursively enumerate a directory tree." "wod 6/16/1998: add Cursor wait, and use 'self pathNameDelimiter asString' rather than hardwired ':' " "FileDirectory default statsForDirectoryTree: '\smalltalk'" | dirs files bytes todo p entries | Cursor wait showWhile: [ dirs _ files _ bytes _ 0. todo _ OrderedCollection with: rootedPathName. [todo isEmpty] whileFalse: [ p _ todo removeFirst. entries _ self directoryContentsFor: p. entries do: [:entry | (entry at: 4) ifTrue: [ todo addLast: (p, self pathNameDelimiter asString, (entry at: 1)). dirs _ dirs + 1] ifFalse: [ files _ files + 1. bytes _ bytes + (entry at: 5)]]]]. ^ Array with: dirs with: files with: bytes ! ! !FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:16'! directoryExists: filenameOrPath "Answer true if a directory of the given name exists. The given name may be either a full path name or a local directory within this directory." "FileDirectory default directoryExists: FileDirectory default pathName" | fName dir | FileDirectory splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. self isCaseSensitive ifTrue:[^dir directoryNames includes: fName] ifFalse:[^dir directoryNames anySatisfy: [:name| name sameAs: fName]]. ! ! !FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'! fileExists: filenameOrPath "Answer true if a file of the given name exists. The given name may be either a full path name or a local file within this directory." "FileDirectory default fileExists: Smalltalk sourcesName" | fName dir | FileDirectory splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. self isCaseSensitive ifTrue:[^dir fileNames includes: fName] ifFalse:[^dir fileNames anySatisfy: [:name| name sameAs: fName]]. ! ! !FileDirectory methodsFor: 'testing' stamp: 'jm 4/9/1999 17:48'! fileOrDirectoryExists: filenameOrPath "Answer true if either a file or a directory file of the given name exists. The given name may be either a full path name or a local name within this directory." "FileDirectory default fileOrDirectoryExists: Smalltalk sourcesName" | fName dir | FileDirectory splitName: filenameOrPath to: [:filePath :name | fName _ name. filePath isEmpty ifTrue: [dir _ self] ifFalse: [dir _ FileDirectory on: filePath]]. ^ dir includesKey: fName ! ! !FileDirectory methodsFor: 'testing' stamp: 'di 11/21/1999 20:17'! includesKey: localName "Answer true if this directory includes a file or directory of the given name. Note that the name should be a local file name, in contrast with fileExists:, which takes either local or full-qualified file names." "(FileDirectory on: Smalltalk vmPath) includesKey: 'SqueakV2.sources'" self isCaseSensitive ifTrue:[^ self fileAndDirectoryNames includes: localName] ifFalse:[^ self fileAndDirectoryNames anySatisfy: [:str| str sameAs: localName]].! ! !FileDirectory methodsFor: 'testing' stamp: 'ar 5/1/1999 01:51'! isCaseSensitive "Return true if file names are treated case sensitive" ^self class isCaseSensitive! ! !FileDirectory methodsFor: 'file operations' stamp: 'wod 11/5/1998 18:41'! copyFileNamed: fileName1 toFileNamed: fileName2 "Copy the contents of the existing file with the first name into a new file with the second name. Both files are assumed to be in this directory." "FileDirectory default copyFileNamed: 'todo.txt' toFileNamed: 'todocopy.txt'" | file1 file2 buffer | file1 _ (self readOnlyFileNamed: fileName1) binary. file2 _ (self newFileNamed: fileName2) binary. buffer _ String new: 50000. [file1 atEnd] whileFalse: [file2 nextPutAll: (file1 nextInto: buffer)]. file1 close. file2 close. ! ! !FileDirectory methodsFor: 'file operations' stamp: 'jm 4/9/1999 18:02'! deleteDirectory: localDirName "Delete the directory with the given name in this directory. Fail if the path is bad or if a directory by that name does not exist." self primDeleteDirectory: (self fullNameFor: localDirName). ! ! !FileDirectory methodsFor: 'file operations' stamp: 'ar 3/21/98 18:08'! deleteFileNamed: localFileName ifAbsent: failBlock "Delete the file of the given name if it exists, else evaluate failBlock. If the first deletion attempt fails do a GC to force finalization of any lost references. ar 3/21/98 17:53" (self retryWithGC:[self primDeleteFileNamed: (self fullNameFor: localFileName)] until:[:result| result notNil]) == nil ifTrue: [^failBlock value]. ! ! !FileDirectory methodsFor: 'file operations' stamp: 'tk 2/25/2000 15:30'! putFile: file1 named: destinationFileName "Copy the contents of the existing fileStream into the file destinationFileName in this directory. fileStream can be anywhere in the fileSystem." | file2 buffer | file1 binary. (file2 _ self newFileNamed: destinationFileName) ifNil: [^ false]. file2 binary. buffer _ String new: 50000. [file1 atEnd] whileFalse: [file2 nextPutAll: (file1 nextInto: buffer)]. file1 close. file2 close. ^ true ! ! !FileDirectory methodsFor: 'file operations' stamp: 'tk 3/31/2000 21:09'! rename: oldFileName toBe: newFileName | selection | "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name." "Modified for retry after GC ar 3/21/98 18:09" (self retryWithGC:[self primRename: (self fullNameFor: oldFileName) to: (self fullNameFor: newFileName)] until:[:result| result notNil]) ~~ nil ifTrue:[^self]. (self fileExists: oldFileName) ifFalse:[ ^self error:'Attempt to rename a non-existent file'. ]. (self fileExists: newFileName) ifTrue:[ selection _ (PopUpMenu labels: 'delete old version cancel') startUpWithCaption: 'Trying to rename a file to be ', newFileName , ' and it already exists.'. selection = 1 ifTrue: [self deleteFileNamed: newFileName. ^ self rename: oldFileName toBe: newFileName]]. ^self error:'Failed to rename file'.! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'acg 1/7/2000 08:00'! fullNameFor: fileName "Return a corrected, fully-qualified name for the given file name. If the given name is already a full path (i.e., it contains a delimiter character), assume it is already a fully-qualified name. Otherwise, prefix it with the path to this directory. In either case, correct the local part of the file name." "Details: Note that path relative to a directory, such as '../../foo' are disallowed by this algorithm." | correctedLocalName prefix | self class splitName: fileName to: [:filePath :localName | correctedLocalName _ localName isEmpty ifFalse: [self checkName: localName fixErrors: true] ifTrue: [localName]. prefix _ self fullPathFor: filePath]. prefix isEmpty ifTrue: [^correctedLocalName]. prefix last = self pathNameDelimiter ifTrue:[^ prefix, correctedLocalName] ifFalse:[^ prefix, self slash, correctedLocalName]! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'jm 5/29/2003 19:22'! nextNameFor: baseFileName extension: extension "Assumes a file name includes a version number encoded as '.' followed by digits preceding the file extension. Increment the version number and answer the new file name. If a version number is not found, set the version to 1 and answer a new file name" | files splits version | files _ self fileNamesMatching: (baseFileName,'*', self class dot, extension). splits _ (files collect: [:file | self splitNameVersionExtensionFor: file]) select: [:split | (split at: 1) = baseFileName]. splits _ splits asSortedCollection: [:a :b | (a at: 2) < (b at: 2)]. splits isEmpty ifTrue: [version _ 1] ifFalse: [version _ (splits last at: 2) + 1]. ^ (baseFileName, '.', version asString, self class dot, extension) asFileName! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'djp 10/27/1999 08:58'! splitNameVersionExtensionFor: fileName " answer an array with the root name, version # and extension. See comment in nextSequentialNameFor: for more details" | baseName version extension i j | baseName _ self class baseNameFor: fileName. extension _ self class extensionFor: fileName. i _ j _ baseName findLast: [:c | c isDigit not]. i = 0 ifTrue: [version _ 0] ifFalse: [(baseName at: i) = $. ifTrue: [version _ (baseName copyFrom: i+1 to: baseName size) asNumber. j _ j - 1] ifFalse: [version _ 0]. baseName _ baseName copyFrom: 1 to: j]. ^ Array with: baseName with: version with: extension! ! !FileDirectory methodsFor: 'file name utilities' stamp: 'jm 10/10/2003 09:58'! unusedNameStartingWith: prefix "Answer an unused file or directory name in this directory starting with the given prefix and ending with one or more digits." "FileDirectory default unusedNameStartingWith: 'tmp'" | usedNames i result | usedNames _ self fileAndDirectoryNames asSet. i _ 0. result _ prefix, '0'. [usedNames includes: result] whileTrue: [ result _ prefix, (i _ i + 1) printString]. ^ result ! ! !FileDirectory methodsFor: 'private' stamp: 'jm 8/14/1998 16:44'! directoryContentsFor: fullPath "Return a collection of directory entries for the files and directories in the directory with the given path. See primLookupEntryIn:index: for further details." "FileDirectory default directoryContentsFor: ''" | entries index done entryArray | entries _ OrderedCollection new: 200. index _ 1. done _ false. [done] whileFalse: [ entryArray _ self primLookupEntryIn: fullPath index: index. #badDirectoryPath = entryArray ifTrue: [^ OrderedCollection new]. entryArray == nil ifTrue: [done _ true] ifFalse: [entries addLast: (DirectoryEntry fromArray: entryArray)]. index _ index + 1]. ^ entries asArray ! ! !FileDirectory methodsFor: 'private' stamp: 'jm 4/9/1999 17:59'! primDeleteDirectory: fullPath "Delete the directory named by the given path. Fail if the path is bad or if a directory by that name does not exist." self primitiveFailed ! ! !FileDirectory methodsFor: 'private' stamp: 'jm 8/14/1998 16:43'! primLookupEntryIn: fullPath index: index "Look up the index-th entry of the directory with the given fully-qualified path (i.e., starting from the root of the file hierarchy) and return an array containing: The empty string enumerates the top-level files or drives. (For example, on Unix, the empty path enumerates the contents of '/'. On Macs and PCs, it enumerates the mounted volumes/drives.) The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given path is bad." ^ #badDirectoryPath ! ! !FileDirectory methodsFor: 'private' stamp: 'ar 3/21/98 18:04'! primRename: oldFileFullName to: newFileFullName "Rename the file of the given name to the new name. Fail if there is no file of the old name or if there is an existing file with the new name. Changed to return nil instead of failing ar 3/21/98 18:04" ^nil! ! !FileDirectory methodsFor: 'searching' stamp: 'sw 6/2/2000 21:55'! filesContaining: searchString caseSensitive: aBoolean | aList | "Search the contents of all files in the receiver and its subdirectories for the search string. Return a list of paths found. Make the search case sensitive if aBoolean is true." aList _ OrderedCollection new. self withAllFilesDo: [:stream | (stream contentsOfEntireFile includesSubstring: searchString caseSensitive: aBoolean) ifTrue: [aList add: stream name]] andDirectoriesDo: [:d | d pathName]. ^ aList "FileDirectory default filesContaining: 'includesSubstring:' caseSensitive: true"! ! !FileDirectory methodsFor: 'searching' stamp: 'SIM 5/22/2000 13:33'! withAllFilesDo: fileStreamBlock andDirectoriesDo: directoryBlock "For the receiver and all it's subdirectories evaluate directoryBlock. For a read only file stream on each file within the receiver and it's subdirectories evaluate fileStreamBlock." | todo dir | todo _ OrderedCollection with: self. [todo size > 0] whileTrue: [ dir _ todo removeFirst. directoryBlock value: dir. dir fileNames do: [: n | fileStreamBlock value: (FileStream readOnlyFileNamed: (dir fullNameFor: n))]. dir directoryNames do: [: n | todo add: (dir directoryNamed: n)]] ! ! !FileDirectory class methodsFor: 'instance creation' stamp: 'ls 9/10/1998 00:59'! forFileName: aString | path | path _ self dirPathFor: aString. path isEmpty ifTrue: [^ self default]. ^ self on: path ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'jm 11/14/2003 10:44'! baseNameFor: fileName "Answer the given file name without its extension, if any." | i | i _ fileName findLast: [:c | c = $.]. i = 0 ifTrue: [^ fileName] ifFalse: [^ fileName copyFrom: 1 to: i - 1]. ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'jm 11/14/2003 10:45'! extensionFor: fileName "Answer the extension of given file name, if any." | i | i _ fileName findLast: [:c | c = $.]. i = 0 ifTrue: [^ ''] ifFalse: [^ fileName copyFrom: i + 1 to: fileName size]. ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'jm 11/14/2003 10:32'! searchAllFilesForAString "Prompt the user for a search string and a starting directory. Search the contents of all files in the starting directory and its subdirectories for the search string (case-insensitive) and answer a collection of file paths." "FileDirectory searchAllFilesForAString" | searchString dir | searchString _ FillInTheBlankMorph request: 'Search string?'. searchString isEmpty ifTrue: [^ nil]. dir _ PluggableFileList getFolderDialog open. dir ifNil: [^ self]. ^ dir filesContaining: searchString caseSensitive: false ! ! !FileDirectory class methodsFor: 'name utilities' stamp: 'bf 3/22/2000 18:04'! splitName: fullName to: pathAndNameBlock "Take the file name and convert it to the path name of a directory and a local file name within that directory. FileName must be of the form: , where is optional. The part may contain delimiters." | delimiter i dirName localName | delimiter _ self pathNameDelimiter. (i _ fullName findLast: [:c | c = delimiter]) = 0 ifTrue: [dirName _ String new. localName _ fullName] ifFalse: [dirName _ fullName copyFrom: 1 to: (i - 1 max: 1). localName _ fullName copyFrom: i + 1 to: fullName size]. ^ pathAndNameBlock value: dirName value: localName! ! !FileDirectory class methodsFor: 'system start up' stamp: 'jbc 5/12/2000 17:09'! openSources: sourcesName andChanges: changesName forImage: imageName "Initialize the default directory to the image directory and open the sources and changes files, if possible. Look for the changes file in image directory. Look for the system sources (or an alias to it) first in the VM directory, then in the image directory. Open the changes and sources files and install them in SourceFiles." "Note: SourcesName and imageName are full paths; changesName is a local name." | sources changes sourceAlias msg wmsg localSourcesName | msg _ 'Squeak cannot locate &fileRef. Please check that the file is named properly and is in the same directory as this image. Further explanation can found in the startup window, ''How Squeak Finds Source Code''.'. wmsg _ 'Squeak cannot write to &fileRef. Please check that you have write permission for this file. You won''t be able to save this image correctly until you fix this.'. self setDefaultDirectoryFrom: imageName. sources _ changes _ nil. "look for the sources file or an alias to it in the VM's directory" (DefaultDirectory fileExists: sourcesName) ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourcesName] ifFalse: ["look for an un-renamed Macintosh alias to the sources file" sourceAlias _ sourcesName , ' alias'. (DefaultDirectory fileExists: sourceAlias) ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourceAlias]]. sources ifNil: ["look for the sources file or an alias to it in the image directory" localSourcesName _ FileDirectory localNameFor: sourcesName. (DefaultDirectory fileExists: localSourcesName) ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: localSourcesName] ifFalse: ["look for an un-renamed Macintosh alias to the sources file" sourceAlias _ localSourcesName , ' alias'. (DefaultDirectory fileExists: sourceAlias) ifTrue: [sources _ DefaultDirectory readOnlyFileNamed: sourceAlias]]]. (DefaultDirectory fileExists: changesName) ifTrue: [changes _ DefaultDirectory oldFileNamed: changesName. changes isNil ifTrue: [PopUpMenu notify: (wmsg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName). changes _ DefaultDirectory readOnlyFileNamed: changesName]]. ((sources == nil or: [sources atEnd]) and: [Preferences valueOfFlag: #warnIfNoSourcesFile]) ifTrue: [PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the sources file named ' , sourcesName). (Smalltalk getSystemAttribute: 1001) = 'Mac OS' ifTrue: [PopUpMenu notify: 'Make sure the sources file is not an Alias.']]. (changes == nil and: [Preferences valueOfFlag: #warnIfNoChangesFile]) ifTrue: [PopUpMenu notify: (msg copyReplaceAll: '&fileRef' with: 'the changes file named ' , changesName)]. SourceFiles _ Array with: sources with: changes! ! !FileDirectory class methodsFor: 'system start up' stamp: 'di 2/4/1999 15:27'! shutDown Smalltalk closeSourceFiles. ! ! !FileDirectory class methodsFor: 'system start up' stamp: 'di 2/4/1999 08:50'! startUp "Establish the platform-specific FileDirectory subclass. Do any platform-specific startup." self setDefaultDirectoryFrom: Smalltalk imageName. Smalltalk openSourceFiles. ! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'jm 11/14/2003 10:44'! dot "Answer a one-character string containing a period character." ^ '.' ! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'ar 5/1/1999 01:48'! isCaseSensitive "Return true if file names are treated case sensitive" ^true! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'jm 11/14/2003 10:50'! pathNameDelimiter "Answer the active directory class's directory separator character (e.g., '/' on Unix, ':' on Macintosh)." ^ DirectoryClass pathNameDelimiter ! ! !FileDirectory class methodsFor: 'platform specific' stamp: 'ar 4/18/1999 18:18'! slash ^ self pathNameDelimiter asString! ! !FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:47'! activeDirectoryClass "Return the concrete FileDirectory subclass for the platform on which we are currently running." FileDirectory allSubclasses do: [:class | class isActiveDirectoryClass ifTrue: [^ class]]. "no responding subclass; use FileDirectory" ^ FileDirectory ! ! !FileDirectory class methodsFor: 'private' stamp: 'TPR 5/10/1998 21:40'! isActiveDirectoryClass "Does this class claim to be that properly active subclass of FileDirectory for this platform? Default test is whether the primPathNameDelimiter matches the one for this class. Other tests are possible" ^self pathNameDelimiter = self primPathNameDelimiter ! ! I am model that can be used to navigate the host file system. By omitting the volume list, file list, and template panes from the view, I can also be used as the model for an editor on an individual file. FileLists can now see FTP servers anywhere on the net. In the volume list menu: fill in server info... Gives you a form to register a new ftp server you want to use. open server... Choose a server to connect to. local disk Go back to looking at your local volume. Still undone (you can contribute code): [ ] Using a Proxy server to get out through a firewall. What is the convention for proxy servers with FTP? [ ] Fill in the date and size info in the list of remote files. Allow sorting by it. New smarts needed in (ServerDirectory fileNameFormattedFrom:sizePad:sortMode:). [ ] Currently the FileList has no way to delete a directory. Since you can't select a directory without going into it, it would have to be deleting the current directory. Which would usually be empty. ! !FileList methodsFor: 'initialization' stamp: 'di 5/16/2000 09:42'! directory: dir "Set the path of the volume to be displayed." self okToChange ifFalse: [^ self]. self modelSleep. directory _ dir. self modelWakeUp. sortMode == nil ifTrue: [sortMode _ #date]. volList _ ((Array with: '[]'), directory pathParts) "Nesting suggestion from RvL" withIndexCollect: [:each :i | ( String new: i-1 withAll: $ ), each]. self changed: #relabel. self changed: #volumeList. self pattern: pattern! ! !FileList methodsFor: 'initialization' stamp: 'jm 7/17/2003 22:30'! modelSleep "User has exited or collapsed the window--close any remote connections." ! ! !FileList methodsFor: 'initialization' stamp: 'sbw 12/30/1999 15:53'! optionalButtonHeight ^ 15! ! !FileList methodsFor: 'initialization' stamp: 'jm 10/13/2002 18:06'! optionalButtonRow | aRow aButton | aRow _ AlignmentMorph newRow. aRow isSticky: true. aRow setProperty: #clipToOwnerWidth toValue: true. aRow addTransparentSpacerOfSize: (5@0). self optionalButtonSpecs do: [:spec | aButton _ PluggableButtonMorph on: self getState: nil action: spec second. aButton useRoundedCorners; label: spec first asString; askBeforeChanging: true; onColor: Color transparent offColor: Color transparent. aRow addMorphBack: aButton. aRow addTransparentSpacerOfSize: (3 @ 0). aButton setBalloonText: spec fourth. aRow addTransparentSpacerOfSize: (3 @ 0). (spec second == #sortBySize) ifTrue: [aRow addTransparentSpacerOfSize: (4@0)]]. ^ aRow! ! !FileList methodsFor: 'initialization' stamp: 'sw 1/7/2000 15:55'! optionalButtonSpecs ^ #( ('Name' sortByName sortingByName 'sort entries by name') ('Date' sortByDate sortingByDate 'sort entries by date') ('Size' sortBySize sortingBySize 'sort entries by size') ('Changes' browseChanges none 'open a changelist browser on selected file') ('File-in' fileInSelection none 'fileIn the selected file') ('File-in to New' fileIntoNewChangeSet none 'fileIn the selected file into a new change set') ('Delete' deleteFile none 'delete the seleted item')) ! ! !FileList methodsFor: 'initialization' stamp: 'sw 1/7/2000 15:56'! optionalButtonView | aView bHeight windowWidth offset previousView aButtonView wid specs | aView _ View new model: self. bHeight _ self optionalButtonHeight. windowWidth _ 120. aView window: (0@0 extent: windowWidth@bHeight). offset _ 0. specs _ self optionalButtonSpecs copyFrom: 1 to: 6. "Too cramped for the seventh!!" previousView _ nil. specs do: [:quad | aButtonView _ PluggableButtonView on: self getState: (quad third == #none ifTrue: [nil] ifFalse: [quad third]) action: quad second. quad second = specs last second ifTrue: [wid _ windowWidth - offset] ifFalse: [aButtonView borderWidthLeft: 0 right: 1 top: 0 bottom: 0. wid _ (windowWidth // (specs size)) - 2]. aButtonView label: quad first asParagraph; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. quad second = specs first second ifTrue: [aView addSubView: aButtonView] ifFalse: [aView addSubView: aButtonView toRightOf: previousView]. previousView _ aButtonView]. ^aView ! ! !FileList methodsFor: 'initialization' stamp: 'di 5/11/1999 22:25'! release self modelSleep! ! !FileList methodsFor: 'volume list and pattern' stamp: 'ar 6/16/1999 06:58'! deleteDirectory "Remove the currently selected directory" | localDir | directory entries size = 0 ifFalse:[^self inform:'Directory must be empty']. localDir _ directory pathParts last. (self confirm: 'Really delete ' , localDir printString , '?') ifFalse: [^ self]. self volumeListIndex: self volumeListIndex-1. directory deleteDirectory: localDir. self updateFileList.! ! !FileList methodsFor: 'volume list and pattern' stamp: 'ls 7/25/1998 01:15'! fileNameFormattedFrom: entry sizePad: sizePad "entry is a 5-element array of the form: (name creationTime modificationTime dirFlag fileSize)" | sizeStr nameStr dateStr | nameStr _ (entry at: 4) ifTrue: [entry first , self folderString] ifFalse: [entry first]. dateStr _ ((Date fromSeconds: (entry at: 3) ) printFormat: #(3 2 1 $. 1 1 2)) , ' ' , (String streamContents: [:s | (Time fromSeconds: (entry at: 3) \\ 86400) print24: true on: s]). sizeStr _ (entry at: 5) asStringWithCommas. sortMode = #name ifTrue: [^ nameStr , ' (' , dateStr , ' ' , sizeStr , ')']. sortMode = #date ifTrue: [^ '(' , dateStr , ' ' , sizeStr , ') ' , nameStr]. sortMode = #size ifTrue: [^ '(' , ((sizeStr size to: sizePad) collect: [:i | $ ]) , sizeStr , ' ' , dateStr , ') ' , nameStr]. ! ! !FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/23/2003 13:20'! listForPattern: pat "Make the list be those file names which match the pattern." | entries sizePad newList allFiles sortBlock | entries _ directory entries. sizePad _ (entries inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. "create block to decide what order to display the entries" sortBlock _ [ :x :y | (x isDirectory = y isDirectory) ifTrue: [ "sort by user-specified criterion" sortMode = #name ifTrue: [(x name compare: y name) <= 2] ifFalse: [ sortMode = #date ifTrue: [ x modificationTime = y modificationTime ifTrue: [ (x name compare: y name) <= 2 ] ifFalse: [ x modificationTime > y modificationTime ] ] ifFalse: [ "size" x fileSize = y fileSize ifTrue: [ (x name compare: y name) <= 2 ] ifFalse: [ x fileSize > y fileSize ] ] ] ] ifFalse: [ "directories always precede files" x isDirectory ] ]. newList _ (SortedCollection new: 30) sortBlock: sortBlock. allFiles _ pat = '*'. entries do: [:entry | "" (allFiles or: [entry isDirectory or: [pat match: entry first]]) ifTrue: [newList add: entry]]. newList _ newList collect: [ :e | self fileNameFormattedFrom: e sizePad: sizePad ]. ^ newList asArray ! ! !FileList methodsFor: 'volume list and pattern' stamp: 'stp 12/11/1999 19:37'! volumeListIndex: index "Select the volume name having the given index." | delim path | volListIndex := index. index = 1 ifTrue: [self directory: (FileDirectory on: '')] ifFalse: [delim := directory pathNameDelimiter. path := String streamContents: [:strm | 2 to: index do: [:i | strm nextPutAll: (volList at: i) withBlanksTrimmed. i < index ifTrue: [strm nextPut: delim]]]. self directory: (directory on: path)]. brevityState := #FileList. self addPath: path. self changed: #fileList. self changed: #contents! ! !FileList methodsFor: 'volume list and pattern' stamp: 'jm 5/23/2003 13:22'! volumeMenu: aMenu ^ aMenu labels: 'recent... delete directory...' lines: # (1) selections: #(recentDirs deleteDirectory) ! ! !FileList methodsFor: 'file list' stamp: 'jm 5/23/2003 13:19'! fileListIndex: anInteger "Select the file name having the given index, and display its contents." | item name | self okToChange ifFalse: [^ self]. listIndex := anInteger. listIndex = 0 ifTrue: [fileName := nil] ifFalse: [item := self fileNameFromFormattedItem: (list atPin: anInteger). (item endsWith: self folderString) ifTrue: ["remove [...] folder string and open the folder" name := item copyFrom: 1 to: item size - self folderString size. listIndex := 0. brevityState := #FileList. self addPath: name. name first = $^ ifTrue: [self error: 'remote directories not supported'] ifFalse: [volListIndex = 1 ifTrue: [name _ name, directory slash]. self directory: (directory directoryNamed: name)]] ifFalse: [fileName := item]]. "open the file selected" brevityState := #needToGetBrief. self changed: #fileListIndex. self changed: #contents! ! !FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:03'! addNew: aString byEvaluating: aBlock "A parameterization of earlier versions of #addNewDirectory and #addNewFile. Fixes the bug in each that pushing the cancel button in the FillInTheBlank dialog gave a walkback." | response newName index ending | self okToChange ifFalse: [^ self]. (response _ FillInTheBlank request: 'New ',aString,' Name?' initialAnswer: aString,'Name') isEmpty ifTrue: [^ self]. newName _ response asFileName. Cursor wait showWhile: [ aBlock value: newName]. self updateFileList. index _ list indexOf: newName. index = 0 ifTrue: [ending _ ') ',newName. index _ list findFirst: [:line | line endsWith: ending]]. self fileListIndex: index. ! ! !FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:04'! addNewDirectory self addNew: 'Directory' byEvaluating: [:newName | directory createDirectory: newName] ! ! !FileList methodsFor: 'file list menu' stamp: 'sge 11/28/1999 09:04'! addNewFile self addNew: 'File' byEvaluating: [:newName | (directory newFileNamed: newName) close] ! ! !FileList methodsFor: 'file list menu' stamp: 'sw 7/8/1999 16:05'! browseChanges "Browse the selected file in fileIn format." fileName ifNotNil: [ChangeList browseStream: (directory oldFileNamed: fileName)] ifNil: [self beep]. ! ! !FileList methodsFor: 'file list menu' stamp: 'tk 3/15/2000 10:32'! compressFile "Compress the currently selected file" (directory readOnlyFileNamed: self fullName) compressFile. self updateFileList! ! !FileList methodsFor: 'file list menu' stamp: 'di 4/28/1999 11:33'! copyName listIndex = 0 ifTrue: [^ self]. ParagraphEditor clipboardTextPut: self fullName asText. ! ! !FileList methodsFor: 'file list menu' stamp: 'jm 9/17/2006 11:23'! covertToUnix "Replace all CR's with LF's." | fileContents | fileContents _ (FileStream readOnlyFileNamed: self fullName) contentsOfEntireFile. fileContents _ fileContents collect: [:ch | ch = Character cr ifTrue: [Character lf] ifFalse: [ch]]. (StandardFileStream newFileNamed: self fullName) nextPutAll: fileContents; close. ! ! !FileList methodsFor: 'file list menu' stamp: 'di 8/16/1998 12:22'! deleteFile "Delete the currently selected file" listIndex = 0 ifTrue: [^ self]. (self confirm: 'Really delete ' , fileName , '?') ifFalse: [^ self]. directory deleteFileNamed: fileName. self updateFileList. brevityState _ #FileList. self get! ! !FileList methodsFor: 'file list menu' stamp: 'sma 5/20/2000 18:30'! fileAllIn "File in all of the currently selected file, if any." "wod 5/24/1998: open the file read only." | fn ff | listIndex = 0 ifTrue: [^ self]. ff _ directory readOnlyFileNamed: (fn _ self uncompressedFileName). ((self getSuffix: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. ff fileIn! ! !FileList methodsFor: 'file list menu' stamp: 'jm 9/25/2006 21:52'! fileContentsMenu: aMenu shifted: shifted | shiftMenu | ^ shifted ifFalse: [aMenu labels: 'get entire file view as hex browse changes find...(f) find again (g) set search string (e) do again (j) undo (z) copy (c) cut (x) paste (v) paste... do it (d) print it (p) inspect it (i) fileIn selection accept (s) cancel (l) more...' lines: #(3 6 8 12 16 18) selections: #(get getHex browseChanges find findAgain setSearchString again undo copySelection cut paste pasteRecent doIt printIt inspectIt fileItIn accept cancel shiftedYellowButtonActivity)] ifTrue: [shiftMenu _ ParagraphEditor shiftedYellowButtonMenu. aMenu labels: shiftMenu labelString lines: shiftMenu lineArray selections: shiftMenu selections] ! ! !FileList methodsFor: 'file list menu' stamp: 'jwh 5/24/2000 12:35'! fileIntoNewChangeSet "File in all of the contents of the currently selected file, if any, into a new change set." | fn ff | listIndex = 0 ifTrue: [^ self]. ff _ directory readOnlyFileNamed: (fn _ self uncompressedFileName). ((self getSuffix: fn) sameAs: 'html') ifTrue: [ff _ ff asHtml]. ChangeSorter newChangesFromStream: ff named: (FileDirectory localNameFor: fn)! ! !FileList methodsFor: 'file list menu' stamp: 'sma 5/20/2000 18:29'! fileNameSuffix ^ self getSuffix: self fullName! ! !FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 16:06'! fileSelectedMenu: aMenu | firstItems secondItems thirdItems n1 n2 n3 | firstItems _ self itemsForFileEnding: self fileNameSuffix asLowercase. secondItems _ self itemsForAnyFile. thirdItems _ self itemsForNoFile. n1 _ firstItems first size. n2 _ n1 + secondItems first size. n3 _ n2 + thirdItems first size. ^ aMenu labels: firstItems first , secondItems first , thirdItems first , #('more...') lines: firstItems second , (Array with: n1 with: n2) , (thirdItems second collect: [:n | n + n2]) , (Array with: n3) selections: firstItems third , secondItems third , thirdItems third , #(offerAllFileOptions)! ! !FileList methodsFor: 'file list menu' stamp: 'ar 1/2/2000 15:30'! itemsForAnyFile ^ #(('copy name to clipboard' 'rename' 'delete' 'compress') () (copyName renameFile deleteFile compressFile) )! ! !FileList methodsFor: 'file list menu' stamp: 'jm 9/17/2006 11:23'! itemsForFileEnding: suffix | labels lines selectors | labels _ OrderedCollection new. lines _ OrderedCollection new. selectors _ OrderedCollection new. (#('bmp' 'gif' 'jpg' 'jpeg' 'form' 'png' '*') includes: suffix) ifTrue: [ labels addAll: #('open image in a window'). selectors addAll: #(openImageInWindow)]. (#('mid' 'midi' '*') includes: suffix) ifTrue: [ labels add: 'play midi file'. selectors add: #playMidiFile]. (#('st' 'cs' '*') includes: suffix) ifTrue: [ suffix = '*' ifTrue: [lines add: labels size]. labels addAll: #('fileIn' 'file into new change set' 'browse changes' 'browse code' 'remove line feeds' 'convert to Unix'). lines add: labels size - 1. selectors addAll: #(fileInSelection fileIntoNewChangeSet browseChanges browseFile removeLinefeeds covertToUnix)]. (#('gz' '*') includes: suffix) ifTrue: [ labels addAll: #('view decompressed' 'decompress to file'). selectors addAll: #(viewGZipContents saveGZipContents)]. ^ Array with: labels with: lines with: selectors ! ! !FileList methodsFor: 'file list menu' stamp: 'di 11/19/1998 14:25'! itemsForNoFile ^ #( ('sort by name' 'sort by size' 'sort by date' 'browse code files' 'add new file' 'add new directory') (3 4) (sortByName sortBySize sortByDate browseFiles addNewFile addNewDirectory) )! ! !FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 09:34'! noFileSelectedMenu: aMenu | items | items _ self itemsForNoFile. ^ aMenu labels: items first lines: items second selections: items third ! ! !FileList methodsFor: 'file list menu' stamp: 'di 8/20/1998 16:05'! offerAllFileOptions | items action | items _ self itemsForFileEnding: '*'. action _ (SelectionMenu labels: items first lines: items second selections: items third) startUp. action ifNotNil: [self perform: action]! ! !FileList methodsFor: 'file list menu' stamp: 'sma 4/30/2000 09:38'! openImageInWindow "Handle five file formats: GIF, JPG, PNG, Form stoteOn: (run coded), and BMP. Fail if file format is not recognized." | image | image _ Form fromFileNamed: self fullName. Smalltalk isMorphic ifTrue: [World addMorph: (SketchMorph withForm: image)] ifFalse: [FormView open: image named: fileName]! ! !FileList methodsFor: 'file list menu' stamp: 'jm 5/23/2003 13:18'! 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." (#(get getHex browseChanges sortByDate sortBySize sortByName fileInSelection fileIntoNewChangeSet browseChanges copyName openImageInWindow playMidiFile renameFile deleteFile addNewFile) includes: selector) ifTrue: [^ self perform: selector] ifFalse: [^ super perform: selector orSendTo: otherTarget]! ! !FileList methodsFor: 'file list menu' stamp: 'jm 5/29/1998 17:09'! playMidiFile "Play a MIDI file." | f score | Smalltalk at: #MIDIFileReader ifPresent: [:midiReader | Smalltalk at: #ScorePlayerMorph ifPresent: [:scorePlayer | f _ (directory oldFileNamed: self fullName) binary. score _ (midiReader new readMIDIFrom: f) asScore. f close. scorePlayer openOn: score title: fileName]]. ! ! !FileList methodsFor: 'file list menu' stamp: 'ar 9/3/1999 13:05'! removeLinefeeds "Remove any line feeds by converting to CRs instead" | fileContents | fileContents _ (CrLfFileStream readOnlyFileNamed: self fullName) contentsOfEntireFile. (StandardFileStream newFileNamed: self fullName) nextPutAll: fileContents; close.! ! !FileList methodsFor: 'file list menu' stamp: 'sge 2/13/2000 04:36'! renameFile "Rename the currently selected file" | newName response | listIndex = 0 ifTrue: [^ self]. self okToChange ifFalse: [^ self]. (response _ FillInTheBlank request: 'NewFileName?' initialAnswer: fileName) isEmpty ifTrue: [^ self]. newName _ response asFileName. newName = fileName ifTrue: [^ self]. directory rename: fileName toBe: newName. self updateFileList. listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = newName]. listIndex > 0 ifTrue: [fileName _ newName]. self changed: #fileListIndex. ! ! !FileList methodsFor: 'file list menu' stamp: 'jm 6/20/2003 09:51'! saveGZipContents "Save the contents of a gzipped file." | newName unzipped zipped buffer | newName _ FileDirectory baseNameFor: fileName. unzipped _ directory newFileNamed: newName. zipped _ GZipReadStream on: (directory readOnlyFileNamed: self fullName). buffer _ String new: 50000. 'Extracting ' , self fullName displayProgressAt: Sensor cursorPoint from: 0 to: zipped sourceStream size during: [:bar | [zipped atEnd] whileFalse: [bar value: zipped sourceStream position. unzipped nextPutAll: (zipped nextInto: buffer)]. zipped close. unzipped close]. self updateFileList. ^ newName! ! !FileList methodsFor: 'file list menu' stamp: 'mjg 9/1/1998 14:10'! templateFile ^' <?request name?> ' ! ! !FileList methodsFor: 'file list menu' stamp: 'ar 1/2/2000 15:31'! viewGZipContents "View the contents of a gzipped file" | f | f _ (directory readOnlyFileNamed: self fullName). contents _ f contentsOfEntireFile. Cursor wait showWhile:[contents _ (GZipReadStream on: contents) upToEnd]. contents replaceAll: Character lf with: Character cr. (StringHolder new) contents: contents; openLabel:'Contents of ', fileName printString! ! !FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:05'! addPath: aString "Add the given string to the list of recently visited directories." | full | aString ifNil: [^self]. full := String streamContents: [ :strm | 2 to: volList size do: [ :i | strm nextPutAll: (volList at: i) withBlanksTrimmed. strm nextPut: FileDirectory pathNameDelimiter]]. full := full, aString. "Remove and super-directories of aString from the collection." RecentDirs removeAllSuchThat: [ :aDir | ((aDir, '*') match: full)]. "If a sub-directory is in the list, do nothing." (RecentDirs detect: [ :aDir | ((full, '*') match: aDir)] ifNone: [nil]) ifNotNil: [^self]. [RecentDirs size >= 10] whileTrue: [RecentDirs removeFirst]. RecentDirs addLast: full! ! !FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:26'! contents "Answer the contents of the file, reading it first if needed." "Possible brevityState values: FileList, fullFile, briefFile, needToGetFull, needToGetBrief, fullHex, briefHex, needToGetFullHex, needToGetBriefHex" (listIndex = 0) | (brevityState == #FileList) ifTrue: [^ self defaultContents]. "no file selected" brevityState == #fullFile ifTrue: [^ contents]. brevityState == #fullHex ifTrue: [^ contents]. brevityState == #briefFile ifTrue: [^ contents]. brevityState == #briefHex ifTrue: [^ contents]. brevityState == #needToGetFullHex ifTrue: [^ self readContentsHex: false]. brevityState == #needToGetBriefHex ifTrue: [^ self readContentsHex: true]. brevityState == #needToGetFull ifTrue: [^ self readContentsBrief: false]. brevityState == #needToGetBrief ifTrue: [^ self readContentsBrief: true]. "default" self halt: 'unknown state ' , brevityState printString! ! !FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:25'! defaultContents contents _ list == nil ifTrue: [String new] ifFalse: [String streamContents: [:s | s nextPutAll: 'NO FILE SELECTED'; cr. s nextPutAll: ' -- Folder Summary --'; cr. list do: [:item | s nextPutAll: item; cr]]]. brevityState _ #FileList. ^ contents! ! !FileList methodsFor: 'private' stamp: 'sma 4/30/2000 09:41'! errorMustBeMorph self inform: 'Can only load a single morph into an mvc project via this mechanism.'! ! !FileList methodsFor: 'private'! fileNameFromFormattedItem: item "Extract fileName and folderString from a formatted fileList item string" | i | (i _ item indexOf: $( ifAbsent: [0]) = 0 ifTrue: [^ item withBlanksTrimmed]. ^ (item copyReplaceFrom: i to: (item findFirst: [:c | c = $)]) with: '') withBlanksTrimmed! ! !FileList methodsFor: 'private' stamp: 'sma 5/20/2000 18:29'! getSuffix: aString | i | i _ aString findLast: [:each | $. = each]. ^ i = 0 ifTrue: [''] ifFalse: [aString copyFrom: i + 1 to: aString size]! ! !FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:46'! put: aText | ff type | brevityState == #fullFile ifTrue: [ff _ directory newFileNamed: self fullName. Cursor write showWhile: [ff nextPutAll: aText asString; close]. fileName = ff localName ifTrue: [contents _ aText asString] ifFalse: [self updateFileList]. "user renamed the file" ^ true "accepted"]. listIndex = 0 ifTrue: [PopUpMenu notify: 'No fileName is selected'. ^ false "failed"]. type _ 'These'. brevityState = #briefFile ifTrue: [type _ 'Abbreviated']. brevityState = #briefHex ifTrue: [type _ 'Abbreviated']. brevityState = #fullHex ifTrue: [type _ 'Hexadecimal']. brevityState = #FileList ifTrue: [type _ 'Directory']. PopUpMenu notify: type , ' contents cannot meaningfully be saved at present.'. ^ false "failed" ! ! !FileList methodsFor: 'private' stamp: 'jm 5/23/2003 13:21'! readContentsBrief: brevityFlag "Read the contents of the receiver's selected file, unless it is too long, in which case show just the first 5000 characters. Don't create a file if it doesn't already exist." | f fileSize first5000 | f _ directory oldFileOrNoneNamed: self fullName. f ifNil: [^ 'For some reason, this file cannot be read']. (brevityFlag not or: [(fileSize _ f size) <= 100000]) ifTrue: [contents _ f contentsOfEntireFile. brevityState _ #fullFile. "don't change till actually read" ^ contents]. "if brevityFlag is true, don't display long files when first selected" first5000 _ f next: 5000. f close. contents _ 'File ''', fileName, ''' is ', fileSize printString, ' bytes long. You may use the ''get'' command to read the entire file. Here are the first 5000 characters... ------------------------------------------ ', first5000 , ' ------------------------------------------ ... end of the first 5000 characters.'. brevityState _ #briefFile. "don't change till actually read" ^ contents. ! ! !FileList methodsFor: 'private' stamp: 'di 8/16/1998 09:20'! readContentsHex: brevity "retrieve the contents from the external file unless it is too long. Don't create a file here. Check if exists." | f size data hexData s | f _ directory oldFileOrNoneNamed: self fullName. f == nil ifTrue: [^ 'For some reason, this file cannot be read']. ((size _ f size)) > 5000 & brevity ifTrue: [data _ f next: 10000. f close. brevityState _ #briefHex] ifFalse: [data _ f contentsOfEntireFile. brevityState _ #fullHex]. s _ WriteStream on: (String new: data size*4). 0 to: data size-1 by: 16 do: [:loc | s nextPutAll: loc hex; space; nextPut: $(; print: loc; nextPut: $); space; tab. loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space]. s cr]. hexData _ s contents. ^ contents _ ((size > 5000) & brevity ifTrue: ['File ''', fileName, ''' is ', size printString, ' bytes long. You may use the ''get'' command to read the entire file. Here are the first 5000 characters... ------------------------------------------ ', hexData , ' ------------------------------------------ ... end of the first 5000 characters.'] ifFalse: [hexData]). ! ! !FileList methodsFor: 'private' stamp: 'stp 12/11/1999 20:03'! recentDirs "Put up a menu and let the user select from the list of recently visited directories." | dirName | RecentDirs isEmpty ifTrue: [^self]. dirName := (SelectionMenu selections: RecentDirs) startUp. dirName == nil ifTrue: [^self]. self directory: (FileDirectory on: dirName)! ! !FileList methodsFor: 'private' stamp: 'ls 9/11/1998 04:15'! resort: newMode "Re-sort the list of files." | name | listIndex > 0 ifTrue: [name _ self fileNameFromFormattedItem: (list at: listIndex)]. sortMode _ newMode. self pattern: pattern. name ifNotNil: [ fileName _ name. listIndex _ list findFirst: [:item | (self fileNameFromFormattedItem: item) = name. ]. self changed: #fileListIndex]. listIndex = 0 ifTrue: [self changed: #contents] ! ! !FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'! sortingByDate ^ sortMode == #date! ! !FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:57'! sortingByName ^ sortMode == #name! ! !FileList methodsFor: 'private' stamp: 'sw 1/7/2000 15:58'! sortingBySize ^ sortMode == #size! ! !FileList methodsFor: 'private' stamp: 'sma 5/20/2000 18:31'! uncompressedFileName | f | f _ self fullName. ((f endsWith: '.gz') and: [self confirm: f , ' appears to be a compressed file. Do you want to uncompress it?']) ifFalse: [^ f]. ^ self saveGZipContents! ! !FileList methodsFor: 'private' stamp: 'wod 5/27/1998 17:47'! updateFileList "Update my files list with file names in the current directory that match the pattern." "wod 5/27/1998: nil out the fileName." Cursor execute showWhile: [list _ (pattern includes: $*) | (pattern includes: $#) ifTrue: [self listForPattern: pattern] ifFalse: [ pattern isEmpty ifTrue: [self listForPattern: '*'] ifFalse: [self listForPattern: '*', pattern, '*']]. listIndex _ 0. volListIndex _ volList size. fileName _ nil. contents _ ''. self changed: #volumeListIndex. self changed: #fileList]. ! ! !FileList methodsFor: 'menu messages' stamp: 'wod 5/13/1998 04:10'! browseFile FileContentsBrowser browseFile: self fullName.! ! !FileList methodsFor: 'menu messages' stamp: 'wod 5/13/1998 04:10'! browseFiles | selectionPattern fileList | selectionPattern := FillInTheBlank request:'What files?' initialAnswer: self pattern. fileList _ (directory fileNamesMatching: selectionPattern) collect: [:each | directory fullNameFor: each]. FileContentsBrowser browseFiles: fileList. ! ! !FileList class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:30'! open "Open a view of an instance of me on the default directory." "FileList open" | dir aFileList topView volListView templateView fileListView fileContentsView underPane pHeight | Smalltalk isMorphic ifTrue: [^ self openAsMorph]. dir _ FileDirectory default. aFileList _ self new directory: dir. topView _ StandardSystemView new. topView model: aFileList; label: dir pathName; minimumSize: 200@200. topView borderWidth: 1. volListView _ PluggableListView on: aFileList list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:. volListView autoDeselect: false. volListView window: (0@0 extent: 80@45). topView addSubView: volListView. templateView _ PluggableTextView on: aFileList text: #pattern accept: #pattern:. templateView askBeforeDiscardingEdits: false. templateView window: (0@0 extent: 80@15). topView addSubView: templateView below: volListView. Preferences optionalButtons ifTrue: [ underPane _ aFileList optionalButtonView. underPane isNil ifTrue: [pHeight _ 60] ifFalse: [ topView addSubView: underPane toRightOf: volListView. pHeight _ 60 - aFileList optionalButtonHeight]] ifFalse: [ underPane _ nil. pHeight _ 60]. fileListView _ PluggableListView on: aFileList list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. fileListView window: (0@0 extent: 120@pHeight). underPane isNil ifTrue: [topView addSubView: fileListView toRightOf: volListView] ifFalse: [topView addSubView: fileListView below: underPane]. fileListView controller terminateDuringSelect: true. "Pane to left may change under scrollbar" fileContentsView _ PluggableTextView on: aFileList text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:. fileContentsView window: (0@0 extent: 200@140). topView addSubView: fileContentsView below: templateView. topView controller open. ! ! !FileList class methodsFor: 'instance creation' stamp: 'sw 12/13/1999 10:26'! openAsMorph "Open a morphic view of a FileList on the default directory." | dir aFileList window fileListTop | dir _ FileDirectory default. aFileList _ self new directory: dir. window _ (SystemWindow labelled: dir pathName) model: aFileList. window addMorph: ((PluggableListMorph on: aFileList list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:) autoDeselect: false) frame: (0@0 corner: 0.3@0.2). window addMorph: (PluggableTextMorph on: aFileList text: #pattern accept: #pattern:) frame: (0@0.2 corner: 0.3@0.3). Preferences optionalButtons ifTrue: [window addMorph: aFileList optionalButtonRow frame: (0.3 @ 0 corner: 1 @ 0.08). fileListTop _ 0.08] ifFalse: [fileListTop _ 0]. window addMorph: (PluggableListMorph on: aFileList list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:) frame: (0.3 @ fileListTop corner: 1@0.3). window addMorph: (PluggableTextMorph on: aFileList text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:) frame: (0@0.3 corner: 1@1). ^ window! ! !FileList class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:31'! openEditorOn: aFileStream editString: editString "Open an editor on the given FileStream." | fileModel topView fileContentsView | Smalltalk isMorphic ifTrue: [^ (self openMorphOn: aFileStream editString: editString) openInWorld]. fileModel _ FileList new setFileStream: aFileStream. "closes the stream" topView _ StandardSystemView new. topView model: fileModel; label: aFileStream fullName; minimumSize: 180@120. topView borderWidth: 1. fileContentsView _ PluggableTextView on: fileModel text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:. fileContentsView window: (0@0 extent: 180@120). topView addSubView: fileContentsView. editString ifNotNil: [fileContentsView editString: editString. fileContentsView hasUnacceptedEdits: true]. topView controller open. ! ! !FileList class methodsFor: 'instance creation' stamp: 'di 10/18/1999 22:34'! openMorphOn: aFileStream editString: editString "Open a morphic view of a FileList on the given file." | fileModel window fileContentsView | fileModel _ FileList new setFileStream: aFileStream. "closes the stream" window _ (SystemWindow labelled: aFileStream fullName) model: fileModel. window addMorph: (fileContentsView _ PluggableTextMorph on: fileModel text: #contents accept: #put: readSelection: #contentsSelection menu: #fileContentsMenu:shifted:) frame: (0@0 corner: 1@1). editString ifNotNil: [fileContentsView editString: editString. fileContentsView hasUnacceptedEdits: true]. ^ window! ! !FileList class methodsFor: 'class initialization' stamp: 'stp 12/11/1999 19:47'! initialize "FileList initialize" RecentDirs := OrderedCollection new! ! !FilePackage methodsFor: 'accessing'! classAt: className ^self classes at: className! ! !FilePackage methodsFor: 'accessing'! classes ^classes! ! !FilePackage methodsFor: 'accessing'! fullPackageName ^fullName! ! !FilePackage methodsFor: 'accessing'! packageInfo ^String streamContents:[:s| s nextPutAll:'Package: '. s nextPutAll: self fullPackageName; cr; cr. sourceSystem isEmpty ifFalse:[ s nextPutAll: sourceSystem; cr; cr]. doIts isEmpty ifFalse:[ s nextPutAll:'Unresolvable doIts:'; cr; cr. doIts do:[:chgRec| s nextPut:$!!; nextPutAll: chgRec string; nextPut: $!!; cr]]].! ! !FilePackage methodsFor: 'accessing'! packageName ^packageName! ! !FilePackage methodsFor: 'accessing'! removeClass: aPseudoClass (self classes removeKey: aPseudoClass name). classOrder copy do:[:cls| cls name = aPseudoClass name ifTrue:[ classOrder remove: cls]. ].! ! !FilePackage methodsFor: 'accessing'! renameClass: aPseudoClass to: newName | oldName | oldName := aPseudoClass name. self classes removeKey: oldName. self classes at: newName put: aPseudoClass. aPseudoClass renameTo: newName.! ! !FilePackage methodsFor: 'initialize'! fromFileNamed: aName | stream | fullName := aName. packageName := FileDirectory localNameFor: fullName. stream := FileStream readOnlyFileNamed: aName. doIts := OrderedCollection new. classOrder := OrderedCollection new. sourceSystem := ''. self fileInFrom: stream.! ! !FilePackage methodsFor: 'private'! classDefinition: string with: chgRec | tokens theClass | tokens := Scanner new scanTokens: string. tokens size = 11 ifFalse:[^doIts add: chgRec]. theClass := self getClass: (tokens at: 3). theClass definition: string. classOrder add: theClass.! ! !FilePackage methodsFor: 'private'! getClass: className | pseudoClass | (classes includesKey: className) ifTrue:[ ^classes at: className. ]. pseudoClass := PseudoClass new. pseudoClass name: className. classes at: className put: pseudoClass. ^pseudoClass.! ! !FilePackage methodsFor: 'private'! metaClassDefinition: string with: chgRec | tokens theClass | tokens := Scanner new scanTokens: string. theClass := self getClass: (tokens at: 1). theClass metaClass definition: string. classOrder add: theClass metaClass.! ! !FilePackage methodsFor: 'private'! msgClassComment: string with: chgRec | tokens theClass | tokens := Scanner new scanTokens: string. (tokens size = 3 and:[(tokens at: 3) class == String]) ifTrue:[ theClass := self getClass: tokens first. ^theClass commentString: tokens last]. (tokens size = 4 and:[(tokens at: 3) asString = 'class' and:[(tokens at: 4) class == String]]) ifTrue:[ theClass := self getClass: tokens first. theClass metaClass commentString: tokens last]. ! ! !FilePackage methodsFor: 'private'! possibleSystemSource: chgRec | tokens | sourceSystem isEmpty ifTrue:[ tokens := Scanner new scanTokens: chgRec string. (tokens size = 1 and:[tokens first class == String]) ifTrue:[ sourceSystem := tokens first. ^self]]. doIts add: chgRec.! ! !FilePackage methodsFor: 'private'! removedMethod: string with: chgRec | class tokens | tokens := Scanner new scanTokens: string. (tokens size = 3 and:[(tokens at: 2) == #removeSelector: ]) ifTrue:[ class := self getClass: (tokens at: 1). ^class removeSelector: (tokens at: 3). ]. (tokens size = 4 and:[(tokens at: 2) == #class and:[(tokens at: 3) == #removeSelector:]]) ifTrue:[ class := self getClass: (tokens at: 1). ^class metaClass removeSelector: (tokens at: 4). ]. doIts add: chgRec! ! !FilePackage methodsFor: 'private'! sampleMethod " In an existing method there are always a number of changes. Other stuff will be deleted Or even better, some things may be just modified. "! ! !FilePackage methodsFor: 'change record types'! classComment: chgRec (self getClass: chgRec methodClassName) classComment: chgRec! ! !FilePackage methodsFor: 'change record types'! doIt: chgRec | string | string := chgRec string. ('*ubclass:*instanceVariableNames:*classVariableNames:*poolDictionaries:*category:*' match: string) ifTrue:[^self classDefinition: string with: chgRec]. ('* class*instanceVariableNames:*' match: string) ifTrue:[^self metaClassDefinition: string with: chgRec]. ('* removeSelector: *' match: string) ifTrue:[^self removedMethod: string with: chgRec]. ('* comment:*' match: string) ifTrue:[^self msgClassComment: string with: chgRec]. ('* initialize' match: string) ifTrue:[^self]. "Initialization is done based on class>>initialize" ('''From *' match: string) ifTrue:[^self possibleSystemSource: chgRec]. doIts add: chgRec.! ! !FilePackage methodsFor: 'change record types'! method: chgRec (self getClass: chgRec methodClassName) methodChange: chgRec! ! !FilePackage methodsFor: 'change record types'! preamble: chgRec self doIt: chgRec! ! !FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:57'! askForDoits | menu choice choices | choices := #('do not process' 'at the beginning' 'at the end' 'cancel'). menu _ SelectionMenu selections: choices. choice := nil. [choices includes: choice] whileFalse: [ choice _ menu startUpWithCaption: 'The package contains unprocessed doIts. When would like to process those?']. ^choices indexOf: choice! ! !FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 16:00'! fileIn | doitsMark | doitsMark := 1. doIts isEmpty ifFalse:[doitsMark := self askForDoits]. doitsMark = 4 ifTrue: [^nil]. doitsMark = 2 ifTrue:[self fileInDoits]. classOrder do:[:cls| cls fileInDefinition. ]. classes do:[:cls| Transcript cr; show:'Filing in ', cls name. cls fileInMethods. cls hasMetaclass ifTrue:[cls metaClass fileInMethods]. ]. doitsMark = 3 ifTrue:[self fileInDoits].! ! !FilePackage methodsFor: 'fileIn/fileOut'! fileInDoits doIts do:[:chgRec| chgRec fileIn].! ! !FilePackage methodsFor: 'fileIn/fileOut' stamp: 'jm 10/7/2002 06:57'! fileOut | fileName stream | fileName := FillInTheBlank request: 'Enter the file name' initialAnswer:''. stream := FileStream newFileNamed: fileName. sourceSystem isEmpty ifFalse:[ stream nextChunkPut: sourceSystem printString;cr ]. self fileOutOn: stream. stream cr; cr. self classes do:[:cls| cls needsInitialize ifTrue:[ stream cr; nextChunkPut: cls name,' initialize']]. stream cr. stream close. ! ! !FilePackage methodsFor: 'fileIn/fileOut'! fileOutDoits: aStream doIts do:[:chgRec| chgRec fileOutOn: aStream].! ! !FilePackage methodsFor: 'fileIn/fileOut' stamp: 'wod 4/15/98 15:59'! fileOutOn: aStream | doitsMark | doitsMark := 1. doIts isEmpty ifFalse:[doitsMark := self askForDoits]. doitsMark = 4 ifTrue: [^nil]. doitsMark = 2 ifTrue:[self fileOutDoits: aStream]. classOrder do:[:cls| cls fileOutDefinitionOn: aStream. ]. classes do:[:cls| cls fileOutMethodsOn: aStream. cls hasMetaclass ifTrue:[cls metaClass fileOutMethodsOn: aStream]. ]. doitsMark = 3 ifTrue:[self fileOutDoits: aStream].! ! !FilePackage methodsFor: 'reading'! fileInFrom: aStream | chgRec changes | changes := (ChangeList new scanFile: aStream from: 0 to: aStream size) changeList. aStream close. classes := Dictionary new. ('Processing ', self packageName) displayProgressAt: Sensor cursorPoint from: 1 to: changes size during:[:bar| 1 to: changes size do:[:i| bar value: i. chgRec := changes at: i. self perform: (chgRec type copyWith: $:) asSymbol with: chgRec. ]. ].! ! !FilePackage class methodsFor: 'instance creation'! fromFileNamed: aName ^self new fromFileNamed: aName! ! I am an example server that can receive and save large files using the MsgServer framework. My only operation is: 1 -- receive a file whose arguments are the file name and file size in bytes. To try this server, copy the remainder of this comment into a workspace and follow the step-by-step directions. First start the server: server _ FileReceiverServerTest new. server forkServerProcess. Next, create a client socket and connect it to the server: Socket initializeNetwork. sock _ MessageSocket new. sock connectTo: NetNameResolver localHostAddress port: FileReceiverServerTest portNumber waitSecs: 10. sock isConnected ifFalse: [self error: 'could not connect']. You can now send a file to the server: fileName _ 'Gromit.jmv'. file _ (FileStream readOnlyFileNamed: fileName) binary. request _ WriteStream on: ByteArray new. request nextPut: 1. request string: fileName. request int32: file size. sock request: request contents withStream: file. When you are done sending files, you can close the client socket stop the server: sock destroy. server stopServer. ! !FileReceiverServerTest methodsFor: 'request handling' stamp: 'jm 4/23/2003 09:57'! createFileBasedOnName: fileName "Find an unused file name based on the given file name. Create a new file of that name and answer a stream on that file." | ext root n newFileName | (FileDirectory default fileExists: fileName) ifFalse: [^ FileStream newFileNamed: fileName]. ext _ FileDirectory extensionFor: fileName. root _ fileName copyFrom: 1 to: fileName size - ext size. ext size > 0 ifTrue: [ext _ '.', ext]. n _ 1. [true] whileTrue: [ newFileName _ root, n printString, ext. (FileDirectory default fileExists: newFileName) ifFalse: [ ^ FileStream newFileNamed: newFileName]. n _ n + 1]. ! ! !FileReceiverServerTest methodsFor: 'request handling' stamp: 'jm 4/23/2003 18:32'! processMessage: aByteArray requestSocket: aSocket "This server receives and saves files." | s op fName byteCount file bytesLeft buf n | "parse the request" s _ ReadStream on: aByteArray. op _ s next. op = 1 ifFalse: [^ 'bad op']. fName _ s string. byteCount _ s int32. "receive the file" file _ self createFileBasedOnName: fName. bytesLeft _ byteCount. buf _ ByteArray new: 10000. [aSocket isConnected and: [bytesLeft > 0]] whileTrue: [ buf size > bytesLeft ifTrue: [buf _ ByteArray new: bytesLeft]. aSocket waitForData. n _ aSocket socket readInto: buf startingAt: 1. n > 0 ifTrue: [ file nextPutAll: (buf copyFrom: 1 to: n). bytesLeft _ bytesLeft - n]]. file close. ^ 'ok' ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! close "Close this file." self subclassResponsibility ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! closed "Answer true if this file is closed." self subclassResponsibility ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:03'! flush "When writing, flush the current buffer out to disk." self subclassResponsibility ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:04'! reopen "Ensure that the receiver is open, re-open it if necessary." "Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! ascii "Set this file to ascii (text) mode." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! binary "Set this file to binary mode." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 12:59'! readOnly "Set this file's mode to read-only." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'! readWrite "Set this file's mode to read-write." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:01'! text "Set this file to text (ascii) mode." self ascii. ! ! !FileStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:42'! fileIn "Guarantee that the receiver is readOnly before fileIn for efficiency and to eliminate remote sharing conflicts." self readOnly. self fileInAnnouncing: 'Loading ', self localName! ! !FileStream class methodsFor: 'instance creation' stamp: 'jm 5/8/2003 19:14'! droppedFiles "Poll for a dropped file event. If there is such an event, answer an array containing the drop point followed by one or more FileStream's for the dropped files. Otherwise, answer the empty array." "Note: File dropping does not work on versions of the Squeak VM before the DropPlugin and event primitive. This method can still be called, but it will always answer an empty array." | p result i f evtBuf | "check for a file drop event?" p _ Sensor fileDropPoint. p ifNil: [^ #()]. "no file drop event" "get streams on all dropped files" result _ OrderedCollection with: p. i _ 1. [(f _ StandardFileStream new requestDropStream: i) notNil] whileTrue: [ result addLast: f. i _ i + 1]. "flush remaining file drop events" evtBuf _ Array new: 8. [(evtBuf at: 1) = 3] whileTrue: [ evtBuf at: 1 put: 0. Sensor primGetNextEvent: evtBuf]. ^ result asArray ! ! !FileStream class methodsFor: 'instance creation' stamp: 'TPR 8/26/1999 10:49'! isAFileNamed: fName "return whether a file exists with the given name" ^self concreteStream isAFileNamed: (self fullName: fName)! ! !FileStream class methodsFor: 'concrete classes' stamp: 'ls 7/11/1998 02:58'! concreteStream "Who should we really direct class queries to? " ^ StandardFileStream "may change this to CrLfFileStream"! ! !FillInTheBlank methodsFor: 'initialize-release' stamp: 'sw 1/31/2000 14:42'! initialize super initialize. acceptOnCR _ false. done _ false. responseUponCancel _ '' ! ! !FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:45'! responseUponCancel: resp responseUponCancel _ resp! ! !FillInTheBlank methodsFor: 'accessing' stamp: 'sw 1/31/2000 14:47'! setResponseForCancel self contents: responseUponCancel! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:43'! multiLineRequest: queryString centerAt: aPoint initialAnswer: defaultAnswer answerHeight: answerHeight "Create a multi-line instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer nil if the user cancels. An empty string returned means that the ussr cleared the editing area and then hit 'accept'. Because multiple lines are invited, we ask that the user use the ENTER key, or (in morphic anyway) hit the 'accept' button, to submit; that way, the return key can be typed to move to the next line." "FillInTheBlank multiLineRequest: 'Enter several lines; end input by accepting or canceling or typing the enter key' centerAt: Display boundingBox center initialAnswer: 'bozo!!' answerHeight: 100" | model fillInView savedArea | Smalltalk isMorphic ifTrue: [^ FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: self currentWorld onCancelReturn: nil acceptOnCR: false]. model _ self new initialize. model contents: defaultAnswer. model responseUponCancel: nil. model acceptOnCR: false. fillInView _ (Smalltalk at: #FillInTheBlankView) multiLineOn: model message: queryString centerAt: aPoint answerHeight: answerHeight. savedArea _ Form fromDisplay: fillInView displayBox. fillInView display. defaultAnswer isEmpty ifFalse: [fillInView lastSubView controller selectFrom: 1 to: defaultAnswer size]. (fillInView lastSubView containsPoint: Sensor cursorPoint) ifFalse: [fillInView lastSubView controller centerCursorInView]. fillInView controller startUp. fillInView release. savedArea displayOn: Display at: fillInView viewport topLeft. ^ model contents! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'di 9/11/1998 15:01'! request: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlankMorph request: queryString" ^ self request: queryString initialAnswer: '' centerAt: Sensor cursorPoint. ! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'di 9/11/1998 15:02'! request: queryString initialAnswer: defaultAnswer "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'What is your favorite color?' initialAnswer: 'red, no blue. Ahhh!!'" ^ self request: queryString initialAnswer: defaultAnswer centerAt: Sensor cursorPoint. ! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:43'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | model fillInView savedArea | Smalltalk isMorphic ifTrue: [^ FillInTheBlankMorph request: queryString initialAnswer: defaultAnswer centerAt: aPoint]. model _ self new initialize. model contents: defaultAnswer. fillInView _ FillInTheBlankView on: model message: queryString centerAt: aPoint. savedArea _ Form fromDisplay: fillInView displayBox. fillInView display. defaultAnswer isEmpty ifFalse: [fillInView lastSubView controller selectFrom: 1 to: defaultAnswer size]. (fillInView lastSubView containsPoint: Sensor cursorPoint) ifFalse: [fillInView lastSubView controller centerCursorInView]. fillInView controller startUp. fillInView release. savedArea displayOn: Display at: fillInView viewport topLeft. ^ model contents! ! !FillInTheBlank class methodsFor: 'instance creation' stamp: 'jdr 6/4/2000 15:04'! requestPassword: queryString | model fillInView savedArea defaultAnswer | "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlank requestPassword: 'POP password'" Smalltalk isMorphic ifTrue: [^ FillInTheBlankMorph requestPassword: queryString]. defaultAnswer _ ''. model _ self new initialize. model contents: defaultAnswer. fillInView _ FillInTheBlankView requestPassword: model message: queryString centerAt: Sensor cursorPoint answerHeight: 40. savedArea _ Form fromDisplay: fillInView displayBox. fillInView display. defaultAnswer isEmpty ifFalse: [fillInView lastSubView controller selectFrom: 1 to: defaultAnswer size]. (fillInView lastSubView containsPoint: Sensor cursorPoint) ifFalse: [fillInView lastSubView controller centerCursorInView]. fillInView controller startUp. fillInView release. savedArea displayOn: Display at: fillInView viewport topLeft. ^ model contents ! ! !FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'! isControlActive ^ self isControlWanted! ! !FillInTheBlankController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 14:45'! isControlWanted ^ model done not! ! !FillInTheBlankController methodsFor: 'other' stamp: 'sw 1/31/2000 14:47'! cancel model setResponseForCancel. super cancel. model done: true. ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'di 4/12/1999 16:19'! delete self breakDependents. ^ super delete! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'jm 11/24/2002 10:24'! initialize super initialize. self color: Color white. Preferences roundedWindowCorners ifTrue: [self useRoundedCorners]. borderWidth _ 2. self extent: 200@70. responseUponCancel _ ''. "Caller can reset this to return something else, e.g. nil, upon cancel" ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 1/31/2000 11:01'! responseUponCancel: anObject responseUponCancel _ anObject ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'bolot 5/18/2000 13:52'! setPasswordQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean response _ initialAnswer. done _ false. self removeAllMorphs. self extent: 200@70. self addQuery: queryString. self width: (self width max: self firstSubmorph width + (2 * borderWidth)). self addLine. textPane _ PluggableTextMorph on: self text: #response accept: #response: readSelection: #selectionInterval menu: #codePaneMenu:shifted:. textPane hasUnacceptedEdits: true. textPane acceptOnCR: acceptBoolean. textPane extent: self innerBounds width@answerHeight. textPane position: self innerBounds left@self lastSubmorph bottom. textPane font: (StrikeFont passwordFontSize: 12). self addMorphBack: textPane. self addLine. self addButtonRow. self height: (self height max: (self lastSubmorph bottom - self top) + borderWidth). ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'sw 2/2/2000 22:41'! setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight self setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: true ! ! !FillInTheBlankMorph methodsFor: 'initialization' stamp: 'ssa 2/14/2000 13:20'! setQuery: queryString initialAnswer: initialAnswer answerHeight: answerHeight acceptOnCR: acceptBoolean response _ initialAnswer. done _ false. self removeAllMorphs. self extent: 200@70. self addQuery: queryString. self width: (self width max: self firstSubmorph width + (2 * borderWidth)). self addLine. textPane _ PluggableTextMorph on: self text: #response accept: #response: readSelection: #selectionInterval menu: #codePaneMenu:shifted:. textPane hasUnacceptedEdits: true. textPane acceptOnCR: acceptBoolean. textPane extent: self innerBounds width@answerHeight. textPane position: self innerBounds left@self lastSubmorph bottom. self addMorphBack: textPane. self addLine. self addButtonRow. self height: (self height max: (self lastSubmorph bottom - self top) + borderWidth). ! ! !FillInTheBlankMorph methodsFor: 'menu' stamp: 'sw 1/31/2000 11:11'! cancel "Sent by the cancel button." response _ responseUponCancel. done _ true. ! ! !FillInTheBlankMorph methodsFor: 'invoking' stamp: 'di 12/6/1999 19:42'! getUserResponse "Wait for the user to accept or cancel, and answer the result string. Answers the empty string if the user cancels." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." | w | w _ self world. w ifNil: [^ response]. done _ false. [done] whileFalse: [w doOneCycle]. self delete. w doOneCycle. ^ response ! ! !FillInTheBlankMorph methodsFor: 'private' stamp: 'jm 6/15/2003 10:28'! addLine | line | line _ BorderedMorph new color: Color black; extent: self width@borderWidth; position: self left@self lastSubmorph bottom. self addMorphBack: line. ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 12/21/1998 13:21'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels. This variant is only for calling from within a Morphic project." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: World ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 1/31/2000 11:03'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. Answer the empty string if the user cancels." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: ''! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:43'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel. If user hits cr, treat it as a normal accept." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" ^ self request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: true! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'sw 2/2/2000 22:34'! request: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | aFillInTheBlankMorph | aFillInTheBlankMorph _ self new setQuery: queryString initialAnswer: defaultAnswer answerHeight: 50 acceptOnCR: acceptBoolean. aFillInTheBlankMorph responseUponCancel: returnOnCancel. aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. ^ aFillInTheBlankMorph getUserResponse ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:57'! requestPassword: queryString "Create an instance of me whose question is queryString. Invoke it centered at the cursor, and answer the string the user accepts. Answer the empty string if the user cancels." "use password font" "FillInTheBlankMorph requestPassword: 'Password?'" ^ self requestPassword: queryString initialAnswer: '' centerAt: Sensor cursorPoint inWorld: World onCancelReturn: '' acceptOnCR: true ! ! !FillInTheBlankMorph class methodsFor: 'instance creation' stamp: 'bolot 5/18/2000 13:53'! requestPassword: queryString initialAnswer: defaultAnswer centerAt: aPoint inWorld: aWorld onCancelReturn: returnOnCancel acceptOnCR: acceptBoolean "Create an instance of me whose question is queryString with the given initial answer. Invoke it centered at the given point, and answer the string the user accepts. If the user cancels, answer returnOnCancel." "FillInTheBlankMorph request: 'Type something, then type CR.' initialAnswer: 'yo ho ho!!' centerAt: Display center" | aFillInTheBlankMorph | aFillInTheBlankMorph _ self new setPasswordQuery: queryString initialAnswer: defaultAnswer answerHeight: 50 acceptOnCR: acceptBoolean. aFillInTheBlankMorph responseUponCancel: returnOnCancel. aWorld addMorph: aFillInTheBlankMorph centeredNear: aPoint. ^ aFillInTheBlankMorph getUserResponse ! ! !FillInTheBlankView class methodsFor: 'instance creation' stamp: 'jdr 6/4/2000 15:03'! requestPassword: aFillInTheBlank message: queryString centerAt: aPoint answerHeight: answerHeight "Answer an instance of me on aFillInTheBlank asking the question queryString. Allow the reply to be multiple lines, and make the user input view the given height." | messageView answerView topView myPar pwdFont myArray myStyle | aFillInTheBlank acceptOnCR: true. messageView _ DisplayTextView new model: queryString asDisplayText; borderWidthLeft: 2 right: 2 top: 2 bottom: 0; controller: NoController new. messageView window: (0@0 extent: (messageView window extent max: 200@30)); centered. answerView _ self new model: aFillInTheBlank; window: (0@0 extent: (messageView window width@answerHeight)); borderWidth: 2. " now answerView to use the password font" myPar _ answerView displayContents. pwdFont _ (StrikeFont passwordFontSize: 12). myArray _ Array new: 1. myArray at: 1 put: pwdFont. myStyle _ TextStyle fontArray: myArray. myPar setWithText: (myPar text) style: myStyle. topView _ View new model: aFillInTheBlank. topView controller: ModalController new. topView addSubView: messageView. topView addSubView: answerView below: messageView. topView align: topView viewport center with: aPoint. topView window: (0 @ 0 extent: (messageView window width) @ (messageView window height + answerView window height)). topView translateBy: (topView displayBox amountToTranslateWithin: Display boundingBox). ^ topView ! ! I demonstrate how to used the step mechanism to provide a flashing ellipse. ! !FlasherMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 11:54'! color: aColor "Record my on color." super color: aColor. onColor _ aColor.! ! !FlasherMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 11:58'! step super step. color = onColor ifTrue: [super color: (onColor mixed: 0.5 with: Color black)] ifFalse: [super color: onColor]. ! ! !FlasherMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 11:57'! stepTime "Answer the desired time between steps in milliseconds." ^ 500 ! ! !FlasherMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:05'! includeInNewMorphMenu ^ true ! ! My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. It is actually possible to specify a radix for Squeak Float constants. This is great for teaching about numbers, but may be confusing to the average reader: 3r20.2 --> 6.66666666666667 8r20.2 --> 16.25 If you don't have access to the definition of IEEE-754, you can figure out what is going on by printing various simple values in Float hex. It may help you to know that the basic format is... sign 1 bit exponent 11 bits with bias of 1023 (16r3FF) to produce an exponent in the range -1023 .. +1024 - 16r000: significand = 0: Float zero significand ~= 0: Denormalized number (exp = -1024, no hidden '1' bit) - 16r7FF: significand = 0: Infinity significand ~= 0: Not A Number (NaN) representation mantissa 53 bits, but only 52 are stored (20 in the first word, 32 in the second). This is because a normalized mantissa, by definition, has a 1 to the right of its floating point, and IEEE-754 omits this redundant bit to gain an extra bit of precision instead. People talk about the mantissa without its leading one as the FRACTION, and with its leading 1 as the SIGNFICAND. The single-precision format is... sign 1 bit exponent 8 bits, with bias of 127, to represent -126 to +127 - 0x0 and 0xFF reserved for Float zero (mantissa is ignored) - 16r7F reserved for Float underflow/overflow (mantissa is ignored) mantissa 24 bits, but only 23 are stored This format is used in FloatArray (qv), and much can be learned from the conversion routines, Float asIEEE32BitWord, and Float class fromIEEE32Bit:. Thanks to Rich Harmon for asking many questions and to Tim Olson, Bruce Cohen, Rick Zaccone and others for the answers that I have collected here.! ]style[(680 9 1189 21 6 26 149)f1,f1LFloat hex;,f1,f1LFloat asIEEE32BitWord;,f1,f1LFloat class fromIEEE32Bit:;,f1! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! * aNumber "Primitive. Answer the result of multiplying the receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #*! ! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'! + aNumber "Primitive. Answer the sum of the receiver and aNumber. Essential. Fail if the argument is not a Float. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #+! ! !Float methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'! - aNumber "Primitive. Answer the difference between the receiver and aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #-! ! !Float methodsFor: 'arithmetic' stamp: 'jm 5/22/2003 19:58'! / aNumber "Primitive. Answer the result of dividing receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber = 0 ifTrue: [^ self error: 'division by 0']. ^ aNumber adaptToFloat: self andSend: #/! ! !Float methodsFor: 'mathematical functions' stamp: 'jsp 2/25/1999 11:15'! arcSin "Answer the angle in radians." ((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range']. ((self = -1.0) or: [self = 1.0]) ifTrue: [^ Halfpi * self] ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! ! !Float methodsFor: 'mathematical functions' stamp: 'jsp 3/30/1999 12:38'! arcTan: denominator "Answer the angle in radians. Optional. See Object documentation whatIsAPrimitive." | result | (self = 0.0) ifTrue: [ (denominator > 0.0) ifTrue: [ result _ 0 ] ifFalse: [ result _ Pi ] ] ifFalse: [(denominator = 0.0) ifTrue: [ (self > 0.0) ifTrue: [ result _ Halfpi ] ifFalse: [ result _ Halfpi negated ] ] ifFalse: [ (denominator > 0) ifTrue: [ result _ (self / denominator) arcTan ] ifFalse: [ result _ ((self / denominator) arcTan) + Pi ] ]. ]. ^ result.! ! !Float methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:35'! raisedTo: aNumber "Answer the receiver raised to aNumber." aNumber isInteger ifTrue: ["Do the special case of integer power" ^ self raisedToInteger: aNumber]. self < 0.0 ifTrue: [ self error: self printString, ' raised to a non-integer power' ]. 0.0 = aNumber ifTrue: [^ 1.0]. "special case for exponent = 0.0" (self= 0.0) | (aNumber = 1.0) ifTrue: [^ self]. "special case for self = 1.0" ^ (self ln * aNumber asFloat) exp "otherwise use logarithms" ! ! !Float methodsFor: 'mathematical functions' stamp: 'laza 12/21/1999 12:15'! safeArcCos "Answer the angle in radians." (self between: -1.0 and: 1.0) ifTrue: [^ self arcCos] ifFalse: [^ self sign arcCos]! ! !Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'! < aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is less than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: # ^ aNumber adaptToFloat: self andSend: #<=! ! !Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:56'! = aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is equal to the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." aNumber isNumber ifFalse: [^ false]. ^ aNumber adaptToFloat: self andSend: #=! ! !Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'! > aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." ^ aNumber adaptToFloat: self andSend: #>! ! !Float methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'! >= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than or equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive. " ^ aNumber adaptToFloat: self andSend: #>! ! !Float methodsFor: 'testing' stamp: 'bf 8/20/1999 12:56'! hasContentsInExplorer ^false! ! !Float methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'! isPowerOfTwo "Return true if the receiver is an integral power of two. Floats never return true here." ^false! ! !Float methodsFor: 'testing'! isZero ^self = 0.0! ! !Float methodsFor: 'truncation and round off' stamp: 'di 7/1/1998 23:01'! truncated "Answer with a SmallInteger equal to the value of the receiver without its fractional part. The primitive fails if the truncated value cannot be represented as a SmallInteger. In that case, the code below will compute a LargeInteger truncated value. Essential. See Object documentation whatIsAPrimitive. " (self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number']. self abs < 2.0e16 ifTrue: ["Fastest way when it may not be an integer" ^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated] ifFalse: [^ self asTrueFraction. "Extract all bits of the mantissa and shift if necess"]! ! !Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:38'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert it to a Float." ^ rcvr asFloat perform: selector with: self! ! !Float methodsFor: 'converting' stamp: 'di 11/6/1998 13:07'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Float." ^ rcvr asFloat perform: selector with: self! ! !Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'! asFraction ^ self asTrueFraction ! ! !Float methodsFor: 'converting' stamp: 'di 2/8/1999 12:51'! asIEEE32BitWord "Convert the receiver into a 32 bit Integer value representing the same number in IEEE 32 bit format. Used for conversion in FloatArrays only." | word1 word2 sign mantissa exponent destWord | self = 0.0 ifTrue:[^0]. word1 _ self basicAt: 1. word2 _ self basicAt: 2. mantissa _ (word2 bitShift: -29) + ((word1 bitAnd: 16rFFFFF) bitShift: 3). exponent _ ((word1 bitShift: -20) bitAnd: 16r7FF) - 1023 + 127. exponent < 0 ifTrue:[^0]. "Underflow" exponent > 254 ifTrue:["Overflow" exponent _ 255. mantissa _ 0]. sign _ word1 bitAnd: 16r80000000. destWord _ (sign bitOr: (exponent bitShift: 23)) bitOr: mantissa. ^ destWord! ! !Float methodsFor: 'converting' stamp: 'di 7/1/1998 22:20'! asTrueFraction " Answer a fraction that EXACTLY represents self, a double precision IEEE floating point number. Floats are stored in the same form on all platforms. (Does not handle gradual underflow or NANs.) By David N. Smith with significant performance improvements by Luciano Esteban Notarfrancesco. (Version of 11April97)" | shifty sign expPart exp fraction fractionPart result zeroBitsCount | self isInfinite ifTrue: [self error: 'Cannot represent infinity as a fraction']. self isNaN ifTrue: [self error: 'Cannot represent Not-a-Number as a fraction']. " Extract the bits of an IEEE double float " shifty := ((self basicAt: 1) bitShift: 32) + (self basicAt: 2). " Extract the sign and the biased exponent " sign := (shifty bitShift: -63) = 0 ifTrue: [1] ifFalse: [-1]. expPart := (shifty bitShift: -52) bitAnd: 16r7FF. " Extract fractional part; answer 0 if this is a true 0.0 value " fractionPart := shifty bitAnd: 16r000FFFFFFFFFFFFF. ( expPart=0 and: [ fractionPart=0 ] ) ifTrue: [ ^ 0 ]. " Replace omitted leading 1 in fraction " fraction := fractionPart bitOr: 16r0010000000000000. "Unbias exponent: 16r3FF is bias; 52 is fraction width" exp := 16r3FF + 52 - expPart. " Form the result. When exp>52, the exponent is adjusted by the number of trailing zero bits in the fraction to minimize the (huge) time otherwise spent in #gcd:. " exp negative ifTrue: [ result := sign * fraction bitShift: exp negated ] ifFalse: [ zeroBitsCount _ fraction lowBit - 1. exp := exp - zeroBitsCount. exp <= 0 ifTrue: [ zeroBitsCount := zeroBitsCount + exp. "exp := 0." " Not needed; exp not refernced again " result := sign * fraction bitShift: zeroBitsCount negated ] ifFalse: [ result := Fraction numerator: (sign * fraction bitShift: zeroBitsCount negated) denominator: (1 bitShift: exp) ] ]. "Low cost validation omitted after extensive testing" "(result asFloat = self) ifFalse: [self error: 'asTrueFraction validation failed']." ^ result ! ! !Float methodsFor: 'private' stamp: 'ls 10/10/1999 11:55'! absPrintOn: aStream base: base digitCount: digitCount "Print me in the given base, using digitCount significant figures." | fuzz x exp q fBase scale logScale xi | self isInf ifTrue: [^ aStream nextPutAll: 'Inf']. fBase _ base asFloat. "x is myself normalized to [1.0, fBase), exp is my exponent" exp _ self < 1.0 ifTrue: [self reciprocalFloorLog: fBase] ifFalse: [self floorLog: fBase]. scale _ 1.0. logScale _ 0. [(x _ fBase raisedTo: (exp + logScale)) = 0] whileTrue: [scale _ scale * fBase. logScale _ logScale + 1]. x _ self * scale / x. fuzz _ fBase raisedTo: 1 - digitCount. "round the last digit to be printed" x _ 0.5 * fuzz + x. x >= fBase ifTrue: ["check if rounding has unnormalized x" x _ x / fBase. exp _ exp + 1]. (exp < 6 and: [exp > -4]) ifTrue: ["decimal notation" q _ 0. exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' at: i)]]] ifFalse: ["scientific notation" q _ exp. exp _ 0]. [x >= fuzz] whileTrue: ["use fuzz to track significance" xi _ x asInteger. aStream nextPut: (Character digitValue: xi). x _ x - xi asFloat * fBase. fuzz _ fuzz * fBase. exp _ exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. [exp >= -1] whileTrue: [aStream nextPut: $0. exp _ exp - 1. exp = -1 ifTrue: [aStream nextPut: $.]]. q ~= 0 ifTrue: [aStream nextPut: $e. q printOn: aStream]! ! !Float class methodsFor: 'instance creation' stamp: 'di 2/8/1999 12:58'! fromIEEE32Bit: word "Convert the given 32 bit word (which is supposed to be a positive 32bit value) from a 32bit IEEE floating point representation into an actual Squeak float object (being 64bit wide). Should only be used for conversion in FloatArrays or likewise objects." | sign mantissa exponent newFloat | word negative ifTrue: [^ self error:'Cannot deal with negative numbers']. word = 0 ifTrue:[^ 0.0]. mantissa _ word bitAnd: 16r7FFFFF. exponent _ ((word bitShift: -23) bitAnd: 16rFF) - 127. sign _ word bitAnd: 16r80000000. exponent = 128 ifTrue:["Either NAN or INF" mantissa = 0 ifFalse:[^ Float nan]. sign = 0 ifTrue:[^ Float infinity] ifFalse:[^ Float infinity negated]]. "Create new float" newFloat _ self new: 2. newFloat basicAt: 1 put: ((sign bitOr: (1023 + exponent bitShift: 20)) bitOr: (mantissa bitShift: -3)). newFloat basicAt: 2 put: ((mantissa bitAnd: 7) bitShift: 29). ^newFloat! ! !Float class methodsFor: 'constants' stamp: 'sw 10/8/1999 22:59'! halfPi ^ Halfpi! ! FloatArrays store 32bit IEEE floating point numbers.! !FloatArray methodsFor: 'accessing' stamp: 'ar 1/22/1999 19:52'! at: index ^Float fromIEEE32Bit: (self basicAt: index)! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 2/4/1999 17:05'! at: index put: value value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0.0! ! !FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! length "Return the length of the receiver" ^self squaredLength sqrt! ! !FloatArray methodsFor: 'accessing' stamp: 'laza 3/24/2000 13:08'! squaredLength "Return the squared length of the receiver" ^self dot: self! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! * anObject ^self clone *= anObject! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! *= anObject ^anObject isNumber ifTrue:[self primMulScalar: anObject asFloat] ifFalse:[self primMulArray: anObject]! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! + anObject ^self clone += anObject! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:48'! += anObject ^anObject isNumber ifTrue:[self primAddScalar: anObject asFloat] ifFalse:[self primAddArray: anObject]! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:33'! - anObject ^self clone -= anObject! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:49'! -= anObject ^anObject isNumber ifTrue:[self primSubScalar: anObject asFloat] ifFalse:[self primSubArray: anObject]! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 9/14/1998 22:34'! / anObject ^self clone /= anObject! ! !FloatArray methodsFor: 'arithmetic' stamp: 'ar 10/7/1998 19:58'! /= anObject ^anObject isNumber ifTrue:[self primDivScalar: anObject asFloat] ifFalse:[self primDivArray: anObject]! ! !FloatArray methodsFor: 'arithmetic' stamp: 'laza 3/24/2000 13:07'! dot: aFloatVector "Primitive. Return the dot product of the receiver and the argument. Fail if the argument is not of the same size as the receiver." | result | "" self size = aFloatVector size ifFalse:[^self error:'Must be equal size']. result _ 0.0. 1 to: self size do:[:i| result _ result + ((self at: i) * (aFloatVector at: i)). ]. ^result! ! !FloatArray methodsFor: 'comparing' stamp: 'bf 8/20/1999 12:49'! = aFloatArray | length | aFloatArray class = self class ifFalse: [^ false]. length _ self size. length = aFloatArray size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (aFloatArray at: i) ifFalse: [^ false]]. ^ true! ! !FloatArray methodsFor: 'comparing' stamp: 'ar 9/15/1998 01:14'! hash | result | result _ 0. 1 to: self size do:[:i| result _ result + (self basicAt: i) ]. ^result bitAnd: 16r1FFFFFFF! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/11/1998 03:10'! primAddArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) + (floatArray at: i)].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/10/1998 21:46'! primAddScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) + scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/7/1998 20:00'! primDivArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) / (floatArray at: i)].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/10/1998 21:46'! primDivScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) / scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/7/1998 20:00'! primMulArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) * (floatArray at: i)].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/10/1998 21:47'! primMulScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) * scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/7/1998 20:01'! primSubArray: floatArray 1 to: self size do:[:i| self at: i put: (self at: i) - (floatArray at: i)].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'ar 10/10/1998 21:47'! primSubScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! ! !FloatArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'! asFloatArray ^self! ! !FloatArray methodsFor: 'private' stamp: 'ar 10/9/1998 11:27'! 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! ! !FloatArray methodsFor: 'user interface' stamp: 'ar 2/13/1999 21:33'! inspect "Open a OrderedCollectionInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector." OrderedCollectionInspector openOn: self withEvalPane: true! ! !FloatArray methodsFor: 'user interface' stamp: 'ar 2/13/1999 21:33'! inspectWithLabel: aLabel "Open a OrderedCollectionInspector on the receiver. Use basicInspect to get a normal (less useful) type of inspector." OrderedCollectionInspector openOn: self withEvalPane: true withLabel: aLabel! ! A rectangular array of pixels, used for holding images. All pictures, including character images are Forms. The depth of a Form is how many bits are used to specify the color at each pixel. The actual bits are held in a Bitmap, whose internal structure is different at each depth. Class Color allows you to deal with colors without knowing how they are actually encoded inside a Bitmap. The supported depths (in bits) are 1, 2, 4, 8, 16, and 32. The number of actual colors at these depths are: 2, 4, 16, 256, 32768, and 16 million. Forms are combined using BitBlt. See the comment in class BitBlt. Forms that are have both transparent and opapue areas are MaskedForms. Forms that repeat many times to fill a large destination are InfiniteForms. colorAt: x@y Returns the abstract color at this location displayAt: x@y shows this form on the screen displayOn: aMedium at: x@y shows this form in a Window, a Form, or other DisplayMedium fillColor: aColor Set all the pixels to the color. edit launch an editor to change the bits of this form. pixelValueAt: x@y The encoded color. Depends on the depth. ! !Form methodsFor: 'initialize-release' stamp: 'ar 5/28/2000 16:00'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver and can be used for accelerated blts" ^Form extent: extentPoint depth: self depth! ! !Form methodsFor: 'accessing' stamp: 'jm 6/15/2003 18:26'! boundingBox ^ Rectangle origin: 0@0 corner: width@height ! ! !Form methodsFor: 'accessing' stamp: 'jm 6/15/2003 18:47'! computeBoundingBox "Note: Clients usually send boundingBox rather than this message." ^ Rectangle origin: 0@0 corner: width@height ! ! !Form methodsFor: 'accessing' stamp: 'jm 11/24/2002 10:48'! getCanvas "Return a Canvas for drawing on the receiver." ^ FormCanvas on: self ! ! !Form methodsFor: 'accessing' stamp: 'ar 2/16/2000 22:00'! offset ^offset ifNil:[0@0]! ! !Form methodsFor: 'copying' stamp: 'jm 5/29/2003 17:58'! copy: destRectangle from: sourcePt in: sourceForm rule: rule "Make up a BitBlt table and copy the bits." (BitBlt toForm: self) copy: destRectangle from: sourcePt in: sourceForm fillColor: nil rule: rule! ! !Form methodsFor: 'displaying' stamp: 'jm 6/15/2003 18:29'! copyBits: sourceForm at: destOrigin translucent: factor "Make up a BitBlt table and copy the bits with the given colorMap." (BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: 30 destOrigin: destOrigin sourceOrigin: 0@0 extent: sourceForm extent clipRect: self boundingBox) copyBitsTranslucent: ((0 max: (factor*255.0) asInteger) min: 255) " | f f2 f3 | f _ Form fromUser. f2 _ Form fromDisplay: (0@0 extent: f extent). f3 _ f2 deepCopy. 0.0 to: 1.0 by: 1.0/32 do: [:t | f3 _ f2 deepCopy. f3 copyBits: f at: 0@0 translucent: t. f3 displayAt: 0@0. (Delay forMilliseconds: 50) wait]. "! ! !Form methodsFor: 'displaying' stamp: 'jm 5/25/2003 11:48'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aColor "Copy the given rectangular area from sourceForm into myself at the given destination point using the given combination rule and fill color." (BitBlt destForm: self sourceForm: sourceForm fillColor: aColor combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) copyBits. ! ! !Form methodsFor: 'displaying' stamp: 'jm 5/29/2003 17:58'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm map: map "Make up a BitBlt table and copy the bits. Use a colorMap." ((BitBlt destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) colorMap: map) copyBits! ! !Form methodsFor: 'displaying' stamp: 'jm 5/29/2003 17:58'! copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map "Make up a BitBlt table and copy the bits with the given colorMap." ((BitBlt destForm: self sourceForm: sourceForm halftoneForm: nil combinationRule: Form over destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: self boundingBox) colorMap: map) copyBits! ! !Form 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. ! ! !Form methodsFor: 'bordering'! border: aRectangle width: borderWidth fillColor: aColor "Paint a border whose rectangular area is defined by aRectangle. The width of the border of each side is borderWidth. Uses aColor for drawing the border." self border: aRectangle widthRectangle: (Rectangle left: borderWidth right: borderWidth top: borderWidth bottom: borderWidth) rule: Form over fillColor: aColor. ! ! !Form methodsFor: 'bordering' stamp: 'jm 5/29/2003 17:58'! border: rect width: borderWidth rule: rule fillColor: fillColor "Paint a fillColor colored border whose rectangular area is defined by rect. The width of the border of each side is borderWidth." | blt | blt _ (BitBlt toForm: self) combinationRule: rule; fillColor: fillColor; sourceOrigin: 0@0; destOrigin: rect origin. blt width: rect width; height: borderWidth; copyBits. blt destY: rect corner y - borderWidth; copyBits. blt destY: rect origin y + borderWidth; width: borderWidth; height: rect height - borderWidth - borderWidth; copyBits. blt destX: rect corner x - borderWidth; copyBits. ! ! !Form methodsFor: 'bordering'! border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aColor "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 aColor and combinationRule for drawing the border." (aRectangle areasOutside: (aRectangle insetBy: insets)) do: [:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aColor]. ! ! !Form methodsFor: 'bordering' stamp: 'jm 5/29/2003 18:06'! borderFormOfWidth: borderWidth sharpCorners: sharpen "Smear this form around and then subtract the original to produce an outline. If sharpen is true, then cause right angles to be outlined by right angles (takes an additional diagonal smears ANDed with both horizontal and vertical smears)." | smearForm bigForm smearPort all cornerForm cornerPort nbrs | depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." bigForm _ self deepCopy. all _ bigForm boundingBox. smearForm _ Form extent: self extent. smearPort _ BitBlt toForm: smearForm. sharpen ifTrue: [cornerForm _ Form extent: self extent. cornerPort _ BitBlt toForm: cornerForm]. nbrs _ (0@0) fourNeighbors. 1 to: borderWidth do: [:i | "Iterate to get several layers of 'skin'" nbrs do: [:d | "Smear the self in 4 directions to grow each layer of skin" smearPort copyForm: bigForm to: d rule: Form under]. sharpen ifTrue: ["Special treatment to smear sharp corners" nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do: [:d1 :d2 | "Copy corner points diagonally" cornerPort copyForm: bigForm to: d1+d2 rule: Form over. "But only preserve if there were dots on either side" cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and. cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and. smearPort copyForm: cornerForm to: 0@0 rule: Form under]. ]. bigForm copy: all from: 0@0 in: smearForm rule: Form over. ]. "Now erase the original shape to obtain the outline" bigForm copy: all from: 0@0 in: self rule: Form erase. ^ bigForm! ! !Form methodsFor: 'filling' stamp: 'di 2/19/1999 07:07'! anyShapeFill "Fill the interior of the outermost outlined region in the receiver, a 1-bit deep form. Typically the resulting form is used with fillShape:fillColor: to paint a solid color. See also convexShapeFill:" | shape | "Draw a seed line around the edge and fill inward from the outside." shape _ self findShapeAroundSeedBlock: [:f | f borderWidth: 1]. "Reverse so that this becomes solid in the middle" shape _ shape reverse. "Finally erase any bits from the original so the fill is only elsewhere" shape copy: shape boundingBox from: self to: 0@0 rule: Form erase. ^ shape! ! !Form methodsFor: 'filling' stamp: 'di 9/11/1998 16:25'! convexShapeFill: aMask "Fill the interior of the outtermost outlined region in the receiver. The outlined region must not be concave by more than 90 degrees. Typically aMask is Color black, to produce a solid fill. then the resulting form is used with fillShape: to paint a solid color. See also anyShapeFill" | destForm tempForm | destForm _ Form extent: self extent. destForm fillBlack. tempForm _ Form extent: self extent. (0@0) fourNeighbors do: [:dir | "Smear self in all 4 directions, and AND the result" self displayOn: tempForm at: (0@0) - self offset. tempForm smear: dir distance: (dir dotProduct: tempForm extent) abs. tempForm displayOn: destForm at: 0@0 clippingBox: destForm boundingBox rule: Form and fillColor: nil]. destForm displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form over fillColor: aMask! ! !Form methodsFor: 'filling'! fill: aRectangle fillColor: aColor "Fill the given rectangular area of the receiver with the given color." self fill: aRectangle rule: Form over fillColor: aColor. ! ! !Form methodsFor: 'filling' stamp: 'jm 5/25/2003 11:47'! fill: aRectangle rule: anInteger fillColor: aForm "Fill a rectangular area of the receiver with the given color and combination rule." (BitBlt toForm: self) copy: aRectangle from: 0@0 in: nil fillColor: aForm rule: anInteger. ! ! !Form methodsFor: 'filling'! fillBlack "Fill the entire receiver with black." self fill: self boundingBox rule: Form over fillColor: Color black. ! ! !Form methodsFor: 'filling'! fillBlack: aRectangle "Fill the given rectangular area of the receiver with black." self fill: aRectangle rule: Form over fillColor: Color black. ! ! !Form methodsFor: 'filling'! fillColor: aColor "Fill the entire receiver with the given color." self fill: self boundingBox rule: Form over fillColor: aColor. ! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 17:59'! fillFromXYColorBlock: colorBlock "General Gradient Fill. Supply relative x and y in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | poker yRel xRel | poker _ BitBlt bitPokerToForm: self. 0 to: height-1 do: [:y | yRel _ y asFloat / (height-1) asFloat. 0 to: width-1 do: [:x | xRel _ x asFloat / (width-1) asFloat. poker pixelAt: x@y put: ((colorBlock value: xRel value: yRel) pixelWordForDepth: depth)]] " | d | ((Form extent: 100@20 depth: Display depth) fillFromXYColorBlock: [:x :y | d _ 1.0 - (x - 0.5) abs - (y - 0.5) abs. Color r: d g: 0 b: 1.0-d]) display "! ! !Form methodsFor: 'filling' stamp: 'ee 10/25/2003 13:41'! fillFromYColorBlock: colorBlock "Vertical Gradient Fill. Supply relative y in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back." | yRel | 0 to: height-1 do: [:y | height = 1 ifTrue: [yRel _ y asFloat / 1 asFloat] ifFalse: [yRel _ y asFloat / (height-1) asFloat]. self fill: (0@y extent: width@1) fillColor: (colorBlock value: yRel)] " ((Form extent: 100@100 depth: Display depth) fillFromYColorBlock: [:y | Color r: y g: 0.0 b: 0.5]) display "! ! !Form methodsFor: 'filling' stamp: 'ee 7/28/2003 15:02'! fillRadialFromXColorBlock: colorBlock center: aPoint "Horizontal Gradient Fill. Supply relative x in [0.0 ... 1.0] to colorBlock, and paint each pixel with the color that comes back" | canvas t xRel m | m _ (width max: height). canvas _ self getCanvas. self fill: (self boundingBox) fillColor: (colorBlock value: 1). ((m-1) negated) to: 0 do: [:x | t _ x abs. xRel _ t asFloat / (m-1) asFloat. canvas frameOval: (Rectangle center: aPoint extent: (t@t)) color: (colorBlock value: xRel)]. ! ! !Form methodsFor: 'filling'! fillShape: aShapeForm fillColor: aColor "Fill a region corresponding to 1 bits in aShapeForm with the given color." ^ self fillShape: aShapeForm fillColor: aColor at: 0@0. ! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 17:59'! fillShape: aShapeForm fillColor: aColor at: location "Fill a region corresponding to 1 bits in aShapeForm with the given color." ((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. ! ! !Form methodsFor: 'filling'! fillWhite "Fill the entire receiver with white." self fill: self boundingBox fillColor: Color white. ! ! !Form methodsFor: 'filling'! fillWhite: aRectangle "Fill the given rectangular area of the receiver with white." self fill: aRectangle rule: Form over fillColor: Color white. ! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 17:59'! findShapeAroundSeedBlock: seedBlock "Build a shape that is black in any region marked by seedBlock. SeedBlock will be supplied a form, in which to blacken various pixels as 'seeds'. Then the seeds are smeared until there is no change in the smear when it fills the region, ie, when smearing hits a black border and thus goes no further." | smearForm previousSmear all count smearPort | depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." all _ self boundingBox. smearForm _ Form extent: self extent. smearPort _ BitBlt toForm: smearForm. seedBlock value: smearForm. "Blacken seeds to be smeared" smearPort copyForm: self to: 0@0 rule: Form erase. "Clear any in black" previousSmear _ smearForm deepCopy. count _ 1. [count = 10 and: "check for no change every 10 smears" [count _ 1. previousSmear copy: all from: 0@0 in: smearForm rule: Form reverse. previousSmear isAllWhite]] whileFalse: [smearPort copyForm: smearForm to: 1@0 rule: Form under. smearPort copyForm: smearForm to: -1@0 rule: Form under. "After horiz smear, trim around the region border" smearPort copyForm: self to: 0@0 rule: Form erase. smearPort copyForm: smearForm to: 0@1 rule: Form under. smearPort copyForm: smearForm to: 0@-1 rule: Form under. "After vert smear, trim around the region border" smearPort copyForm: self to: 0@0 rule: Form erase. count _ count+1. count = 9 ifTrue: "Save penultimate smear for comparison" [previousSmear copy: all from: 0@0 in: smearForm rule: Form over]]. "Now paint the filled region in me with aHalftone" ^ smearForm! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 18:00'! pixelValueAt: aPoint "Return the raw pixel value at the given point. This pixel value depends on the receiver's depth. Typical clients use colorAt: to get a Color. " ^ (BitBlt bitPeekerFromForm: self) pixelAt: aPoint ! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 18:00'! pixelValueAt: aPoint put: pixelValue "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue. ! ! !Form methodsFor: 'filling' stamp: 'jm 6/18/1999 19:01'! reverse "Invert the colors of the receiver." self fill: self boundingBox rule: Form reverse fillColor: (Color quickHighLight: self depth). ! ! !Form methodsFor: 'filling' stamp: 'jm 6/18/1999 19:00'! reverse: aRectangle "Invert the colors of the receiver in the given rectangular area." self fill: aRectangle rule: Form reverse fillColor: (Color quickHighLight: self depth). ! ! !Form methodsFor: 'filling' stamp: 'jm 5/29/2003 18:00'! shapeFill: aColor interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind | depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." interiorPixVal _ self pixelValueAt: interiorPoint. bwForm _ Form extent: self extent. map _ Bitmap new: (1 bitShift: (depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd _ depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd _ bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth. ind _ color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. "bwForm _ self makeBWForm: interiorColor." "not work for two whites" bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm _ bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. "Finally use that shape as a mask to flood the region with color" ((BitBlt destForm: self sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 0 with: 16rFFFFFFFF)) copyBits. self fillShape: bwForm fillColor: aColor. ^ bwForm! ! !Form methodsFor: 'filling' stamp: 'ee 7/18/2003 13:22'! shapeGradientFill: aColor altColor: aColor2 interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind newForm newBounds | depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." interiorPixVal _ self pixelValueAt: interiorPoint. bwForm _ Form extent: self extent. map _ Bitmap new: (1 bitShift: (depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd _ depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd _ bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth. ind _ color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. "bwForm _ self makeBWForm: (Color white)." "not work for two whites" bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm _ bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. newBounds _ (bwForm rectangleEnclosingPixelsNotOfColor: (Color white)). newForm _ Form extent: (newBounds extent) depth: 16. newForm offset: bwForm offset. newForm fillFromXColorBlock: [:x | aColor mixed: x with: aColor2]. "Finally use that shape as a mask to flood the region with color" ((BitBlt destForm: newForm sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: (newBounds origin) extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 16rFFFFFFFF with: 0)) copyBits. self copy: (newForm boundingBox) from: newForm to: (newBounds origin) rule: (Form paint). ^ self.! ! !Form methodsFor: 'filling' stamp: 'ee 7/28/2003 14:59'! shapeGradientRFill: aColor altColor: aColor2 interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind newForm newBounds | depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." interiorPixVal _ self pixelValueAt: interiorPoint. bwForm _ Form extent: self extent. map _ Bitmap new: (1 bitShift: (depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd _ depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd _ bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth. ind _ color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. "bwForm _ self makeBWForm: (Color white)." "not work for two whites" bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm _ bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. newBounds _ (bwForm rectangleEnclosingPixelsNotOfColor: (Color white)). newForm _ Form extent: (newBounds extent) depth: 16. newForm offset: bwForm offset. newForm fillRadialFromXColorBlock: [:x | aColor mixed: x with: aColor2] center: (interiorPoint - newBounds origin). "Finally use that shape as a mask to flood the region with color" ((BitBlt destForm: newForm sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: (newBounds origin) extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 16rFFFFFFFF with: 0)) copyBits. self copy: (newForm boundingBox) from: newForm to: (newBounds origin) rule: (Form paint). ^ self.! ! !Form methodsFor: 'filling' stamp: 'ee 7/25/2003 15:04'! shapeGradientVFill: aColor altColor: aColor2 interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind newForm newBounds | depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." interiorPixVal _ self pixelValueAt: interiorPoint. bwForm _ Form extent: self extent. map _ Bitmap new: (1 bitShift: (depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd _ depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd _ bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color _ Color colorFromPixelValue: interiorPixVal depth: depth. ind _ color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. "bwForm _ self makeBWForm: (Color white)." "not work for two whites" bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm _ bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. newBounds _ (bwForm rectangleEnclosingPixelsNotOfColor: (Color white)). newForm _ Form extent: (newBounds extent) depth: 16. newForm offset: bwForm offset. newForm fillFromYColorBlock: [:x | aColor mixed: x with: aColor2]. "Finally use that shape as a mask to flood the region with color" ((BitBlt destForm: newForm sourceForm: bwForm fillColor: nil combinationRule: Form erase1bitShape "Cut a hole in the picture with my mask" destOrigin: bwForm offset sourceOrigin: (newBounds origin) extent: self extent clipRect: self boundingBox) colorMap: (Bitmap with: 16rFFFFFFFF with: 0)) copyBits. self copy: (newForm boundingBox) from: newForm to: (newBounds origin) rule: (Form paint). ^ self.! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 5/29/2003 17:59'! flipBy: direction centerAt: aPoint "Return a copy of the receiver flipped either #vertical or #horizontal." | newForm quad | newForm _ self class extent: self extent depth: depth. quad _ self boundingBox innerCorners. quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)]) collect: [:i | quad at: i]. (WarpBlt toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededForDepth: depth); combinationRule: 3; copyQuad: quad toRect: newForm boundingBox. newForm offset: (self offset flipBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) flipBy: #vertical centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 _ f flipBy: #vertical centerAt: 0@0. (f2 flipBy: #vertical centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 6/15/2003 19:00'! magnify: aRectangle by: scale "Answer a Form created as a scaling of the receiver. Scale may be a Float, and may be greater or less than 1.0." ^ self magnify: aRectangle by: scale smoothing: 1 "Dynamic test... [Sensor anyButtonPressed] whileFalse: [(Display magnify: (Sensor cursorPoint extent: 31@41) by: 5@3) display] " "Scaling test... | f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100). Display restoreAfter: [Sensor waitNoButton. [Sensor anyButtonPressed] whileFalse: [cp _ Sensor cursorPoint. (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent) display]] " "Consistency test... | f f2 | f _ Form fromDisplay: (Rectangle originFromUser: 100@100). f2 _ f magnify: f boundingBox by: 5@3. (f2 magnify: f2 boundingBox by: 5 reciprocal @ 3 reciprocal) display " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 5/29/2003 17:59'! magnify: aRectangle by: scale smoothing: cellSize "Answer a Form created as a scaling of the receiver. Scale may be a Float, and may be greater or less than 1.0." | newForm | newForm _ self class extent: (aRectangle extent * scale) truncated depth: depth. (WarpBlt toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededForDepth: depth); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: Form over; copyQuad: aRectangle innerCorners toRect: newForm boundingBox. ^ newForm "Dynamic test... [Sensor anyButtonPressed] whileFalse: [(Display magnify: (Sensor cursorPoint extent: 131@81) by: 0.5 smoothing: 2) display] " "Scaling test... | f cp | f _ Form fromDisplay: (Rectangle originFromUser: 100@100). Display restoreAfter: [Sensor waitNoButton. [Sensor anyButtonPressed] whileFalse: [cp _ Sensor cursorPoint. (f magnify: f boundingBox by: (cp x asFloat@cp y asFloat)/f extent smoothing: 2) display]] "! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 6/15/2003 18:52'! magnifyBy: scale "Answer a Form created as a scaling of the receiver. Scale may be a Float, and it may be greater or less than 1.0." ^ self magnify: self boundingBox by: scale smoothing: (scale < 1 ifTrue: [2] ifFalse: [1]) "smooth if scale < 1" ! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 5/29/2003 18:00'! rotateBy: direction centerAt: aPoint "Return a rotated copy of the receiver. direction = #none, #right, #left, or #pi" | newForm quad rot | direction == #none ifTrue: [^ self]. newForm _ self class extent: (direction = #pi ifTrue: [width@height] ifFalse: [height@width]) depth: depth. quad _ self boundingBox innerCorners. rot _ #(right pi left) indexOf: direction. (WarpBlt toForm: newForm) sourceForm: self; colorMap: (self colormapIfNeededForDepth: depth); combinationRule: 3; copyQuad: ((1+rot to: 4+rot) collect: [:i | quad atWrap: i]) toRect: newForm boundingBox. newForm offset: (self offset rotateBy: direction centerAt: aPoint). ^ newForm " [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: #left centerAt: 0@0) display] " "Consistency test... | f f2 p | [Sensor anyButtonPressed] whileFalse: [f _ Form fromDisplay: ((p _ Sensor cursorPoint) extent: 31@41). Display fillBlack: (p extent: 31@41). f2 _ f rotateBy: #left centerAt: 0@0. (f2 rotateBy: #right centerAt: 0@0) displayAt: p] " ! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 5/29/2003 18:00'! rotateBy: deg magnify: scale smoothing: cellSize "Rotate the receiver by the indicated number of degrees and magnify. " "rot is the destination form, big enough for any angle." | side rot warp r1 pts p bigSide | side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger. bigSide _ (side * scale) rounded. rot _ Form extent: bigSide@bigSide depth: self depth. warp _ (WarpBlt toForm: rot) sourceForm: self; colorMap: (self colormapIfNeededForDepth: depth); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: Form paint. r1 _ (0@0 extent: side@side) align: (side@side)//2 with: self boundingBox center. "Rotate the corners of the source rectangle." pts _ r1 innerCorners collect: [:pt | p _ pt - r1 center. (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @ (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))]. warp copyQuad: pts toRect: rot boundingBox. ^ rot " | a f | f _ Form fromDisplay: (0@0 extent: 200@200). a _ 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a _ a+5) magnify: 0.75 smoothing: 2) display]. f display "! ! !Form methodsFor: 'scaling, rotation' stamp: 'jm 5/29/2003 18:00'! rotateBy: deg smoothing: cellSize "Rotate the receiver by the indicated number of degrees." "rot is the destination form, bit enough for any angle." | side rot warp r1 pts p center | side _ 1 + ((width*width) + (height*height)) asFloat sqrt asInteger. rot _ Form extent: side@side depth: self depth. center _ rot extent // 2. "Now compute the sin and cos constants for the rotation angle." warp _ (WarpBlt toForm: rot) sourceForm: self; colorMap: (self colormapIfNeededForDepth: depth); cellSize: cellSize; "installs a new colormap if cellSize > 1" combinationRule: Form over. r1 _ rot boundingBox align: center with: self boundingBox center. pts _ r1 innerCorners collect: [:pt | p _ pt - r1 center. (r1 center x asFloat + (p x asFloat*deg degreeCos) + (p y asFloat*deg degreeSin)) @ (r1 center y asFloat - (p x asFloat*deg degreeSin) + (p y asFloat*deg degreeCos))]. warp copyQuad: pts toRect: rot boundingBox. ^ rot " | a f | f _ Form fromDisplay: (0@0 extent: 200@200). a _ 0. [Sensor anyButtonPressed] whileFalse: [((Form fromDisplay: (Sensor cursorPoint extent: 130@66)) rotateBy: (a _ a+5) smoothing: 2) display]. f display "! ! !Form methodsFor: 'scaling, rotation' stamp: 'LB 7/25/2003 09:37'! toThumbnail: aExtent borderWidth: borderWidth borderColor: aColor "returns a thumbnail with the specified extent, border width and color" |thumb e r p| thumb _ Form extent: aExtent depth: 16. thumb fillColor: aColor. thumb border: thumb boundingBox width: borderWidth. "calculate the rectangle to be used by the thumbnail image" self width > self height ifTrue: [e _ thumb width @ ((self height * thumb width) // self width)] ifFalse: [e _ ((self width * thumb height) // self height) @ thumb height]. p _ (thumb extent - e) // 2. r _ p extent: e. (WarpBlt toForm: thumb) sourceForm: self; cellSize: 2; "do smoothing; this also installs a colormap" combinationRule: Form over; copyQuad: self boundingBox innerCorners toRect: (r insetBy: (borderWidth +1)). ^thumb ! ! !Form methodsFor: 'editing' stamp: 'jm 6/1/2003 06:07'! bitEdit "Create and schedule an editor on me located in an area designated by the user." BitEditor openOnForm: self. ! ! !Form methodsFor: 'image manipulation' stamp: 'bf 10/12/1999 18:07'! dominantColor | tally max maxi | depth > 16 ifTrue: [^(self asFormOfDepth: 16) dominantColor]. tally _ self tallyPixelValues. max _ maxi _ 0. tally withIndexDo: [:n :i | n > max ifTrue: [max _ n. maxi _ i]]. ^ Color colorFromPixelValue: maxi - 1 depth: depth! ! !Form methodsFor: 'image manipulation' stamp: 'ar 7/23/1999 17:04'! orderedDither32To16 "Do an ordered dithering for converting from 32 to 16 bit depth." | ditherMatrix ii out inBits outBits index pv dmv r di dmi dmo g b pvOut outIndex | self depth = 32 ifFalse:[^self error:'Must be 32bit for this']. ditherMatrix _ #( 0 8 2 10 12 4 14 6 3 11 1 9 15 7 13 5). ii _ (0 to: 31) collect:[:i| i]. out _ Form extent: self extent depth: 16. inBits _ self bits. outBits _ out bits. index _ outIndex _ 0. pvOut _ 0. 0 to: self height-1 do:[:y| 0 to: self width-1 do:[:x| pv _ inBits at: (index _ index + 1). dmv _ ditherMatrix at: (y bitAnd: 3) * 4 + (x bitAnd: 3) + 1. r _ pv bitAnd: 255. di _ r * 496 bitShift: -8. dmi _ di bitAnd: 15. dmo _ di bitShift: -4. r _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. g _ (pv bitShift: -8) bitAnd: 255. di _ g * 496 bitShift: -8. dmi _ di bitAnd: 15. dmo _ di bitShift: -4. g _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. b _ (pv bitShift: -16) bitAnd: 255. di _ b * 496 bitShift: -8. dmi _ di bitAnd: 15. dmo _ di bitShift: -4. b _ dmv < dmi ifTrue:[ii at: 2+dmo] ifFalse:[ii at: 1+dmo]. pvOut _ (pvOut bitShift: 16) + (b bitShift: 10) + (g bitShift: 5) + r. (x bitAnd: 1) = 1 ifTrue:[ outBits at: (outIndex _ outIndex+1) put: pvOut. pvOut _ 0]. ]. (self width bitAnd: 1) = 1 ifTrue:[ outBits at: (outIndex _ outIndex+1) put: (pvOut bitShift: -16). pvOut _ 0]. ]. ^out! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:06'! pixelCompare: aRect with: otherForm at: otherLoc "Compare the selected bits of this form (those within aRect) against those in a similar rectangle of otherFrom. Return the sum of the absolute value of the differences of the color values of every pixel. Obviously, this is most useful for rgb (16- or 32-bit) pixels but, in the case of 8-bits or less, this will return the sum of the differing bits of the corresponding pixel values (somewhat less useful)" | pixPerWord temp | pixPerWord _ 32//depth. (aRect left\\pixPerWord = 0 and: [aRect right\\pixPerWord = 0]) ifTrue: ["If word-aligned, use on-the-fly difference" ^ (BitBlt toForm: self) copy: aRect from: otherLoc in: otherForm fillColor: nil rule: 32]. "Otherwise, combine in a word-sized form and then compute difference" temp _ self copy: aRect. temp copy: aRect from: otherLoc in: otherForm rule: 21. ^ (BitBlt toForm: temp) copy: aRect from: otherLoc in: nil fillColor: (Bitmap with: 0) rule: 32 " Dumb example prints zero only when you move over the original rectangle... | f diff | f _ Form fromUser. [Sensor anyButtonPressed] whileFalse: [diff _ f pixelCompare: f boundingBox with: Display at: Sensor cursorPoint. diff printString , ' ' displayAt: 0@0] "! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:00'! primCountBits "Count the non-zero pixels of this form." depth > 8 ifTrue: [^(self asFormOfDepth: 8) primCountBits]. ^ (BitBlt toForm: self) fillColor: (Bitmap with: 0); destRect: (0@0 extent: width@height); combinationRule: 32; copyBits! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:10'! rectangleEnclosingPixelsNotOfColor: aColor "Answer the smallest rectangle enclosing all the pixels of me that are different from the given color. Useful for extracting a foreground graphic from its background." | cm slice copyBlt countBlt top bottom newH left right | "map the specified color to 1 and all others to 0" cm _ Bitmap new: (1 bitShift: (depth min: 15)). cm primFill: 1. cm at: (aColor indexInMap: cm) put: 0. cm _ ColorMap colors: cm. "build a 1-pixel high horizontal slice and BitBlts for counting pixels of interest" slice _ Form extent: width@1 depth: 1. copyBlt _ (BitBlt toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: width height: 1; colorMap: cm. countBlt _ (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from top and bottom" top _ (0 to: height) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0] ifNone: [^ 0@0 extent: 0@0]. bottom _ (height - 1 to: top by: -1) detect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits > 0]. "build a 1-pixel wide vertical slice and BitBlts for counting pixels of interest" newH _ bottom - top + 1. slice _ Form extent: 1@newH depth: 1. copyBlt _ (BitBlt toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: 1 height: newH; colorMap: cm. countBlt _ (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. "scan in from left and right" left _ (0 to: width) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. right _ (width - 1 to: left by: -1) detect: [:x | copyBlt sourceOrigin: x@top; copyBits. countBlt copyBits > 0]. ^ left@top corner: (right + 1)@(bottom + 1) ! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:00'! replaceColor: oldColor withColor: newColor "Replace one color with another everywhere is this form" | cm newInd target ff | depth = 32 ifTrue: [cm _ (Color cachedColormapFrom: 16 to: 32) copy] ifFalse: [cm _ Bitmap new: (1 bitShift: (depth min: 15)). 1 to: cm size do: [:i | cm at: i put: i - 1]]. newInd _ newColor pixelValueForDepth: depth. cm at: (oldColor pixelValueForDepth: (depth min: 16))+1 put: newInd. target _ newColor isTransparent ifTrue: [ff _ Form extent: self extent depth: depth. ff fillColor: newColor. ff] ifFalse: [self]. (BitBlt toForm: target) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form paint; destX: 0 destY: 0 width: width height: height; colorMap: cm; copyBits. newColor = Color transparent ifTrue: [target displayOn: self].! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:00'! smear: dir distance: dist "Smear any black pixels in this form in the direction dir in Log N steps" | skew bb | bb _ BitBlt destForm: self sourceForm: self fillColor: nil combinationRule: Form under destOrigin: 0@0 sourceOrigin: 0@0 extent: self extent clipRect: self boundingBox. skew _ 1. [skew < dist] whileTrue: [bb destOrigin: dir*skew; copyBits. skew _ skew+skew]! ! !Form methodsFor: 'image manipulation' stamp: 'jm 6/18/1999 18:41'! tallyPixelValues "Answer a Bitmap whose elements contain the number of pixels in this Form with the pixel value corresponding to their index. Note that the pixels of multiple Forms can be tallied together using tallyPixelValuesInRect:into:." ^ self tallyPixelValuesInRect: self boundingBox into: (Bitmap new: (1 bitShift: (self depth min: 15))) " Move a little rectangle around the screen and print its tallies... | r tallies nonZero | Cursor blank showWhile: [ [Sensor anyButtonPressed] whileFalse: [r _ Sensor cursorPoint extent: 10@10. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. tallies _ (Display copy: r) tallyPixelValues. nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] thenCollect: [:i | (tallies at: i) -> (i-1)]. nonZero printString , ' ' displayAt: 0@0. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] " ! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:00'! tallyPixelValuesInRect: aRectangle into: valueTable "Tally the selected pixels of this Form into valueTable, a Bitmap of depth 2^depth similar to a color map. Answer valueTable." (BitBlt toForm: self) sourceForm: self; "src must be given for color map ops" sourceOrigin: 0@0; tallyMap: valueTable; combinationRule: 33; destRect: aRectangle; sourceRect: aRectangle; copyBits. ^ valueTable " Move a little rectangle around the screen and print its tallies... | r tallies nonZero | Cursor blank showWhile: [ [Sensor anyButtonPressed] whileFalse: [r _ Sensor cursorPoint extent: 10@10. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil. tallies _ (Display copy: r) tallyPixelValues. nonZero _ (1 to: tallies size) select: [:i | (tallies at: i) > 0] thenCollect: [:i | (tallies at: i) -> (i-1)]. nonZero printString , ' ' displayAt: 0@0. Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]] "! ! !Form methodsFor: 'image manipulation' stamp: 'jm 6/30/1999 15:36'! trimBordersOfColor: aColor "Answer a copy of this Form with each edge trimmed in to the first pixel that is not of the given color. (That is, border strips of the given color are removed)." | r | r _ self rectangleEnclosingPixelsNotOfColor: aColor. ^ self copy: r ! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:00'! xTallyPixelValue: pv orNot: not "Return an array of the number of pixels with value pv by x-value. Note that if not is true, then this will tally those different from pv." | cm slice countBlt copyBlt | cm _ self newColorMap. "Map all colors but pv to zero" not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" cm at: pv+1 put: 1 - (cm at: pv+1). slice _ Form extent: 1@height. copyBlt _ (BitBlt destForm: slice sourceForm: self halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: 1 @ slice height clipRect: slice boundingBox) colorMap: cm. countBlt _ (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. ^ (0 to: width-1) collect: [:x | copyBlt sourceOrigin: x@0; copyBits. countBlt copyBits]! ! !Form methodsFor: 'image manipulation' stamp: 'jm 5/29/2003 18:06'! yTallyPixelValue: pv orNot: not "Return an array of the number of pixels with value pv by y-value. Note that if not is true, then this will tally those different from pv." | cm slice copyBlt countBlt | cm _ self newColorMap. "Map all colors but pv to zero" not ifTrue: [cm atAllPut: 1]. "... or all but pv to one" cm at: pv+1 put: 1 - (cm at: pv+1). slice _ Form extent: width@1. copyBlt _ (BitBlt destForm: slice sourceForm: self halftoneForm: nil combinationRule: Form over destOrigin: 0@0 sourceOrigin: 0@0 extent: slice width @ 1 clipRect: slice boundingBox) colorMap: cm. countBlt _ (BitBlt toForm: slice) fillColor: (Bitmap with: 0); destRect: (0@0 extent: slice extent); combinationRule: 32. ^ (0 to: height-1) collect: [:y | copyBlt sourceOrigin: 0@y; copyBits. countBlt copyBits]! ! !Form methodsFor: 'fileIn/Out' stamp: 'di 8/5/1998 11:37'! hibernate "Replace my bitmap with a compactly encoded representation (a ByteArray). It is vital that BitBlt and any other access to the bitmap (such as writing to a file) not be used when in this state. Since BitBlt will fail if the bitmap size is wrong (not = bitsSize), we do not allow replacement by a byteArray of the same (or larger) size." "NOTE: This method copies code from Bitmap compressToByteArray so that it can nil out the old bits during the copy, thus avoiding 2x need for extra storage." | compactBits lastByte | (bits isMemberOf: Bitmap) ifFalse: [^ self "already hibernated or weird state"]. compactBits _ ByteArray new: (bits size*4) + 7 + (bits size//1984*3). lastByte _ bits compress: bits toByteArray: compactBits. lastByte < (bits size*4) ifTrue: [bits _ nil. "Let GC reclaim the old bits before the copy if necessary" bits _ compactBits copyFrom: 1 to: lastByte]! ! !Form methodsFor: 'fileIn/Out' stamp: 'di 3/15/1999 14:50'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; print: width; nextPut: $x; print: height; nextPut: $x; print: depth; nextPut: $). ! ! !Form methodsFor: 'fileIn/Out' stamp: 'jm 6/15/2003 17:58'! readFromOldFormat: aBinaryStream "Read a Form in the original ST-80 format." | w h offsetX offsetY newForm theBits pos | self error: 'this method must be updated to read into 32-bit word bitmaps'. w _ aBinaryStream nextWord. h _ aBinaryStream nextWord. offsetX _ aBinaryStream nextWord. offsetY _ aBinaryStream nextWord. offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536]. offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536]. newForm _ (Form extent: w @ h) offset: offsetX @ offsetY. theBits _ newForm bits. pos _ 0. 1 to: w + 15 // 16 do: [:j | 1 to: h do: [:i | theBits at: (pos _ pos+1) put: aBinaryStream nextWord]]. newForm bits: theBits. ^ newForm ! ! !Form methodsFor: 'fileIn/Out'! storeBitsOn:aStream base:anInteger bits do: [:word | anInteger = 10 ifTrue: [aStream space] ifFalse: [aStream crtab: 2]. word printOn: aStream base: anInteger]. ! ! !Form methodsFor: 'fileIn/Out'! storeOn: aStream base: anInteger "Store the receiver out as an expression that can be evaluated to recreate a Form with the same contents as the original." self unhibernate. aStream nextPut: $(. aStream nextPutAll: self species name. aStream crtab: 1. aStream nextPutAll: 'extent: '. self extent printOn: aStream. aStream crtab: 1. aStream nextPutAll: 'depth: '. self depth printOn: aStream. aStream crtab: 1. aStream nextPutAll: 'fromArray: #('. self storeBitsOn:aStream base:anInteger. aStream nextPut: $). aStream crtab: 1. aStream nextPutAll: 'offset: '. self offset printOn: aStream. aStream nextPut: $). ! ! !Form methodsFor: 'fileIn/Out' stamp: 'ar 5/28/2000 00:52'! unhibernate "If my bitmap has been compressed into a ByteArray, then expand it now, and return true." bits == nil ifTrue:[bits _ Bitmap new: self bitsSize. ^true]. (bits isMemberOf: ByteArray) ifTrue: [bits _ Bitmap decompressFromByteArray: bits. ^ true]. ^ false! ! !Form methodsFor: 'fileIn/Out' stamp: 'di 12/6/1999 10:14'! writeBMPfileNamed: fName "Display writeBMPfileNamed: 'display'" | fileName bhSize biSize biClrUsed f biSizeImage bfOffBits rowBytes rgb data colorValues | self unhibernate. (#(1 4 8 32) includes: depth) ifFalse: [self halt "depth must be one of these"]. ((fileName _ fName) asUppercase endsWith: '.BMP') ifFalse: [fileName _ fName , '.BMP']. bhSize _ 14. "# bytes in file header" biSize _ 40. "info header size in bytes" biClrUsed _ depth = 32 ifTrue: [0] ifFalse:[1 << depth]. "No. color table entries" bfOffBits _ biSize + bhSize + (4*biClrUsed). rowBytes _ ((depth min: 24) * width + 31 // 32) * 4. biSizeImage _ height * rowBytes. f _ (FileStream newFileNamed: fileName) binary. "Write the file header" f position: 0. f nextLittleEndianNumber: 2 put: 19778. "bfType = BM" f nextLittleEndianNumber: 4 put: bfOffBits + biSizeImage. "Entire file size in bytes" f nextLittleEndianNumber: 4 put: 0. "bfReserved" f nextLittleEndianNumber: 4 put: bfOffBits. "Offset of bitmap data from start of hdr (and file)" "Write the bitmap info header" f position: bhSize. f nextLittleEndianNumber: 4 put: biSize. "info header size in bytes" f nextLittleEndianNumber: 4 put: width. "biWidth" f nextLittleEndianNumber: 4 put: height. "biHeight" f nextLittleEndianNumber: 2 put: 1. "biPlanes" f nextLittleEndianNumber: 2 put: (depth min: 24). "biBitCount" f nextLittleEndianNumber: 4 put: 0. "biCompression" f nextLittleEndianNumber: 4 put: biSizeImage. "size of image section in bytes" f nextLittleEndianNumber: 4 put: 2800. "biXPelsPerMeter" f nextLittleEndianNumber: 4 put: 2800. "biYPelsPerMeter" f nextLittleEndianNumber: 4 put: biClrUsed. f nextLittleEndianNumber: 4 put: 0. "biClrImportant" biClrUsed > 0 ifTrue: [ "write color map; this works for ColorForms, too" colorValues _ self colormapIfNeededForDepth: 32. 1 to: biClrUsed do: [:i | rgb _ colorValues at: i. 0 to: 24 by: 8 do: [:j | f nextPut: (rgb >> j bitAnd: 16rFF)]]]. 'Writing image data' displayProgressAt: Sensor cursorPoint from: 1 to: height during: [:bar | 1 to: height do: [:i | bar value: i. data _ (self copy: (0@(height-i) extent: width@1)) bits. depth = 32 ifTrue: [1 to: data size do: [:j | f nextLittleEndianNumber: 3 put: (data at: j)]. 1 to: (data size*3)+3//4*4-(data size*3) do: [:j | f nextPut: 0 "pad to 32-bits"]] ifFalse: [1 to: data size do: [:j | f nextNumber: 4 put: (data at: j)]]]]. f position = (bfOffBits + biSizeImage) ifFalse: [self halt]. f close. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'jm 5/25/2003 11:41'! writeOnFileNamed: fileName "Saves the receiver on the file fileName in the format: fileCode=2, depth, extent, offset, bits." | file | file _ FileStream newFileNamed: fileName. file binary. file nextPut: 2. self writeOn: file. file close. " | f | [(f _ Form fromUser) boundingBox area>25] whileTrue: [f writeOnFileNamed: 'test.form'. (Form newFromFileNamed: 'test.form') display]. "! ! !Form methodsFor: 'fileIn/Out' stamp: 'jm 5/25/2003 11:42'! writeUncompressedOn: file "Write the receiver on the file in the format depth, extent, offset, bits. The sender must write the header byte; see writeUncompressedOnFileNamed:." self unhibernate. file binary. file nextPut: depth. file nextWordPut: width. file nextWordPut: height. file nextWordPut: ((self offset x) >=0 ifTrue: [self offset x] ifFalse: [self offset x + 65536]). file nextWordPut: ((self offset y) >=0 ifTrue: [self offset y] ifFalse: [self offset y + 65536]). bits writeUncompressedOn: file. ! ! !Form methodsFor: 'fileIn/Out' stamp: 'jm 5/25/2003 11:40'! writeUncompressedOnFileNamed: fileName "Saves the receiver on the file fileName in the format: fileCode=2, depth, extent, offset, bits." | file | file _ FileStream newFileNamed: fileName. file binary. file nextPut: 2. self writeUncompressedOn: file. file close. " | f | [(f _ Form fromUser) boundingBox area>25] whileTrue: [f writeUncompressedOnFileNamed: 'test.form'. (Form fromBinaryStream: (FileStream oldFileNamed: 'test.form')) display]. "! ! !Form methodsFor: 'other' stamp: 'di 2/26/1999 07:29'! asCursorForm ^ self! ! !Form methodsFor: 'other' stamp: 'jm 5/29/2003 17:58'! asFormOfDepth: d | newForm | d = depth ifTrue:[^self]. newForm _ Form extent: self extent depth: d. (BitBlt toForm: newForm) colorMap: (self colormapIfNeededForDepth: d); copy: (self boundingBox) from: 0@0 in: self fillColor: nil rule: Form over. ^newForm! ! !Form methodsFor: 'other' stamp: 'jm 5/29/2003 18:06'! asGrayScale "Assume the receiver is a grayscale image. Return a grayscale ColorForm computed by extracting the brightness levels of one color component. This technique allows a 32-bit Form to be converted to an 8-bit ColorForm to save space while retaining a full 255 levels of gray. (The usual colormapping technique quantizes to 8, 16, or 32 levels, which loses information.)" | f32 srcForm result map bb grays | depth = 32 ifFalse: [ f32 _ Form extent: width@height depth: 32. self displayOn: f32. ^ f32 asGrayScale]. self unhibernate. srcForm _ Form extent: (width * 4)@height depth: 8. srcForm bits: bits. result _ ColorForm extent: width@height depth: 8. map _ Bitmap new: 256. 2 to: 256 do: [:i | map at: i put: i - 1]. map at: 1 put: 1. "map zero pixel values to near-black" bb _ (BitBlt toForm: result) sourceForm: srcForm; combinationRule: Form over; colorMap: map. 0 to: width - 1 do: [:dstX | bb sourceRect: (((dstX * 4) + 2)@0 extent: 1@height); destOrigin: dstX@0; copyBits]. "final BitBlt to zero-out pixels that were truely transparent in the original" map _ Bitmap new: 512. map at: 1 put: 16rFF. (BitBlt toForm: result) sourceForm: self; sourceRect: self boundingBox; destOrigin: 0@0; combinationRule: Form erase; colorMap: map; copyBits. grays _ (0 to: 255) collect: [:brightness | Color gray: brightness asFloat / 255.0]. grays at: 1 put: Color transparent. result colors: grays. ^ result ! ! !Form methodsFor: 'other' stamp: 'jm 4/5/1999 19:20'! colorReduced "Return a color-reduced ColorForm version of the receiver, if possible, or the receiver itself if not." | tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c | tally _ self tallyPixelValues asArray. tallyDepth _ (tally size log: 2) asInteger. colorCount _ 0. tally do: [:n | n > 0 ifTrue: [colorCount _ colorCount + 1]]. (tally at: 1) = 0 ifTrue: [colorCount _ colorCount + 1]. "include transparent" colorCount > 256 ifTrue: [^ self]. "cannot reduce" newForm _ self formForColorCount: colorCount. "build an array of just the colors used, and a color map to translate old pixel values to their indices into this color array" cm _ Bitmap new: tally size. oldPixelValues _ self colormapIfNeededForDepth: 32. newFormColors _ Array new: colorCount. newFormColors at: 1 put: Color transparent. nextColorIndex _ 2. 2 to: cm size do: [:i | (tally at: i) > 0 ifTrue: [ oldPixelValues = nil ifTrue: [c _ Color colorFromPixelValue: i - 1 depth: tallyDepth] ifFalse: [c _ Color colorFromPixelValue: (oldPixelValues at: i) depth: 32]. newFormColors at: nextColorIndex put: c. cm at: i put: nextColorIndex - 1. "pixel values are zero-based indices" nextColorIndex _ nextColorIndex + 1]]. "copy pixels into new ColorForm, mapping to new pixel values" newForm copyBits: self boundingBox from: self at: 0@0 clippingBox: self boundingBox rule: Form over fillColor: nil map: cm. newForm colors: newFormColors. newForm offset: offset. ^ newForm ! ! !Form methodsFor: 'other' stamp: 'jm 10/14/2003 20:16'! colorReduced8Bit "Return an 8-bit ColorForm version of the receiver." | tally tallyDepth colorCount newForm cm oldPixelValues newFormColors nextColorIndex c | tally _ self tallyPixelValues asArray. tallyDepth _ (tally size log: 2) asInteger. colorCount _ 0. tally do: [:n | n > 0 ifTrue: [colorCount _ colorCount + 1]]. (tally at: 1) = 0 ifTrue: [colorCount _ colorCount + 1]. "include transparent even if it's not used" colorCount > 256 ifTrue: [^ self]. "cannot reduce" newForm _ ColorForm extent: self extent depth: 8. "build an array of just the colors used, and a color map to translate old pixel values to their indices into this color array" cm _ Bitmap new: tally size. oldPixelValues _ self colormapIfNeededForDepth: 32. newFormColors _ Array new: colorCount. newFormColors at: 1 put: Color transparent. nextColorIndex _ 2. 2 to: cm size do: [:i | (tally at: i) > 0 ifTrue: [ oldPixelValues = nil ifTrue: [c _ Color colorFromPixelValue: i - 1 depth: tallyDepth] ifFalse: [c _ Color colorFromPixelValue: (oldPixelValues at: i) depth: 32]. newFormColors at: nextColorIndex put: c. cm at: i put: nextColorIndex - 1. "pixel values are zero-based indices" nextColorIndex _ nextColorIndex + 1]]. "copy pixels into new ColorForm, mapping to new pixel values" newForm copyBits: self boundingBox from: self at: 0@0 clippingBox: self boundingBox rule: Form over fillColor: nil map: cm. newForm colors: newFormColors. newForm offset: offset. ^ newForm ! ! !Form methodsFor: 'other' stamp: 'jm 5/29/2003 17:59'! mapColor: oldColor to: newColor "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | map _ (Color cachedColormapFrom: depth to: depth) copy. map at: (oldColor indexInMap: map) put: (newColor pixelWordForDepth: depth). (BitBlt toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'other' stamp: 'jm 5/29/2003 17:59'! mapColors: oldColorBitsCollection to: newColorBits "Make all pixels of the given color in this Form to the given new color." "Warnings: This method modifies the receiver. It may lose some color accuracy on 32-bit Forms, since the transformation uses a color map with only 15-bit resolution." | map | depth < 16 ifTrue: [map _ (Color cachedColormapFrom: depth to: depth) copy] ifFalse: [ "use maximum resolution color map" "source is 16-bit or 32-bit RGB; use colormap with 5 bits per color component" map _ Color computeRGBColormapFor: depth bitsPerColor: 5]. oldColorBitsCollection do:[ :oldColor | map at: oldColor put: newColorBits]. (BitBlt toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'transitions' stamp: 'jm 10/14/2002 19:02'! pageImage: otherImage at: topLeft corner: corner "Produce a page-turning illusion that gradually reveals otherImage located at topLeft in this form. Corner specifies which corner, as 1=topLeft, 2=topRight, 3=bottomRight, 4=bottomLeft." | bb maskForm resultForm delta maskLoc maskRect stepSize cornerSel smallRect p | stepSize _ 10. bb _ otherImage boundingBox. resultForm _ self copy: (topLeft extent: bb extent). maskForm _ Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint. "maskLoc _ starting loc rel to topLeft" otherImage width > otherImage height ifTrue: ["wide image; motion is horizontal." (corner between: 2 and: 3) not ifTrue: ["motion is to the right" delta _ 1@0. maskLoc _ bb topLeft - (corner = 1 ifTrue: [maskForm width@0] ifFalse: [maskForm width@stepSize])] ifFalse: ["motion is to the left" delta _ -1@0. maskLoc _ bb topRight - (corner = 2 ifTrue: [0@0] ifFalse: [0@stepSize])]] ifFalse: ["tall image; motion is vertical." corner <= 2 ifTrue: ["motion is downward" delta _ 0@1. maskLoc _ bb topLeft - (corner = 1 ifTrue: [0@maskForm height] ifFalse: [stepSize@maskForm height])] ifFalse: ["motion is upward" delta _ 0@-1. maskLoc _ bb bottomLeft - (corner = 3 ifTrue: [stepSize@0] ifFalse: [0@0])]]. "Build a solid triangle in the mask form" p _ Pen newOnForm: maskForm. corner even "Draw 45-degree line" ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2] ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]. maskForm smear: delta negated distance: maskForm width. "Copy the mask to full resolution for speed. Make it be the reversed so that it can be used for ORing in the page-corner color" maskForm _ (Form extent: maskForm extent depth: otherImage depth) copyBits: maskForm boundingBox from: maskForm at: 0@0 colorMap: (Bitmap with: 16rFFFFFFFF with: 0). "Now move the triangle maskForm across the resultForm selecting the triangular part of otherImage to display, and across the resultForm, selecting the part of the original image to erase." cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: corner. 1 to: (otherImage width + otherImage height // stepSize)+1 do: [:i | "Determine the affected square" maskRect _ (maskLoc extent: maskForm extent) intersect: bb. ((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue: [smallRect _ 0@0 extent: (maskRect width min: maskRect height) asPoint. maskRect _ smallRect align: (smallRect perform: cornerSel) with: (maskRect perform: cornerSel)]. "AND otherForm with triangle mask, and OR into result" resultForm copyBits: bb from: otherImage at: 0@0 clippingBox: maskRect rule: Form over fillColor: nil. resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc clippingBox: maskRect rule: Form erase fillColor: nil. resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc clippingBox: maskRect rule: Form under fillColor: Color lightBrown. "Now update Display in a single BLT." self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft clippingBox: self boundingBox rule: Form over fillColor: nil. Display forceDisplayUpdate. maskLoc _ maskLoc + (delta*stepSize)] " 1 to: 4 do: [:corner | Display pageImage: (Form fromDisplay: (10@10 extent: 200@300)) reverse at: 10@10 corner: corner] " ! ! !Form methodsFor: 'transitions' stamp: 'jm 5/29/2003 17:59'! pageWarp: otherImage at: topLeft forward: forward "Produce a page-turning illusion that gradually reveals otherImage located at topLeft in this form. forward == true means turn pages toward you, else away. [ignored for now]" | pageRect oldPage nSteps buffer p leafRect sourceQuad warp oldBottom d | pageRect _ otherImage boundingBox. oldPage _ self copy: (pageRect translateBy: topLeft). (forward ifTrue: [oldPage] ifFalse: [otherImage]) border: pageRect widthRectangle: (Rectangle left: 0 right: 2 top: 1 bottom: 1) rule: Form over fillColor: Color black. oldBottom _ self copy: ((pageRect bottomLeft + topLeft) extent: (pageRect width@(pageRect height//4))). nSteps _ 8. buffer _ Form extent: otherImage extent + (0@(pageRect height//4)) depth: self depth. d _ pageRect topLeft + (0@(pageRect height//4)) - pageRect topRight. 1 to: nSteps-1 do: [:i | forward ifTrue: [buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. p _ pageRect topRight + (d * i // nSteps)] ifFalse: [buffer copy: pageRect from: oldPage to: 0@0 rule: Form over. p _ pageRect topRight + (d * (nSteps-i) // nSteps)]. buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. leafRect _ pageRect topLeft corner: p x @ (pageRect bottom + p y). sourceQuad _ Array with: pageRect topLeft with: pageRect bottomLeft + (0@p y) with: pageRect bottomRight with: pageRect topRight - (0@p y). warp _ (WarpBlt toForm: buffer) clipRect: leafRect; sourceForm: (forward ifTrue: [oldPage] ifFalse: [otherImage]); combinationRule: Form paint. warp copyQuad: sourceQuad toRect: leafRect. self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. Display forceDisplayUpdate]. buffer copy: pageRect from: otherImage to: 0@0 rule: Form over. buffer copy: oldBottom boundingBox from: oldBottom to: pageRect bottomLeft rule: Form over. self copy: buffer boundingBox from: buffer to: topLeft rule: Form over. Display forceDisplayUpdate. " 1 to: 4 do: [:corner | Display pageWarp: (Form fromDisplay: (10@10 extent: 200@300)) reverse at: 10@10 forward: false] " ! ! !Form methodsFor: 'transitions' stamp: 'jm 6/18/1998 12:57'! wipeImage: otherImage at: topLeft clippingBox: clipBox rectForIndex: rectForIndexBlock | i clipRect t rectOrList waitTime | i _ 0. clipRect _ topLeft extent: otherImage extent. clipBox ifNotNil: [clipRect _ clipRect intersect: clipBox]. [rectOrList _ rectForIndexBlock value: (i _ i + 1). rectOrList == nil] whileFalse: [ t _ Time millisecondClockValue. rectOrList asOrderedCollection do: [:r | self copyBits: r from: otherImage at: topLeft + r topLeft clippingBox: clipRect rule: Form over fillColor: nil]. Display forceDisplayUpdate. waitTime _ 3 - (Time millisecondClockValue - t). waitTime > 0 ifTrue: ["(Delay forMilliseconds: waitTime) wait"]]. ! ! !Form methodsFor: 'transitions' stamp: 'di 1/28/1999 09:20'! zoomIn: goingIn orOutTo: otherImage at: topLeft vanishingPoint: vp "Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40. Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40." | nSteps j bigR lilR minTime startTime lead | nSteps _ 16. minTime _ 500. "milliseconds" startTime _ Time millisecondClockValue. ^ self wipeImage: otherImage at: topLeft clippingBox: nil rectForIndex: [:i | "i runs from 1 to nsteps" i > nSteps ifTrue: [nil "indicates all done"] ifFalse: ["If we are going too fast, delay for a bit" lead _ startTime + (i-1*minTime//nSteps) - Time millisecondClockValue. lead > 10 ifTrue: [(Delay forMilliseconds: lead) wait]. "Return an array with the difference rectangles for this step." j _ goingIn ifTrue: [i] ifFalse: [nSteps+1-i]. bigR _ vp - (vp*(j)//nSteps) corner: vp + (otherImage extent-vp*(j)//nSteps). lilR _ vp - (vp*(j-1)//nSteps) corner: vp + (otherImage extent-vp*(j-1)//nSteps). bigR areasOutside: lilR]]! ! !Form methodsFor: 'private' stamp: 'tk 3/13/2000 15:21'! hackBits: bitThing "This method provides an initialization so that BitBlt may be used, eg, to copy ByteArrays and other non-pointer objects efficiently. The resulting form looks 4 wide, 8 deep, and bitThing-size-in-words high." width _ 4. depth _ 8. bitThing class isBits ifFalse: [self error: 'bitThing must be a non-pointer object']. bitThing class isBytes ifTrue: [height _ bitThing basicSize // 4] ifFalse: [height _ bitThing basicSize]. bits _ bitThing! ! !Form methodsFor: 'private' stamp: 'jm 9/24/2003 12:15'! privateOffset ^ offset ! ! !Form methodsFor: 'private' stamp: 'ar 5/28/2000 15:49'! setExtent: extent depth: bitsPerPixel bits: bitmap "Create a virtual bit map with the given extent and bitsPerPixel." width _ extent x asInteger. width < 0 ifTrue: [width _ 0]. height _ extent y asInteger. height < 0 ifTrue: [height _ 0]. depth _ bitsPerPixel. (bits isNil or:[self bitsSize = bitmap size]) ifFalse:[^self error:'Bad dimensions']. bits _ bitmap! ! !Form class methodsFor: 'instance creation' stamp: 'jm 6/15/2003 17:57'! dotOfSize: diameter "Create a form which contains a round black dot." | radius form bb rect centerX centerY centerYBias centerXBias radiusSquared xOverY maxy dx | radius _ diameter//2. form _ (self extent: diameter@diameter) offset:(radius@radius) negated. bb _ (BitBlt toForm: form) sourceX: 0; sourceY: 0; combinationRule: Form over; fillColor: Color black. rect _ form boundingBox. centerX _ rect center x. centerY _ rect center y. centerYBias _ rect height odd ifTrue: [0] ifFalse: [1]. centerXBias _ rect width odd ifTrue: [0] ifFalse: [1]. radiusSquared _ (rect height asFloat / 2.0) squared - 0.01. xOverY _ rect width asFloat / rect height asFloat. maxy _ rect height - 1 // 2. "First do the inner fill, and collect x values" 0 to: maxy do: [:dy | dx _ ((radiusSquared - (dy * dy) asFloat) sqrt * xOverY) truncated. bb destX: centerX - centerXBias - dx destY: centerY - centerYBias - dy width: dx + dx + centerXBias + 1 height: 1; copyBits. bb destY: centerY + dy; copyBits]. ^ form " Time millisecondsToRun: [1 to: 20 do: [:i | (Form dotOfSize: i) displayAt: (i*20)@(i*20)]] "! ! !Form class methodsFor: 'instance creation' stamp: 'ar 10/9/1998 23:44'! extent: extentPoint depth: bitsPerPixel bits: aBitmap "Answer an instance of me with blank bitmap of the given dimensions and depth." ^ self basicNew setExtent: extentPoint depth: bitsPerPixel bits: aBitmap! ! !Form class methodsFor: 'instance creation' stamp: 'jm 6/15/2003 18:05'! fromBinaryStream: aBinaryStream "Read a Form or ColorForm from given file, using the first byte of the file to guess its format. Currently handles: GIF, uncompressed BMP, and both old and new DisplayObject writeOn: formats, JPEG, and PCX. Return nil if the file could not be read or was of an unrecognized format." | firstByte secondByte readerClass | aBinaryStream binary. firstByte _ aBinaryStream next. firstByte = 1 ifTrue: [ "old Squeakform format" ^ self new readFromOldFormat: aBinaryStream]. firstByte = 2 ifTrue: [ "new Squeak form format" ^ self new readFrom: aBinaryStream]. firstByte = $B asciiValue ifTrue: [ "BMP format" aBinaryStream skip: - 1. ^ self fromBMPStream: aBinaryStream]. firstByte = 16rFF ifTrue: [ secondByte _ aBinaryStream next. aBinaryStream skip: - 2. secondByte = 16rD8 ifTrue: [ ^ FastJPEG uncompress: aBinaryStream upToEnd doDithering: false]]. "Try for GIF, PNG, or other formats understood by subclasses of ImageReadWriter..." (readerClass _ self imageReaderClass) ifNil: [self error: 'unknown image format']. "Note: The following call closes the stream." ^ readerClass formFromStream: aBinaryStream ! ! !Form class methodsFor: 'instance creation' stamp: 'jm 1/11/1999 10:42'! fromFileNamed: fileName "Read a Form or ColorForm from the given file." | file form | file _ (FileStream readOnlyFileNamed: fileName) binary. form _ self fromBinaryStream: file. file close. ^ form ! ! !Form class methodsFor: 'instance creation' stamp: 'jm 6/15/2003 17:54'! fromUser "Answer an instance of me with bitmap initialized from the rectangle of the display screen designated by the user." ^ self fromDisplay: (Rectangle fromUser) ! ! !Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! blendAlpha "Answer the integer denoting BitBlt's blend-with-constant-alpha rule." ^ 30! ! !Form class methodsFor: 'mode constants' stamp: 'di 12/31/1998 14:02'! paintAlpha "Answer the integer denoting BitBlt's paint-with-constant-alpha rule." ^ 31! ! !Form class methodsFor: 'examples' stamp: 'jm 6/15/2003 18:50'! exampleMagnify "Form exampleMagnify" | f m | f _ Form fromUser. m _ f magnify: f boundingBox by: 3. m displayOn: Display. ! ! !Form class methodsFor: 'examples' stamp: 'jm 6/15/2003 17:58'! toothpaste: diam "Display restoreAfter: [Form toothpaste: 30]" "Draws wormlike lines by laying down images of spheres. See Ken Knowlton, Computer Graphics, vol. 15 no. 4 p352. Draw with mouse button down; terminate by option-click." | facade ball filter point queue port color q colors colr colr2 | colors _ Display depth = 1 ifTrue: [Array with: Color black] ifFalse: [Color red wheel: 12]. facade _ (Form extent: diam@diam) offset: (diam//-2) asPoint. (Form dotOfSize: diam) displayOn: facade at: (diam//2) asPoint clippingBox: facade boundingBox rule: Form under fillColor: Color white. #(1 2 3) do: [:x | "simulate facade by circles of gray" (Form dotOfSize: x*diam//5) displayOn: facade at: (diam*2//5) asPoint clippingBox: facade boundingBox rule: Form under fillColor: (Color perform: (#(black gray lightGray) at: x)). "facade displayAt: 50*x@50"]. ball _ Form dotOfSize: diam. color _ 8. [ true ] whileTrue: [port _ BitBlt toForm: Display. "Expand 1-bit forms to any pixel depth" port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF). queue _ OrderedCollection new: 32. 16 timesRepeat: [queue addLast: -20@-20]. Sensor waitButton. Sensor yellowButtonPressed ifTrue: [^ self]. filter _ Sensor cursorPoint. colr _ colors atWrap: (color _ color + 5). "choose increment relatively prime to colors size" colr2 _ colr mixed: 0.3 with: Color white. [Sensor redButtonPressed or: [queue size > 0]] whileTrue: [filter _ filter * 4 + Sensor cursorPoint // 5. point _ Sensor redButtonPressed ifTrue: [filter] ifFalse: [-20@-20]. port copyForm: ball to: point rule: Form paint fillColor: colr. (q _ queue removeFirst) == nil ifTrue: [^ self]. "exit" Display depth = 1 ifTrue: [port copyForm: facade to: q rule: Form erase] ifFalse: [port copyForm: facade to: q rule: Form paint fillColor: colr2]. Sensor redButtonPressed ifTrue: [queue addLast: point]]]. ! ! !Form class methodsFor: 'shut down' stamp: 'ar 5/28/2000 23:35'! shutDown "Form shutDown" "Compress all instances in the system. Will decompress on demand..." Form allInstancesDo: [:f | f hibernate]. ColorForm allInstancesDo: [:f | f hibernate].! ! !Form class methodsFor: 'private' stamp: 'di 2/3/1999 07:44'! bmpColorsFrom: aBinaryStream count: colorCount depth: depth "Read colorCount BMP color map entries from the given binary stream. Answer an array of Colors." | maxLevel colors b g r | colorCount = 0 ifTrue: [ "this BMP file does not have a color map" "default monochrome color map" depth = 1 ifTrue: [^ Array with: Color white with: Color black]. "default gray-scale color map" maxLevel _ (2 raisedTo: depth) - 1. ^ (0 to: maxLevel) collect: [:level | Color gray: (level asFloat / maxLevel)]]. colors _ Array new: colorCount. 1 to: colorCount do: [:i | b _ aBinaryStream next. g _ aBinaryStream next. r _ aBinaryStream next. aBinaryStream skip: 1. colors at: i put: (Color r: r g: g b: b range: 255)]. ^ colors ! ! !Form class methodsFor: 'private' stamp: 'jm 6/15/2003 18:04'! fromBMPStream: aBinaryStream "Read a BMP format image from the given binary stream." "Form fromBMPFile: (HTTPSocket httpGet: 'http://anHTTPServer/squeak/squeakers.bmp' accept: 'image/bmp')" | fType fSize reserved pixDataStart hdrSize w h planes d compressed colorCount colors colorForm | (aBinaryStream isMemberOf: String) ifTrue: [^ nil]. "a network error message" aBinaryStream binary. fType _ aBinaryStream nextLittleEndianNumber: 2. fSize _ aBinaryStream nextLittleEndianNumber: 4. reserved _ aBinaryStream nextLittleEndianNumber: 4. pixDataStart _ aBinaryStream nextLittleEndianNumber: 4. hdrSize _ aBinaryStream nextLittleEndianNumber: 4. w _ aBinaryStream nextLittleEndianNumber: 4. h _ aBinaryStream nextLittleEndianNumber: 4. planes _ aBinaryStream nextLittleEndianNumber: 2. d _ aBinaryStream nextLittleEndianNumber: 2. compressed _ aBinaryStream nextLittleEndianNumber: 4. aBinaryStream nextLittleEndianNumber: 4. "biSizeImage" aBinaryStream nextLittleEndianNumber: 4. "biXPelsPerMeter" aBinaryStream nextLittleEndianNumber: 4. "biYPelsPerMeter" colorCount _ aBinaryStream nextLittleEndianNumber: 4. aBinaryStream nextLittleEndianNumber: 4. "biClrImportant" ((fType = 19778) & (reserved = 0) & (planes = 1) & (hdrSize = 40) & (fSize <= aBinaryStream size)) ifFalse: [self error: 'Bad BMP file header']. compressed = 0 ifFalse: [self error: 'Can only read uncompressed BMP files']. d = 24 ifTrue: [ aBinaryStream position: pixDataStart. ^ self bmp24BitPixelDataFrom: aBinaryStream width: w height: h]. "read the color map" "Note: some programs (e.g. Photoshop 4.0) apparently do not set colorCount; assume that any data between the end of the header and the start of the pixel data is the color map" colorCount _ (pixDataStart - 54) // 4. colors _ self bmpColorsFrom: aBinaryStream count: colorCount depth: d. "read the pixel data" aBinaryStream position: pixDataStart. colorForm _ self bmpPixelDataFrom: aBinaryStream width: w height: h depth: d. colorForm colors: colors. ^ colorForm ! ! !Form class methodsFor: 'private' stamp: 'jm 6/20/2003 09:08'! imageReaderClass "If present, answer the class for importing various graphic image files from disk. Otherwise return nil." | aClass | ^ ((aClass _ Smalltalk at: #ImageReadWriter ifAbsent: [nil]) isKindOf: Class) ifTrue: [aClass] ifFalse: [nil] ! ! My instances are used to save information needed to construct the switch in a menu for a FormEditor. A collection of my instances is stored as a class variable of FormMenuView.! I'm a subclass of Canvas for drawing on Forms. Note that when shadowDrawing is true, shadowStipple may be either a color, for a solid shadow of the given color, or it may be a stipple used to simulate gray shading when the display cannot support alpha blending. ! !FormCanvas methodsFor: 'initialize-release' stamp: 'ar 2/17/2000 00:21'! reset origin _ 0@0. "origin of the top-left corner of this cavas" clipRect _ (0@0 corner: 10000@10000). "default clipping rectangle" self shadowColor: nil.! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 5/28/2000 17:11'! allocateForm: extentPoint "Allocate a new form which is similar to the receiver" ^form allocateForm: extentPoint! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:06'! clipRect "Return the currently active clipping rectangle" ^ clipRect translateBy: origin negated! ! !FormCanvas methodsFor: 'accessing' stamp: 'jm 6/15/2003 19:08'! contentsOfArea: aRectangle into: aForm port destForm displayOn: aForm at: (aRectangle origin + origin) negated clippingBox: (0@0 extent: aRectangle extent). ^ aForm ! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'! origin "Return the current origin for drawing operations" ^ origin! ! !FormCanvas methodsFor: 'accessing' stamp: 'jm 11/24/2002 11:16'! shadowColor ^ shadowColor ! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 2/17/2000 00:26'! shadowColor: aColor shadowColor _ aColor! ! !FormCanvas methodsFor: 'testing' stamp: 'ar 2/17/2000 00:24'! isShadowDrawing ^ self shadowColor notNil! ! !FormCanvas methodsFor: 'testing' stamp: 'ar 6/22/1999 14:08'! isVisible: aRectangle "Optimization" (aRectangle right + origin x) < clipRect left ifTrue: [^ false]. (aRectangle left + origin x) > clipRect right ifTrue: [^ false]. (aRectangle bottom + origin y) < clipRect top ifTrue: [^ false]. (aRectangle top + origin y) > clipRect bottom ifTrue: [^ false]. ^ true ! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'! copyClipRect: aRectangle ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin) ! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! copyOffset: aPoint ^ self copyOrigin: origin + aPoint clipRect: clipRect! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! 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)! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! 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)! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 5/14/2000 15:50'! fillColor: c "Note: This always fills, even if the color is transparent." self setClearColor: c. port fillRect: form boundingBox offset: origin.! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 2/17/2000 00:12'! line: pt1 to: pt2 brushForm: brush | offset | offset _ origin. self setPaintColor: Color black. port sourceForm: brush; fillColor: nil; sourceRect: brush boundingBox; colorMap: (brush colormapIfNeededForDepth: self depth); drawFrom: (pt1 + offset) to: (pt2 + offset)! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 2/16/2000 22:07'! line: pt1 to: pt2 width: w color: c | offset | offset _ origin - (w // 2) asPoint. self setFillColor: c. port width: w; height: w; drawFrom: (pt1 + offset) to: (pt2 + offset)! ! !FormCanvas methodsFor: 'drawing' stamp: 'jm 11/25/2002 12:39'! paragraph: para bounds: bounds color: c | clipR scanner | self setPaintColor: c. clipR _ bounds translateBy: origin. scanner _ (port clippedBy: clipR) displayScannerFor: para foreground: (self shadowColor ifNil:[c]) background: Color transparent ignoreColorChanges: self shadowColor notNil. para displayOn: (self copyClipRect: bounds) using: scanner at: clipR topLeft. ! ! !FormCanvas methodsFor: 'drawing' stamp: 'ar 5/18/2000 18:35'! text: s bounds: boundsRect font: fontOrNil color: c | scanner | scanner _ DisplayScanner quickPrintOn: form box: ((boundsRect translateBy: origin) intersect: clipRect) truncated font: fontOrNil color: (self shadowColor ifNil:[c]). scanner drawString: s at: boundsRect topLeft + origin! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! clipBy: aRectangle during: aBlock "Set a clipping rectangle active only during the execution of aBlock. Note: In the future we may want to have more general clip shapes - not just rectangles" ^aBlock value: (self copyClipRect: aRectangle)! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 5/25/2000 18:04'! transformBy: aDisplayTransform clippingTo: aClipRect during: aBlock smoothing: cellSize "Note: This method has been originally copied from TransformationMorph." | innerRect patchRect sourceQuad warp start subCanvas | (aDisplayTransform isPureTranslation) ifTrue:[ ^aBlock value: (self copyOffset: aDisplayTransform offset negated truncated clipRect: aClipRect) ]. "Prepare an appropriate warp from patch to innerRect" innerRect _ aClipRect. patchRect _ aDisplayTransform globalBoundsToLocal: innerRect. sourceQuad _ (aDisplayTransform sourceQuadFor: innerRect) collect: [:p | p - patchRect topLeft]. warp _ self warpFrom: sourceQuad toRect: innerRect. warp cellSize: cellSize. "Render the submorphs visible in the clipping rectangle, as patchForm" start _ (self depth = 1 and: [self isShadowDrawing not]) "If this is true B&W, then we need a first pass for erasure." ifTrue: [1] ifFalse: [2]. start to: 2 do: [:i | "If i=1 we first make a shadow and erase it for opaque whites in B&W" subCanvas _ self class extent: patchRect extent depth: self depth. i=1 ifTrue: [subCanvas shadowColor: Color black. warp combinationRule: Form erase] ifFalse: [self isShadowDrawing ifTrue: [subCanvas shadowColor: self shadowColor]. warp combinationRule: Form paint]. subCanvas translateBy: patchRect topLeft negated during:[:offsetCanvas| aBlock value: offsetCanvas]. warp sourceForm: subCanvas form; warpBits. warp sourceForm: nil. subCanvas _ nil "release space for next loop"] ! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:03'! translateBy: delta clippingTo: aRectangle during: aBlock "Set a translation and clipping rectangle only during the execution of aBlock." ^aBlock value: (self copyOffset: delta clipRect: aRectangle)! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 03:02'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." ^aBlock value: (self copyOffset: delta)! ! !FormCanvas methodsFor: 'drawing-support' stamp: 'ar 6/17/1999 02:55'! translateTo: newOrigin clippingTo: aRectangle during: aBlock "Set a new origin and clipping rectangle only during the execution of aBlock." aBlock value: (self copyOrigin: newOrigin clipRect: aRectangle)! ! !FormCanvas methodsFor: 'other'! forceToScreen:rect ^Display forceToScreen:rect. ! ! !FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 17:07'! printOn: aStream super printOn: aStream. aStream nextPutAll:' on: '; print: form.! ! !FormCanvas methodsFor: 'other' stamp: 'jm 5/29/2003 18:01'! showAt: pt invalidRects: updateRects | blt | blt _ (BitBlt toForm: Display) sourceForm: form; combinationRule: Form over. updateRects do: [:rect | blt sourceRect: rect; destOrigin: rect topLeft + pt; copyBits]! ! !FormCanvas methodsFor: 'other' stamp: 'jm 5/29/2003 18:01'! warpFrom: sourceQuad toRect: destRect ^ (WarpBlt toForm: port destForm) combinationRule: Form paint; sourceQuad: sourceQuad destRect: (destRect translateBy: origin); clipRect: clipRect ! ! !FormCanvas methodsFor: 'private' stamp: 'jm 11/12/2002 13:08'! resetGrafPort "Private!! Create a new grafPort for a new copy." port _ GrafPort toForm: form. port clipRect: clipRect. ! ! !FormCanvas methodsFor: 'private' stamp: 'jm 10/7/2002 05:27'! setClearColor: aColor "Install a new clear color - e.g., a color is used for clearing the background" | clearColor | clearColor _ aColor ifNil: [Color transparent]. clearColor isColor ifFalse: [ (clearColor isKindOf: InfiniteForm) ifFalse: [^ self error:'Cannot install color']. port fillPattern: clearColor; combinationRule: Form over. ^ self]. "clearColor really *is* a color" port sourceForm: nil. port combinationRule: Form over. port fillPattern: clearColor. self depth = 8 ifTrue: [ "use a stipple pattern" port fillColor: (clearColor balancedPatternForDepth: 8)]. ! ! !FormCanvas methodsFor: 'private' stamp: 'jm 11/24/2002 11:36'! setFillColor: aColor "Install a new color used for filling." | screen patternWord fillColor | fillColor _ self shadowColor ifNil: [aColor]. fillColor ifNil: [fillColor _ Color transparent]. fillColor isColor ifFalse: [ (fillColor isKindOf: InfiniteForm) ifFalse: [^ self error:'Cannot use an InfiniteForm here']. port fillPattern: fillColor; combinationRule: Form over. "use a stipple pattern" ^ self]. "fillColor really *is* a color" port sourceForm: nil. fillColor isTranslucent ifFalse: [ port combinationRule: Form over. port fillPattern: fillColor. self depth = 8 ifTrue: [ "In 8 bit depth it's usually a good idea to use a stipple pattern" port fillColor: (fillColor balancedPatternForDepth: 8)]. ^ self]. "fillColor is a translucent color" self depth > 8 ifTrue: [ "BitBlt setup for alpha masked transfer" port fillPattern: fillColor. self depth = 16 ifTrue: [port alphaBits: fillColor privateAlpha; combinationRule: 30] ifFalse: [port combinationRule: Form blend]. ^ self]. "Can't represent actual transparency -- use stipple pattern" screen _ Color translucentMaskFor: fillColor alpha depth: self depth. patternWord _ fillColor pixelWordForDepth: self depth. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint. ! ! !FormCanvas methodsFor: 'private' stamp: 'jm 11/12/2002 13:08'! setForm: aForm self reset. form _ aForm. port _ GrafPort toForm: form. ! ! !FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'! setOrigin: aPoint clipRect: aRectangle origin _ aPoint. clipRect _ aRectangle. port clipRect: aRectangle. ! ! !FormCanvas methodsFor: 'private' stamp: 'jm 10/7/2002 05:23'! setPaintColor: aColor "Install a new color used for filling." | paintColor screen patternWord | paintColor _ self shadowColor ifNil: [aColor]. paintColor ifNil: [paintColor _ Color transparent]. paintColor isColor ifFalse:[ (paintColor isKindOf: InfiniteForm) ifFalse:[^ self error:'Cannot install color']. port fillPattern: paintColor; combinationRule: Form paint. ^ self]. "Okay, so paintColor really *is* a color" port sourceForm: nil. (paintColor isTranslucent) ifFalse: [ port fillPattern: paintColor. port combinationRule: Form paint. self depth = 8 ifTrue: [ port fillColor: (paintColor balancedPatternForDepth: 8)]. ^ self]. "paintColor is a translucent color" self depth > 8 ifTrue: [ "BitBlt setup for alpha mapped transfer" port fillPattern: paintColor. self depth = 16 ifTrue: [port alphaBits: paintColor privateAlpha; combinationRule: 31] ifFalse: [port combinationRule: Form blend]. ^ self]. "Can't represent actual transparency -- use stipple pattern" screen _ Color translucentMaskFor: paintColor alpha depth: self depth. patternWord _ paintColor pixelWordForDepth: self depth. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint ! ! !FormCanvas methodsFor: 'converting' stamp: 'jm 1/6/2003 12:25'! asShadowDrawingCanvas: aColor "Answer a copy of me for drawing drop-shadows." ^ self copy shadowColor: aColor ! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 5/14/2000 15:50'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: borderColor | rect | rect _ r translateBy: origin. "draw the border of the rectangle" borderColor isTransparent ifFalse:[ self setFillColor: borderColor. (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [ port frameRect: rect borderWidth: borderWidth. ] ifFalse: ["for small rectangles, it's faster to fill the entire outer rectangle than to compute and fill the border rects" port fillRect: rect offset: origin]]. "fill the inside" fillColor isTransparent ifFalse: [self setFillColor: fillColor. port fillRect: (rect insetBy: borderWidth) offset: origin].! ! !FormCanvas methodsFor: 'drawing-rectangles' stamp: 'ar 2/16/2000 22:07'! frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth topLeftColor: topLeftColor bottomRightColor: bottomRightColor | w h rect | "First use quick code for top and left borders and fill" self frameAndFillRectangle: r fillColor: fillColor borderWidth: borderWidth borderColor: topLeftColor. "Now use slow code for bevelled bottom and right borders" bottomRightColor isTransparent ifFalse: [ borderWidth isNumber ifTrue: [w _ h _ borderWidth] ifFalse: [w _ borderWidth x. h _ borderWidth y]. rect _ r translateBy: origin. self setFillColor: bottomRightColor. port frameRectRight: rect width: w; frameRectBottom: rect height: h]. ! ! !FormCanvas methodsFor: 'drawing-ovals' stamp: 'jm 11/29/2002 09:29'! fillOval: r color: fillColor borderWidth: borderWidth borderColor: borderColor | rect | "draw the border of the oval" rect _ r translateBy: origin. borderColor isTransparent ifFalse:[ self setFillColor: borderColor. (r area > 10000 or: [fillColor isTranslucent]) ifTrue: [port frameOval: rect borderWidth: borderWidth] ifFalse: [port fillOval: rect]]. "faster this way" "fill the inside" fillColor isTransparent ifFalse: [ self setFillColor: fillColor. port fillOval: (rect insetBy: borderWidth)]. ! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'jm 10/7/2002 05:27'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededForDepth: form depth); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule. ! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'jm 3/18/2003 11:22'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: alpha "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." port colorMap: (aForm colormapIfNeededForDepth: form depth); fillColor: nil. port image: aForm at: aPoint + origin sourceRect: sourceRect rule: rule alpha: alpha. ! ! !FormCanvas methodsFor: 'drawing-images' stamp: 'jm 10/7/2002 05:20'! stencil: stencilForm at: aPoint sourceRect: sourceRect color: aColor "Flood this canvas with aColor wherever stencilForm has non-zero pixels" self setPaintColor: aColor. port colorMap: (Color maskingMap: stencilForm depth). port stencil: stencilForm at: aPoint + origin sourceRect: sourceRect. ! ! !FormCanvas class methodsFor: 'testing' stamp: 'jm 11/12/2002 12:23'! test1 "FormCanvas test1" | canvas | canvas _ FormCanvas extent: 200@200. canvas fillColor: (Color black). canvas line: 10@10 to: 50@30 width: 1 color: (Color red). canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: (Color green). canvas text: 'Hello, World!!' at: 40@40 font: nil color: (Color cyan). canvas fillRectangle: ((10@80) corner: (31@121)) color: (Color magenta). canvas fillOval: ((10@80) corner: (31@121)) color: (Color cyan). canvas frameOval: ((40@80) corner: (61@121)) color: (Color blue). canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: (Color red alpha: 0.2). canvas fillRectangle: ((130@30) corner: (170@80)) color: (Color lightYellow). canvas showAt: 0@0. ! ! !FormCanvas class methodsFor: 'testing' stamp: 'jm 11/12/2002 12:23'! test2 "FormCanvas test2" | baseCanvas p | baseCanvas _ FormCanvas extent: 200@200. p _ Sensor cursorPoint. [Sensor anyButtonPressed] whileFalse: [ baseCanvas translateBy: (Sensor cursorPoint - p) during:[:canvas| canvas fillColor: Color white. canvas line: 10@10 to: 50@30 width: 1 color: Color red. canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. canvas text: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. canvas showAt: 0@0]]. ! ! !FormCanvas class methodsFor: 'testing' stamp: 'jm 11/12/2002 12:23'! test3 "FormCanvas test3" | baseCanvas | baseCanvas _ FormCanvas extent: 200@200. baseCanvas fillColor: Color white. baseCanvas translateBy: 10@10 during:[:canvas| canvas shadowColor: (Color black alpha: 0.5). canvas line: 10@10 to: 50@30 width: 1 color: Color red. canvas frameRectangle: ((20@20) corner: (120@120)) width: 4 color: Color green. canvas text: 'Hello, World!!' at: 40@40 font: nil color: Color cyan. canvas fillRectangle: ((10@80) corner: (31@121)) color: Color magenta. canvas fillOval: ((10@80) corner: (31@121)) color: Color cyan. canvas frameOval: ((40@80) corner: (61@121)) color: Color blue. canvas frameOval: ((70@80) corner: (91@121)) width: 3 color: Color red. canvas fillRectangle: ((130@30) corner: (170@80)) color: Color lightYellow. canvas showAt: 0@0. ].! ! I represent a view of a Form. Editing takes place by modifying a working version of the Form. The message accept is used to copy the working version into the Form; the message cancel copies the Form into the working version.! I represent a Controller that takes control if a key on the keyboard is depressed or if the cursor is within my rectangular area.! I represent a View whose subViews are Switches (and Buttons and OneOnSwitches) whose actions set the mode, color, and tool for editing a Form on the screen. The default controller of my instances is FormMenuController.! I represent a view of a Form.! !FormView methodsFor: 'controller access' stamp: 'jm 10/4/2002 16:07'! defaultControllerClass ^ NoController! ! !FormView methodsFor: 'displaying' stamp: 'jm 5/12/2003 19:59'! displayOn: aBitBlt (model isKindOf: InfiniteForm) ifTrue: [ model displayUsingBitBlt: aBitBlt at: self displayBox origin. ^ self]. aBitBlt copyForm: model to: self displayBox origin rule: Form over. ! ! !FormView class methodsFor: 'examples' stamp: 'di 9/12/1998 10:17'! open: aForm named: aString "FormView open: ((Form extent: 100@100) borderWidth: 1) named: 'Squeak' " "Open a window whose model is aForm and whose label is aString." | topView aView | topView _ StandardSystemView new. topView model: aForm. topView label: aString. topView minimumSize: 80@80. aView _ FormView new. aView model: aForm. aView window: (aForm boundingBox expandBy: 2). aView borderWidthLeft: 2 right: 2 top: 2 bottom: 2. topView addSubView: aView. topView controller open! ! I represent some rational number as a fraction. All public arithmetic operations answer reduced fractions.! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! * aNumber "Answer the result of multiplying the receiver by aNumber." | d1 d2 | aNumber isFraction ifTrue: [d1 _ numerator gcd: aNumber denominator. d2 _ denominator gcd: aNumber numerator. (d2 = denominator and: [d1 = aNumber denominator]) ifTrue: [^ numerator // d1 * (aNumber numerator // d2)]. ^ Fraction numerator: numerator // d1 * (aNumber numerator // d2) denominator: denominator // d2 * (aNumber denominator // d1)]. ^ aNumber adaptToFraction: self andSend: #*! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! + aNumber "Answer the sum of the receiver and aNumber." | n d d1 d2 | aNumber isFraction ifTrue: [d _ denominator gcd: aNumber denominator. n _ numerator * (d1 _ aNumber denominator // d) + (aNumber numerator * (d2 _ denominator // d)). d1 _ d1 * d2. n _ n // (d2 _ n gcd: d). (d _ d1 * (d // d2)) = 1 ifTrue: [^ n]. ^ Fraction numerator: n denominator: d]. ^ aNumber adaptToFraction: self andSend: #+! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! - aNumber "Answer the difference between the receiver and aNumber." aNumber isFraction ifTrue: [^ self + aNumber negated]. ^ aNumber adaptToFraction: self andSend: #-! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! / aNumber "Answer the result of dividing the receiver by aNumber." aNumber isFraction ifTrue: [^self * aNumber reciprocal]. ^ aNumber adaptToFraction: self andSend: #/! ! !Fraction methodsFor: 'comparing' stamp: 'di 11/6/1998 13:58'! < aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator < (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andSend: # thisImageColorTable size ifTrue: [ thisImageColorTable _ thisImageColorTable forceTo: transparentIndex + 1 paddingWith: Color white]. thisImageColorTable at: transparentIndex + 1 put: Color transparent]. f colors: thisImageColorTable. ^ f ! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'jm 10/14/2003 20:02'! nextPutImage: aForm | f newF | aForm unhibernate. f _ aForm. f depth > 8 ifTrue: [ f _ aForm colorReduced8Bit. "try to reduce depth" f depth > 8 ifTrue: [f _ f asFormOfDepth: 8]]. "quantize colors" f depth < 8 ifTrue: [ "Note: writeBitData: expects depth of 8" newF _ f class extent: f extent depth: 8. (f isKindOf: ColorForm) ifTrue: [ newF copyBits: f boundingBox from: f at: 0@0 clippingBox: f boundingBox rule: Form over fillColor: nil map: nil. newF colors: f colors] ifFalse: [f displayOn: newF]. f _ newF]. transparentIndex _ nil. (f isKindOf: ColorForm) ifTrue: [ f _ f asFormWithSingleTransparentColor. (f colorsUsed includes: Color transparent) ifTrue: [ transparentIndex _ (f colors indexOf: Color transparent) - 1]]. width _ f width. height _ f height. bitsPerPixel _ f depth. colorPalette _ f colormapIfNeededForDepth: 32. interlace _ false. self writeHeader. self writeBitData: f bits. self nextPut: Terminator. self close. ! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'! understandsImageFormat ^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! ! !GIFReadWriter methodsFor: 'animated GIF writing' stamp: 'jm 6/21/2003 19:19'! formToSaveFrom: aForm warnIfLosingColorPrecision: warningFlag "Answer a copy of the given Form of the proper depth to be saved, reducing colors if necessary. If warningFlag is true and color precision will be lost, inform the user. Also record the color palette and the transparent color index." | f newF | aForm unhibernate. f _ aForm. f depth > 8 ifTrue: [ f _ aForm colorReduced. "minimize depth" f depth > 8 ifTrue: [ warningFlag ifTrue: [ self inform: 'Too many colors for GIF. Saving image using 8-bit colors.']. "reduce to 8-bit color." f _ f asFormOfDepth: 8]]. f depth < 8 ifTrue: [ "writeBitData: expects depth of 8" newF _ f class extent: f extent depth: 8. (f isKindOf: ColorForm) ifTrue: [ newF copyBits: f boundingBox from: f at: 0@0 clippingBox: f boundingBox rule: Form over fillColor: nil map: nil. newF colors: f colors] ifFalse: [f displayOn: newF]. f _ newF]. colorPalette _ f colormapIfNeededForDepth: 32. interlace _ false. transparentIndex _ nil. ((f isKindOf: ColorForm) and: [f colorsUsed includes: Color transparent]) ifTrue: [ transparentIndex _ (f colors indexOf: Color transparent) - 1]. ^ f ! ! !GIFReadWriter methodsFor: 'animated GIF writing' stamp: 'jm 6/21/2003 17:31'! writeAnimatedGIF: forms allFrameDelays: delayInHundredths loopCount: loopCount "Created an animated GIF from the given collection of Forms. The Forms must all be the same dimensions and depth. All frames will have the given frame delay in hundredths of a second. If loopCount is zero, the animation will loop forever." self writeAnimatedGIF: (forms collect: [:f | Array with: f with: delayInHundredths]) loopCount: loopCount. ! ! !GIFReadWriter methodsFor: 'animated GIF writing' stamp: 'jm 6/22/2003 08:45'! writeAnimatedGIF: formsWithDelays loopCount: loopCount "Created an animated GIF from the given collection of (
, ) pairs. The Forms should all be the same dimensions and depth. Delays are in hundredths of a second. If loopCount is nil, the animation will loop forever." | colorLimitedPairs f | colorLimitedPairs _ formsWithDelays collect: [:pair | f _ pair first asFormOfDepth: 8. "for now, use 8-bit Squeak color palette for all forms" Array with: f with: pair second]. f _ colorLimitedPairs first first. width _ f width. height _ f height. bitsPerPixel _ f depth. colorPalette _ f colormapIfNeededForDepth: 32. interlace _ false. transparentIndex _ nil. ((f isKindOf: ColorForm) and: [f colorsUsed includes: Color transparent]) ifTrue: [ transparentIndex _ (f colors indexOf: Color transparent) - 1]. self writeAnimatedGIFHeader: loopCount. colorLimitedPairs do: [:pair | self writeAnimatedGIFFrame: pair first delay: pair last]. self nextPut: Terminator. self close. ! ! !GIFReadWriter methodsFor: 'animated GIF writing' stamp: 'jm 6/22/2003 08:25'! writeAnimatedGIFFrame: aForm delay: delayInHundredths "Write one frame of an animated GIF with the given delay in hundredths (1/100's) of a second." ((aForm width = width) & (aForm height = height) & (aForm depth = bitsPerPixel)) ifFalse: [ ^ self error: 'All images of an animated GIF must be the same size and depth']. "extensions to record the frame delay and transparent color index, if any" self nextPut: Extension; nextPutAll: #(16rF9 4) asByteArray; nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [9]); writeWord: (delayInHundredths isNil ifTrue: [0] ifFalse: [delayInHundredths]); nextPut: (transparentIndex isNil ifTrue: [0] ifFalse: [transparentIndex]); nextPut: 0. self nextPut: ImageSeparator. self writeWord: 0. "Image Left" self writeWord: 0. "Image Top" self writeWord: width. "Image Width" self writeWord: height. "Image Height" self nextPut: (interlace ifTrue: [16r40] ifFalse: [0]). self writeBitData: aForm bits. ! ! !GIFReadWriter methodsFor: 'animated GIF writing' stamp: 'jm 6/22/2003 08:45'! writeAnimatedGIFHeader: loopCount "Write the file header for an animated GIF." | byte | self nextPutAll: 'GIF89a' asByteArray. self writeWord: width. "Screen Width" self writeWord: height. "Screen Height" byte _ 16r80. "has color map" byte _ byte bitOr: ((bitsPerPixel - 1) bitShift: 5). "color resolution" byte _ byte bitOr: bitsPerPixel - 1. "bits per pixel" self nextPut: byte. self nextPut: 0. "background color." self nextPut: 0. "reserved" colorPalette do: [:pixelValue | self nextPut: ((pixelValue bitShift: -16) bitAnd: 255); nextPut: ((pixelValue bitShift: -8) bitAnd: 255); nextPut: (pixelValue bitAnd: 255)]. loopCount ifNotNil: [ "Write a Netscape loop chunk:" self nextPut: Extension. self nextPutAll: #(255 11 78 69 84 83 67 65 80 69 50 46 48 3 1) asByteArray. self writeWord: (loopCount max: 0). self nextPut: 0]. ! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'jm 6/21/2003 13:08'! writeBitData: bits "using modified Lempel-Ziv Welch algorithm." | maxBits maxMaxCode tSize initCodeSize ent tShift fCode pixel index disp nomatch | pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ width * 8 + 31 // 32 * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ WriteStream on: (ByteArray new: 256). maxBits _ 12. maxMaxCode _ 1 bitShift: maxBits. tSize _ 5003. prefixTable _ Array new: tSize. suffixTable _ Array new: tSize. initCodeSize _ bitsPerPixel <= 1 ifTrue: [2] ifFalse: [bitsPerPixel]. self nextPut: initCodeSize. self setParameters: initCodeSize. tShift _ 0. fCode _ tSize. [fCode < 65536] whileTrue: [tShift _ tShift + 1. fCode _ fCode * 2]. tShift _ 8 - tShift. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self writeCodeAndCheckCodeSize: clearCode. ent _ self readPixelFrom: bits. [(pixel _ self readPixelFrom: bits) == nil] whileFalse: [ fCode _ (pixel bitShift: maxBits) + ent. index _ ((pixel bitShift: tShift) bitXor: ent) + 1. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index] ifFalse: [nomatch _ true. (suffixTable at: index) >= 0 ifTrue: [disp _ tSize - index + 1. index = 1 ifTrue: [disp _ 1]. "probe" [(index _ index - disp) < 1 ifTrue: [index _ index + tSize]. (suffixTable at: index) = fCode ifTrue: [ent _ prefixTable at: index. nomatch _ false. "continue whileFalse:"]. nomatch and: [(suffixTable at: index) > 0]] whileTrue: ["probe"]]. "nomatch" nomatch ifTrue: [self writeCodeAndCheckCodeSize: ent. ent _ pixel. freeCode < maxMaxCode ifTrue: [prefixTable at: index put: freeCode. suffixTable at: index put: fCode. freeCode _ freeCode + 1] ifFalse: [self writeCodeAndCheckCodeSize: clearCode. 1 to: tSize do: [:i | suffixTable at: i put: -1]. self setParameters: initCodeSize]]]]. prefixTable _ suffixTable _ nil. self writeCodeAndCheckCodeSize: ent. self writeCodeAndCheckCodeSize: eoiCode. self flushBits. self nextPut: 0. "zero-length packet" ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'jm 10/27/2002 08:38'! hasMagicNumber: aByteArray | oldP | oldP _ stream position. ((stream size - oldP) >= aByteArray size and: [(stream next: aByteArray size) = aByteArray]) ifTrue: [^ true]. stream position: oldP. ^ false ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 09:31'! readBitData "using modified Lempel-Ziv Welch algorithm." | outCodes outCount bitMask initCodeSize code curCode oldCode inCode finChar i bytes f c packedBits hasLocalColor localColorSize maxOutCodes | maxOutCodes _ 4096. self readWord. "skip Image Left" self readWord. "skip Image Top" width _ self readWord. height _ self readWord. "--- Local Color Table Flag 1 Bit Interlace Flag 1 Bit Sort Flag 1 Bit Reserved 2 Bits Size of Local Color Table 3 Bits ----" packedBits _ self next. interlace _ (packedBits bitAnd: 16r40) ~= 0. hasLocalColor _ (packedBits bitAnd: 16r80) ~= 0. localColorSize _ 1 bitShift: ((packedBits bitAnd: 16r7) + 1). hasLocalColor ifTrue: [localColorTable _ self readColorTable: localColorSize]. pass _ 0. xpos _ 0. ypos _ 0. rowByteSize _ ((width + 3) // 4) * 4. remainBitCount _ 0. bufByte _ 0. bufStream _ ReadStream on: ByteArray new. outCodes _ ByteArray new: maxOutCodes + 1. outCount _ 0. bitMask _ (1 bitShift: bitsPerPixel) - 1. prefixTable _ Array new: 4096. suffixTable _ Array new: 4096. initCodeSize _ self next. self setParameters: initCodeSize. bitsPerPixel > 8 ifTrue: [^self error: 'never heard of a GIF that deep']. bytes _ ByteArray new: rowByteSize * height. [(code _ self readCode) = eoiCode] whileFalse: [code = clearCode ifTrue: [self setParameters: initCodeSize. curCode _ oldCode _ code _ self readCode. finChar _ curCode bitAnd: bitMask. "Horrible hack to avoid running off the end of the bitmap. Seems to cure problem reading some gifs!!? tk 6/24/97 20:16" xpos = 0 ifTrue: [ ypos < height ifTrue: [ bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]] ifFalse: [bytes at: (ypos * rowByteSize) + xpos + 1 put: finChar]. self updatePixelPosition] ifFalse: [curCode _ inCode _ code. curCode >= freeCode ifTrue: [curCode _ oldCode. outCodes at: (outCount _ outCount + 1) put: finChar]. [curCode > bitMask] whileTrue: [outCount > maxOutCodes ifTrue: [^self error: 'corrupt GIF file (OutCount)']. outCodes at: (outCount _ outCount + 1) put: (suffixTable at: curCode + 1). curCode _ prefixTable at: curCode + 1]. finChar _ curCode bitAnd: bitMask. outCodes at: (outCount _ outCount + 1) put: finChar. i _ outCount. [i > 0] whileTrue: ["self writePixel: (outCodes at: i) to: bits" bytes at: (ypos * rowByteSize) + xpos + 1 put: (outCodes at: i). self updatePixelPosition. i _ i - 1]. outCount _ 0. prefixTable at: freeCode + 1 put: oldCode. suffixTable at: freeCode + 1 put: finChar. oldCode _ inCode. freeCode _ freeCode + 1. self checkCodeSize]]. prefixTable _ suffixTable _ nil. f _ ColorForm extent: width@height depth: 8. f bits copyFromByteArray: bytes. "Squeak can handle depths 1, 2, 4, and 8" bitsPerPixel > 4 ifTrue: [^ f]. "reduce depth to save space" c _ ColorForm extent: width@height depth: (bitsPerPixel = 3 ifTrue: [4] ifFalse: [bitsPerPixel]). f displayOn: c. ^ c ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'jm 6/21/2003 11:38'! readBody "Read the GIF blocks. Modified to return a form. " | form extype block blocksize packedFields | form _ nil. [stream atEnd] whileFalse: [ block _ self next. block = Terminator ifTrue: [^ form ]. block = ImageSeparator ifTrue: [ form isNil ifTrue: [form _ self readBitData] ifFalse: [self skipBitData]. ] ifFalse: [ block = Extension ifFalse: [^ form "^ self error: 'Unknown block type'"]. "Extension block" extype _ self next. "extension type" extype = 16rF9 ifTrue: [ "graphics control" self next = 4 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. "==== Reserved 3 Bits Disposal Method 3 Bits User Input Flag 1 Bit Transparent Color Flag 1 Bit ===" packedFields _ self next. self next. "delay time 1" self next. "delay time 2" transparentIndex _ self next. (packedFields bitAnd: 1) = 0 ifTrue: [transparentIndex _ nil]. self next = 0 ifFalse: [^ form "^ self error: 'corrupt GIF file'"]. ] ifFalse: [ "Skip blocks" [(blocksize _ self next) > 0] whileTrue: [self next: blocksize]]]]. ! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'RAA 4/25/2001 08:48'! readColorTable: numberOfEntries | array r g b | array _ Array new: numberOfEntries. 1 to: array size do: [ :i | r _ self next. g _ self next. b _ self next. array at: i put: (Color r: r g: g b: b range: 255) ]. ^array! ! !GIFReadWriter methodsFor: 'private-decoding' stamp: 'jm 10/14/2003 14:38'! readHeader | is89 byte hasColorMap | (self hasMagicNumber: 'GIF87a' asByteArray) ifTrue: [is89 _ false] ifFalse: [ (self hasMagicNumber: 'GIF89a' asByteArray) ifTrue: [is89 _ true] ifFalse: [^ self error: 'This does not appear to be a GIF file']]. self readWord. "skip Screen Width" self readWord. "skip Screen Height" byte _ self next. hasColorMap _ (byte bitAnd: 16r80) ~= 0. bitsPerPixel _ (byte bitAnd: 7) + 1. byte _ self next. "skip background color." self next ~= 0 ifTrue: [ is89 ifFalse: [^ self error: 'corrupt GIF file (screen descriptor)']]. hasColorMap ifTrue: [colorPalette _ self readColorTable: (1 bitShift: bitsPerPixel)] ifFalse: [colorPalette _ nil]. "use default; typically only 1-bit, B/W GIFs lack a palette"! ! !GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'! bytesPerEncodedFrame ^ 33 ! ! !GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'! decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex | p | p _ self primDecode: decodeState frames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex. ^ Array with: p x with: p y ! ! !GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:44'! encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex | p | p _ self primEncode: encodeState frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex. ^ Array with: p x with: p y ! ! !GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:32'! reset "Reset my encoding/decoding state to prepare to encode or decode a new sound stream." encodeState _ self primNewState. decodeState _ self primNewState. ! ! !GSMCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:36'! samplesPerFrame ^ 160 ! ! !GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'! primDecode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex self primitiveFailed. ! ! !GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:33'! primEncode: state frames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex self primitiveFailed. ! ! !GSMCodec methodsFor: 'primitives' stamp: 'jm 2/4/1999 11:35'! primNewState self error: 'The SoundCodecPrims plugin is not available'. ! ! !GZipReadStream methodsFor: 'initialize' stamp: 'ar 12/27/1999 15:37'! on: aCollection from: firstIndex to: lastIndex "Check the header of the GZIP stream." | method magic flags length | super on: aCollection from: firstIndex to: lastIndex. magic _ self nextBits: 16. (magic = GZipMagic) ifFalse:[^self error:'Not a GZipped stream']. method _ self nextBits: 8. (method = GZipDeflated) ifFalse:[^self error:'Bad compression method']. flags _ self nextBits: 8. (flags anyMask: GZipEncryptFlag) ifTrue:[^self error:'Cannot decompress encrypted stream']. (flags anyMask: GZipReservedFlags) ifTrue:[^self error:'Cannot decompress stream with unknown flags']. "Ignore stamp, extra flags, OS type" self nextBits: 16; nextBits: 16. "stamp" self nextBits: 8. "extra flags" self nextBits: 8. "OS type" (flags anyMask: GZipContinueFlag) "Number of multi-part archive - ignored" ifTrue:[self nextBits: 16]. (flags anyMask: GZipExtraField) "Extra fields - ignored" ifTrue:[ length _ self nextBits: 16. 1 to: length do:[:i| self nextBits: 8]]. (flags anyMask: GZipNameFlag) "Original file name - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. (flags anyMask: GZipCommentFlag) "Comment - ignored" ifTrue:[[(self nextBits: 8) = 0] whileFalse]. ! ! !GZipReadStream class methodsFor: 'class initialization' stamp: 'ar 12/27/1999 15:37'! initialize "GZipReadStream initialize" #( (GZipMagic 16r8B1F) "GZIP magic number" (GZipDeflated 8) "Compression method" (GZipAsciiFlag 16r01) "Contents is ASCII" (GZipContinueFlag 16r02) "Part of a multi-part archive" (GZipExtraField 16r04) "Archive has extra fields" (GZipNameFlag 16r08) "Archive has original file name" (GZipCommentFlag 16r10) "Archive has comment" (GZipEncryptFlag 16r20) "Archive is encrypted" (GZipReservedFlags 16rC0)"Reserved" ) do:[:spec| GZipConstants declare: spec first from: Undeclared. GZipConstants at: spec first put: spec last. ].! ! !GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 20:07'! on: aCollection crc _ 16rFFFFFFFF. crcPosition _ 1. bytesWritten _ 0. super on: aCollection. self writeHeader. ! ! !GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 16:36'! release "Write crc and the number of bytes encoded" super release. self updateCrc. crc _ crc bitXor: 16rFFFFFFFF. encoder flushBits. 0 to: 3 do:[:i| encoder nextBytePut: (crc >> (i*8) bitAnd: 255)]. 0 to: 3 do:[:i| encoder nextBytePut: (bytesWritten >> (i*8) bitAnd: 255)].! ! !GZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 11:41'! writeHeader "Write the GZip header" encoder nextBits: 16 put: GZipMagic. encoder nextBits: 8 put: GZipDeflated. encoder nextBits: 8 put: 0. "No flags" encoder nextBits: 32 put: 0. "no time stamp" encoder nextBits: 8 put: 0. "No extra flags" encoder nextBits: 8 put: 0. "No OS type" ! ! !GZipWriteStream methodsFor: 'private' stamp: 'ar 12/27/1999 17:12'! moveContentsToFront "Need to update crc here" self updateCrc. super moveContentsToFront. crcPosition _ position + 1.! ! !GZipWriteStream methodsFor: 'private' stamp: 'ar 12/29/1999 20:09'! updateCrc crcPosition <= position ifTrue:[ bytesWritten _ bytesWritten + position - crcPosition + 1. crc _ self updateCrc: crc from: crcPosition to: position in: collection. crcPosition _ position + 1].! ! !GZipWriteStream methodsFor: 'private' stamp: 'ar 12/27/1999 21:17'! updateCrc: oldCrc from: start to: stop in: aCollection | newCrc | newCrc _ oldCrc. start to: stop do:[:i| newCrc _ (CrcTable at: ((newCrc bitXor: (aCollection byteAt: i)) bitAnd: 255) + 1) bitXor: (newCrc bitShift: -8). ]. ^newCrc! ! !GZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 14:35'! crcTable ^CrcTable! ! !GZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/27/1999 16:55'! initialize "GZipWriteStream initialize" CrcTable _ #(16r00000000 16r77073096 16rEE0E612C 16r990951BA 16r076DC419 16r706AF48F 16rE963A535 16r9E6495A3 16r0EDB8832 16r79DCB8A4 16rE0D5E91E 16r97D2D988 16r09B64C2B 16r7EB17CBD 16rE7B82D07 16r90BF1D91 16r1DB71064 16r6AB020F2 16rF3B97148 16r84BE41DE 16r1ADAD47D 16r6DDDE4EB 16rF4D4B551 16r83D385C7 16r136C9856 16r646BA8C0 16rFD62F97A 16r8A65C9EC 16r14015C4F 16r63066CD9 16rFA0F3D63 16r8D080DF5 16r3B6E20C8 16r4C69105E 16rD56041E4 16rA2677172 16r3C03E4D1 16r4B04D447 16rD20D85FD 16rA50AB56B 16r35B5A8FA 16r42B2986C 16rDBBBC9D6 16rACBCF940 16r32D86CE3 16r45DF5C75 16rDCD60DCF 16rABD13D59 16r26D930AC 16r51DE003A 16rC8D75180 16rBFD06116 16r21B4F4B5 16r56B3C423 16rCFBA9599 16rB8BDA50F 16r2802B89E 16r5F058808 16rC60CD9B2 16rB10BE924 16r2F6F7C87 16r58684C11 16rC1611DAB 16rB6662D3D 16r76DC4190 16r01DB7106 16r98D220BC 16rEFD5102A 16r71B18589 16r06B6B51F 16r9FBFE4A5 16rE8B8D433 16r7807C9A2 16r0F00F934 16r9609A88E 16rE10E9818 16r7F6A0DBB 16r086D3D2D 16r91646C97 16rE6635C01 16r6B6B51F4 16r1C6C6162 16r856530D8 16rF262004E 16r6C0695ED 16r1B01A57B 16r8208F4C1 16rF50FC457 16r65B0D9C6 16r12B7E950 16r8BBEB8EA 16rFCB9887C 16r62DD1DDF 16r15DA2D49 16r8CD37CF3 16rFBD44C65 16r4DB26158 16r3AB551CE 16rA3BC0074 16rD4BB30E2 16r4ADFA541 16r3DD895D7 16rA4D1C46D 16rD3D6F4FB 16r4369E96A 16r346ED9FC 16rAD678846 16rDA60B8D0 16r44042D73 16r33031DE5 16rAA0A4C5F 16rDD0D7CC9 16r5005713C 16r270241AA 16rBE0B1010 16rC90C2086 16r5768B525 16r206F85B3 16rB966D409 16rCE61E49F 16r5EDEF90E 16r29D9C998 16rB0D09822 16rC7D7A8B4 16r59B33D17 16r2EB40D81 16rB7BD5C3B 16rC0BA6CAD 16rEDB88320 16r9ABFB3B6 16r03B6E20C 16r74B1D29A 16rEAD54739 16r9DD277AF 16r04DB2615 16r73DC1683 16rE3630B12 16r94643B84 16r0D6D6A3E 16r7A6A5AA8 16rE40ECF0B 16r9309FF9D 16r0A00AE27 16r7D079EB1 16rF00F9344 16r8708A3D2 16r1E01F268 16r6906C2FE 16rF762575D 16r806567CB 16r196C3671 16r6E6B06E7 16rFED41B76 16r89D32BE0 16r10DA7A5A 16r67DD4ACC 16rF9B9DF6F 16r8EBEEFF9 16r17B7BE43 16r60B08ED5 16rD6D6A3E8 16rA1D1937E 16r38D8C2C4 16r4FDFF252 16rD1BB67F1 16rA6BC5767 16r3FB506DD 16r48B2364B 16rD80D2BDA 16rAF0A1B4C 16r36034AF6 16r41047A60 16rDF60EFC3 16rA867DF55 16r316E8EEF 16r4669BE79 16rCB61B38C 16rBC66831A 16r256FD2A0 16r5268E236 16rCC0C7795 16rBB0B4703 16r220216B9 16r5505262F 16rC5BA3BBE 16rB2BD0B28 16r2BB45A92 16r5CB36A04 16rC2D7FFA7 16rB5D0CF31 16r2CD99E8B 16r5BDEAE1D 16r9B64C2B0 16rEC63F226 16r756AA39C 16r026D930A 16r9C0906A9 16rEB0E363F 16r72076785 16r05005713 16r95BF4A82 16rE2B87A14 16r7BB12BAE 16r0CB61B38 16r92D28E9B 16rE5D5BE0D 16r7CDCEFB7 16r0BDBDF21 16r86D3D2D4 16rF1D4E242 16r68DDB3F8 16r1FDA836E 16r81BE16CD 16rF6B9265B 16r6FB077E1 16r18B74777 16r88085AE6 16rFF0F6A70 16r66063BCA 16r11010B5C 16r8F659EFF 16rF862AE69 16r616BFFD3 16r166CCF45 16rA00AE278 16rD70DD2EE 16r4E048354 16r3903B3C2 16rA7672661 16rD06016F7 16r4969474D 16r3E6E77DB 16rAED16A4A 16rD9D65ADC 16r40DF0B66 16r37D83BF0 16rA9BCAE53 16rDEBB9EC5 16r47B2CF7F 16r30B5FFE9 16rBDBDF21C 16rCABAC28A 16r53B39330 16r24B4A3A6 16rBAD03605 16rCDD70693 16r54DE5729 16r23D967BF 16rB3667A2E 16rC4614AB8 16r5D681B02 16r2A6F2B94 16rB40BBE37 16rC30C8EA1 16r5A05DF1B 16r2D02EF8D ).! ! I am a subclass of BitBlt used by FormCanvas. ! !GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:07'! alphaBits: a alpha _ a! ! !GrafPort methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'! displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ^ (DisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self clone ! ! !GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'! fillPattern: anObject fillPattern _ anObject. self fillColor: anObject.! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:32'! fillOval: rect | centerX centerY nextY yBias xBias outer nextOuterX | rect area <= 0 ifTrue: [^ self]. height _ 1. yBias _ rect height odd ifTrue: [0] ifFalse: [-1]. xBias _ rect width odd ifTrue: [1] ifFalse: [0]. centerX _ rect center x. centerY _ rect center y. outer _ EllipseMidpointTracer new on: rect. nextY _ rect height // 2. [nextY > 0] whileTrue:[ nextOuterX _ outer stepInY. width _ (nextOuterX bitShift: 1) + xBias. destX _ centerX - nextOuterX. destY _ centerY - nextY. self copyBits. destY _ centerY + nextY + yBias. self copyBits. nextY _ nextY - 1. ]. destY _ centerY. height _ 1 + yBias. width _ rect width. destX _ rect left. self copyBits. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'jm 5/12/2003 19:59'! fillRect: rect offset: aPoint "The offset is really just for stupid InfiniteForms." | fc | fillPattern class == InfiniteForm ifTrue:[ fc _ halftoneForm. self fillColor: nil. fillPattern displayUsingBitBlt: ((self clippedBy: rect) colorMap: nil) at: aPoint. halftoneForm _ fc. ^ self]. destX _ rect left. destY _ rect top. sourceX _ 0. sourceY _ 0. width _ rect width. height _ rect height. self copyBits.! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/16/2000 22:26'! frameOval: rect borderWidth: borderWidth | centerX centerY nextY yBias xBias wp outer inner nextOuterX nextInnerX fillAlpha | rect area <= 0 ifTrue: [^ self]. height _ 1. wp _ borderWidth asPoint. yBias _ rect height odd ifTrue: [0] ifFalse: [-1]. xBias _ rect width odd ifTrue: [1] ifFalse: [0]. centerX _ rect center x. centerY _ rect center y. outer _ EllipseMidpointTracer new on: rect. inner _ EllipseMidpointTracer new on: (rect insetBy: wp). nextY _ rect height // 2. 1 to: (wp y min: nextY) do:[:i| nextOuterX _ outer stepInY. width _ (nextOuterX bitShift: 1) + xBias. destX _ centerX - nextOuterX. destY _ centerY - nextY. self copyBits. destY _ centerY + nextY + yBias. self copyBits. nextY _ nextY - 1. ]. [nextY > 0] whileTrue:[ nextOuterX _ outer stepInY. nextInnerX _ inner stepInY. destX _ centerX - nextOuterX. destY _ centerY - nextY. width _ nextOuterX - nextInnerX. self copyBits. destX _ centerX + nextInnerX + xBias. self copyBits. destX _ centerX - nextOuterX. destY _ centerY + nextY + yBias. self copyBits. destX _ centerX + nextInnerX + xBias. self copyBits. nextY _ nextY - 1. ]. destY _ centerY. height _ 1 + yBias. width _ wp x. destX _ rect left. self copyBits. destX _ rect right - wp x. self copyBits. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 14:44'! frameRect: rect borderWidth: borderWidth sourceX _ 0. sourceY _ 0. (rect areasOutside: (rect insetBy: borderWidth)) do: [:edgeStrip | self destRect: edgeStrip; copyBits]. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! frameRectBottom: rect height: h destX _ rect left + 1. destY _ rect bottom - 1. width _ rect width - 2. height _ 1. 1 to: h do: [:i | self copyBits. destX _ destX + 1. destY _ destY - 1. width _ width - 2]. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! frameRectRight: rect width: w width _ 1. height _ rect height - 1. destX _ rect right - 1. destY _ rect top + 1. 1 to: w do: [:i | self copyBits. destX _ destX - 1. destY _ destY + 1. height _ height - 2]. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 01:08'! image: aForm at: aPoint sourceRect: sourceRect rule: rule "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." sourceForm _ aForm. combinationRule _ rule. self sourceRect: sourceRect. self destOrigin: aPoint. self copyBits! ! !GrafPort methodsFor: 'drawing support' stamp: 'jm 3/18/2003 11:17'! image: aForm at: aPoint sourceRect: sourceRect rule: rule alpha: a "Draw the portion of the given Form defined by sourceRect at the given point using the given BitBlt combination rule." sourceForm _ aForm. combinationRule _ rule. self sourceRect: sourceRect. self destOrigin: aPoint. self copyBitsTranslucent: a. ! ! !GrafPort methodsFor: 'drawing support' stamp: 'ar 2/17/2000 00:31'! stencil: stencilForm at: aPoint sourceRect: aRect "Paint using aColor wherever stencilForm has non-zero pixels" self sourceForm: stencilForm; destOrigin: aPoint; sourceRect: aRect. self copyBits! ! !GrafPort methodsFor: 'copying' stamp: 'ar 2/17/2000 01:07'! clippedBy: aRectangle ^ self copy clipRect: (self clipRect intersect: aRectangle)! ! !GrafPort methodsFor: 'copying' stamp: 'ar 2/17/2000 01:07'! copyBits "Override copybits to do translucency if desired" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: [alpha == nil ifTrue: [self copyBitsTranslucent: 255] ifFalse: [self copyBitsTranslucent: alpha]] ifFalse: [super copyBits]! ! I display a graph of numbers, normalized so the full range of values just fits my height. I support a movable cursor that can be dragged with the mouse. Implementation notes: Some operations on me may be done at sound sampling rates (e.g. 11-44 thousand times/second). To allow such high bandwidth application, certain operations that change my appearance do not immediately report a damage rectangle. Instead, a flag is set indicating that my display needs to refreshed and a step method reports the damage rectangle if that flag is set. Also, I cache a bitmap of my graph to allow the cursor to be moved without redrawing the graph. ! !GraphMorph methodsFor: 'initialization' stamp: 'jm 6/17/1999 20:09'! initialize super initialize. self color: (Color r: 0.8 g: 0.8 b: 0.6). self extent: 365@80. self borderWidth: 2. dataColor _ Color darkGray. cursor _ 1.0. "may be fractional" cursorColor _ Color red. cursorColorAtZeroCrossings _ Color red. startIndex _ 1. hasChanged _ false. self data: ((0 to: 360 - 1) collect: [:x | (100.0 * (x degreesToRadians sin)) asInteger]). ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 6/17/1999 21:41'! cursor: aNumber | truncP | cursor ~= aNumber ifTrue: [ cursor _ aNumber. truncP _ aNumber truncated. truncP > data size ifTrue: [cursor _ data size]. truncP < 0 ifTrue: [cursor _ 1]. self keepIndexInView: truncP. hasChanged _ true]. ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'! cursorColorAtZeroCrossing ^ cursorColorAtZeroCrossings ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:32'! cursorColorAtZeroCrossings: aColor cursorColorAtZeroCrossings _ aColor. self flushCachedForm. ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 6/17/1999 21:43'! cursorWrapped: aNumber | sz | cursor ~= aNumber ifTrue: [ cursor _ aNumber. sz _ data size. sz = 0 ifTrue: [cursor _ 1] ifFalse: [ ((cursor >= (sz + 1)) or: [cursor < 0]) ifTrue: [ cursor _ cursor - ((cursor // sz) * sz)]. cursor < 1 ifTrue: [cursor _ sz + cursor]]. "assert: 1 <= cursor < data size + 1" hasChanged _ true]. ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 6/16/1999 13:49'! interpolatedValueAtCursor | sz prev frac next | data isEmpty ifTrue: [^ 0]. sz _ data size. cursor < 0 ifTrue: [^ data at: 1]. "just to be safe, though cursor shouldn't be negative" prev _ cursor truncated. frac _ cursor - prev. prev < 1 ifTrue: [prev _ sz]. prev > sz ifTrue: [prev _ 1]. "assert: 1 <= prev <= sz" frac = 0 ifTrue: [^ data at: prev]. "no interpolation needed" "interpolate" next _ prev = sz ifTrue: [1] ifFalse: [prev + 1]. ^ ((1.0 - frac) * (data at: prev)) + (frac * (data at: next)) ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 4/21/1999 11:24'! lastValue data size = 0 ifTrue: [^ 0]. ^ data last ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 4/21/1999 11:25'! lastValue: aNumber self appendValue: aNumber. ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 12/24/2002 09:24'! selection ^ selection ! ! !GraphMorph methodsFor: 'accessing' stamp: 'jm 12/24/2002 09:25'! selection: anArrayOrNil "Set the selection to the given (startIndex, stopIndex) pair to to nil." selection _ anArrayOrNil. ! ! !GraphMorph methodsFor: 'drawing' stamp: 'jm 11/24/2002 12:45'! drawOn: aCanvas | c | cachedForm = nil ifTrue: [ c _ FormCanvas extent: bounds extent. c translateBy: bounds origin negated during:[:tempCanvas| self drawDataOn: tempCanvas]. cachedForm _ c form]. aCanvas paintImage: cachedForm at: bounds origin. self drawCursorOn: aCanvas. ! ! !GraphMorph methodsFor: 'events' stamp: 'jm 12/26/2002 10:32'! handlesMouseDown: evt ^ true ! ! !GraphMorph methodsFor: 'events' stamp: 'LY 7/3/2003 10:54'! mouseDown: evt "Handles mouse down and drag events. Updates the cursor position and sets the selection to an array containing two copies of the current cursor value." | x | (selection notNil and: [(selection at: 2) - (selection at: 1) > 3]) ifTrue: [ selection _ nil. self flushCachedForm. self changed.]. x _ evt cursorPoint x - (bounds left + borderWidth). cursor _ ((startIndex + x) max: 1) min: data size. selection _ Array with: cursor with: cursor. ! ! !GraphMorph methodsFor: 'events' stamp: 'LY 7/3/2003 11:02'! mouseMove: evt "Updates the cursor position as the mouse moves. Adjusts the selection only if the mouse is currently being pressed" | x w | x _ evt cursorPoint x - (bounds left + borderWidth). w _ self width - (2 * borderWidth). self changed. x < 0 ifTrue: [ cursor _ startIndex + (3 * x). cursor _ (cursor max: 1) min: data size. self adjustSelection. ^ self startIndex: cursor]. x > w ifTrue: [ cursor _ startIndex + w + (3 * (x - w)). cursor _ (cursor max: 1) min: data size. self adjustSelection. ^ self startIndex: cursor - w]. cursor _ ((startIndex + x) max: 1) min: data size. evt anyButtonPressed ifTrue: [self adjustSelection.] ! ! !GraphMorph methodsFor: 'events' stamp: 'LY 7/2/2003 11:59'! mouseUp: evt (selection notNil and: [(selection at: 2) - (selection at: 1) <=3]) ifTrue: [selection _ nil.]. ! ! !GraphMorph methodsFor: 'stepping' stamp: 'jm 6/17/1999 21:32'! step "Make a deferred damage rectangle if I've changed. This allows applications to call methods that invalidate my display at high-bandwidth without paying the cost of doing the damage reporting on ever call; they can merely set hasChanged to true." super step. hasChanged == nil ifTrue: [hasChanged _ false]. hasChanged ifTrue: [ self changed. hasChanged _ false]. ! ! !GraphMorph methodsFor: 'menu' stamp: 'jm 6/16/1999 13:08'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'open wave editor' action: #openWaveEditor. aCustomMenu add: 'read file' action: #readDataFromFile. ! ! !GraphMorph methodsFor: 'menu' stamp: 'jm 6/15/2003 20:03'! openWaveEditor | scaleFactor scaledData editor | self data: data. "make sure maxVal and minVal are current" scaleFactor _ 32767 // ((minVal abs max: maxVal abs) max: 1). scaledData _ SoundBuffer newMonoSampleCount: data size. 1 to: data size do: [:i | scaledData at: i put: (scaleFactor * (data at: i)) truncated]. editor _ SimpleWaveEditor new data: scaledData; samplingRate: 11025; perceivedFrequency: 220.0. editor openInWorld. ! ! !GraphMorph methodsFor: 'menu' stamp: 'jm 6/16/1999 11:24'! readDataFromFile | fileName | fileName _ FillInTheBlank request: 'File name?' initialAnswer: ''. fileName isEmpty ifTrue: [^ self]. (StandardFileStream isAFileNamed: fileName) ifFalse: [ ^ self inform: 'Sorry, I cannot find that file']. self data: (SampledSound fromAIFFfileNamed: fileName) samples. ! ! !GraphMorph methodsFor: 'commands' stamp: 'jm 7/30/1998 12:17'! centerCursor "Scroll so that the cursor is as close as possible to the center of my window." | w | w _ self width - (2 * borderWidth). self startIndex: ((cursor - (w // 2)) max: 1). ! ! !GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:49'! loadSineWave self loadSoundData: FMSound sineTable. ! ! !GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:17'! loadSound: aSound self loadSoundData: aSound samples. ! ! !GraphMorph methodsFor: 'commands' stamp: 'jm 4/22/1999 14:23'! loadSoundData: aCollection | scale absV newData | scale _ 0. aCollection do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]]. scale _ 100.0 / scale. newData _ OrderedCollection new: aCollection size. 1 to: aCollection size do: [:i | newData addLast: (scale * (aCollection at: i))]. self data: newData. self startIndex: 1. self cursor: 1. ! ! !GraphMorph methodsFor: 'commands' stamp: 'jm 6/16/1999 11:29'! playOnce | scale absV scaledData | data isEmpty ifTrue: [^ self]. "nothing to play" scale _ 1. data do: [:v | (absV _ v abs) > scale ifTrue: [scale _ absV]]. scale _ 32767.0 / scale. scaledData _ SoundBuffer newMonoSampleCount: data size. 1 to: data size do: [:i | scaledData at: i put: (scale * (data at: i)) truncated]. (SampledSound samples: scaledData samplingRate: 11025) play. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 12/26/2002 14:33'! adjustSelection "Adjust the selection, if any, to the current cursor position. Do nothing if there is no selection." selection ifNil: [^ self]. cursor < selection first ifTrue: [ selection at: 1 put: cursor. selection at: 2 put: ((selection at: 2) max: cursor)] ifFalse: [ selection at: 1 put: ((selection at: 1) min: cursor). selection at: 2 put: cursor]. self flushCachedForm; changed. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 21:36'! drawCursorOn: aCanvas | ptr x r c | ptr _ (cursor asInteger max: 1) min: data size. c _ cursorColor. ((ptr > 1) and: [ptr < data size]) ifTrue: [ (data at: ptr) sign ~= (data at: ptr + 1) sign ifTrue: [c _ cursorColorAtZeroCrossings]]. r _ self innerBounds. x _ r left + ptr - startIndex. ((x >= r left) and: [x <= r right]) ifTrue: [ aCanvas fillRectangle: (x@r top corner: x + 1@r bottom) color: c]. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 12/24/2002 09:33'! drawDataOn: aCanvas | yScale baseLine x start end value left top bottom right | super drawOn: aCanvas. self drawSelectionOn: aCanvas. data isEmpty ifTrue: [^ self]. maxVal = minVal ifTrue: [ yScale _ 1. ] ifFalse: [ yScale _ (bounds height - (2 * borderWidth)) asFloat / (maxVal - minVal)]. baseLine _ bounds bottom - borderWidth + (minVal * yScale) truncated. left _ top _ 0. right _ 10. bottom _ 0. x _ bounds left + borderWidth. start _ (startIndex asInteger max: 1) min: data size. end _ (start + bounds width) min: data size. start to: end do: [:i | left _ x truncated. right _ x + 1. right > (bounds right - borderWidth) ifTrue: [^ self]. value _ (data at: i) asFloat. value >= 0.0 ifTrue: [ top _ baseLine - (yScale * value) truncated. bottom _ baseLine. ] ifFalse: [ top _ baseLine. bottom _ baseLine - (yScale * value) truncated]. aCanvas fillRectangle: (left@top corner: right@bottom) color: dataColor. x _ x + 1]. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 12/24/2002 09:44'! drawSelectionOn: aCanvas | startVisible endVisible x y | selection ifNil: [^ self]. startVisible _ (startIndex asInteger max: 1) min: data size. endVisible _ (startVisible + bounds width) min: data size. selection first > endVisible ifTrue: [^ self]. "selection is not visible" selection last < startVisible ifTrue: [^ self]. "selection is not visible" x _ (bounds left + borderWidth + (selection first - startVisible)). y _ bounds top + borderWidth. aCanvas fillRectangle: (x@y extent: (selection last - selection first)@(self height - (2 * borderWidth))) color: Color lightYellow. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 6/17/1999 20:10'! flushCachedForm cachedForm _ nil. hasChanged _ true. ! ! !GraphMorph methodsFor: 'private' stamp: 'jm 4/21/1999 11:30'! keepIndexInView: index | w newStart | w _ bounds width - (2 * borderWidth). index < startIndex ifTrue: [ newStart _ index - w + 1. ^ self startIndex: (newStart max: 1)]. index > (startIndex + w) ifTrue: [ ^ self startIndex: (index min: data size)]. ! ! !GraphMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:00'! includeInNewMorphMenu ^ true ! ! !GraphMorph class methodsFor: 'instance creation' stamp: 'jm 1/23/2003 16:21'! openOn: dataCollection "Open a new GraphMorph on the given sequencable collection of data." ^ (self new data: dataCollection) openInWorld ! ! HTTPSockets support HTTP requests, either directly or via an HTTP proxy server. An HTTPSocket saves the parse of the last ASCII header it saw, to avoid having to parse it repeatedly. The real action is in httpGet:accept:. See the examples in the class, especially httpFileInNewChangeSet: and httpShowGif:.! ]style[(206 15 45 23 5 13)f1,f1LHTTPSocket class httpGet:accept:;,f1,f1LHTTPSocket class httpFileInNewChangeSet:;,f1,f1LHTTPSocket class httpShowGif:;! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/14/1998 10:17'! contentType | type i | type _ self getHeader: 'content-type' default: nil. type ifNil: [ ^nil ]. type _ type withBlanksTrimmed. i _ type indexOf: $;. i = 0 ifTrue: [ ^type ]. ^(type copyFrom: 1 to: i-1) withBlanksTrimmed ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:23'! contentType: header "extract the content type from the header. Content-type: text/plain, User may look in headerTokens afterwards." | this | headerTokens ifNil: [ headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR) ]. 1 to: headerTokens size do: [:ii | this _ headerTokens at: ii. (this first asLowercase = $c and: [#('content-type:' 'content type') includes: this asLowercase]) ifTrue: [ ^ (headerTokens at: ii+1)]]. ^ nil "not found"! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/15/97 11:35'! contentsLength: header "extract the data length from the header. Content-length: 1234, User may look in headerTokens afterwards." | this | headerTokens _ header findTokens: ParamDelimiters keep: (String with: CR). 1 to: headerTokens size do: [:ii | this _ headerTokens at: ii. (this first asLowercase = $c and: [this asLowercase = 'content-length:']) ifTrue: [ ^ (headerTokens at: ii+1) asNumber]]. ^ nil "not found"! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:37'! getHeader: name ^self getHeader: name default: nil! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:36'! getHeader: name default: defaultValue ^headers at: name ifAbsent: [ defaultValue ]! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 11:39'! getResponseUpTo: markerString "Keep reading until the marker is seen. Return three parts: header, marker, beginningOfData. Fails if no marker in first 2000 chars." | buf response bytesRead tester mm | buf _ String new: 2000. response _ WriteStream on: buf. tester _ 1. mm _ 1. [tester _ tester - markerString size + 1 max: 1. "rewind a little, in case the marker crosses a read boundary" tester to: response position do: [:tt | (buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1]. "Not totally correct for markers like xx0xx" mm > markerString size ifTrue: ["got it" ^ Array with: (buf copyFrom: 1 to: tt+1-mm) with: markerString with: (buf copyFrom: tt+1 to: response position)]]. tester _ 1 max: response position. "OK if mm in the middle" (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: response position + 1 count: buf size - response position. "response position+1 to: response position+bytesRead do: [:ii | response nextPut: (buf at: ii)]. totally redundant, but needed to advance position!!" response instVarAt: 2 "position" put: (response position + bytesRead)]. "horrible, but fast" ^ Array with: response contents with: '' with: '' "Marker not found and connection closed" ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tao 6/22/1999 07:56'! getResponseUpTo: markerString ignoring: ignoreString "Keep reading, until the marker is seen, skipping characters in ignoreString when comparing to the marker. Return three parts: header, marker, beginningOfData. Fails if no marker in first 2000 chars." | buf response bytesRead tester mm skipped | buf _ String new: 2000. response _ WriteStream on: buf. tester _ 1. mm _ 1. skipped _ 0. [tester _ tester - markerString size + 1 max: 1. "rewind a little, in case the marker crosses a read boundary" tester to: response position do: [:tt | (buf at: tt) = (markerString at: mm) ifFalse: [[ignoreString includes: (markerString at: mm)] whileTrue: [mm _ mm + 1. skipped _ skipped + 1]]. (buf at: tt) = (markerString at: mm) ifTrue: [mm _ mm + 1] ifFalse: [mm _ 1. skipped _ 0]. "Not totally correct for markers like xx0xx" mm > markerString size ifTrue: ["got it" ^ Array with: (buf copyFrom: 1 to: tt+1-mm+skipped) with: markerString with: (buf copyFrom: tt+1 to: response position)]]. tester _ 1 max: response position. "OK if mm in the middle" (response position < buf size) & (self isConnected | self dataAvailable)] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: 'data was late'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: response position + 1 count: buf size - response position. "response position+1 to: response position+bytesRead do: [:ii | response nextPut: (buf at: ii)]. totally redundant, but needed to advance position!!" response instVarAt: 2 "position" put: (response position + bytesRead)]. "horrible, but fast" ^ Array with: response contents with: '' with: '' "Marker not found and connection closed" ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'tk 9/22/1998 12:24'! getRestOfBuffer: beginning "We don't know the length. Keep going until connection is closed. Part of it has already been received. Response is of type text, not binary." | buf response bytesRead | response _ RWBinaryOrTextStream on: (String new: 2000). response nextPutAll: beginning. buf _ String new: 2000. [self isConnected | self dataAvailable] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifTrue: [ Transcript show: 'data was slow'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. bytesRead > 0 ifTrue: [ response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ]. Transcript cr; show: 'data byte count: ', response position printString. response reset. "position: 0." ^ response ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'sma 4/22/2000 17:34'! getRestOfBuffer: beginning totalLength: length "Reel in a string of a fixed length. Part of it has already been received. Close the connection after all chars are received. We do not strip out linefeed chars. tk 6/16/97 22:32" "if length is nil, read until connection close. Response is of type text, not binary." | buf response bytesRead | length ifNil: [^ self getRestOfBuffer: beginning]. buf _ String new: length. response _ RWBinaryOrTextStream on: buf. response nextPutAll: beginning. buf _ String new: length. [(response position < length) & (self isConnected | self dataAvailable)] whileTrue: [ (self waitForDataUntil: (Socket deadlineSecs: 5)) ifFalse: [ Transcript show: 'data was slow'; cr]. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: (length - response position). bytesRead > 0 ifTrue: [ response nextPutAll: (buf copyFrom: 1 to: bytesRead)] ]. "Transcript cr; show: 'data byte count: ', response position printString." "Transcript cr; show: ((self isConnected) ifTrue: ['Over length by: ', bytesRead printString] ifFalse: ['Socket closed'])." response position < length ifTrue: [^ 'server aborted early']. response reset. "position: 0." ^ response! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/13/1998 00:33'! header: headerText "set the headers. Then getHeader: can be used" "divide into basic lines" | lines foldedLines i statusLine | lines _ headerText findTokens: (String with: Character cr with: Character linefeed). statusLine _ lines first. lines _ lines copyFrom: 2 to: lines size. "parse the status (pretty trivial right now)" responseCode _ (statusLine findTokens: ' ') second. "fold lines that start with spaces into the previous line" foldedLines _ OrderedCollection new. lines do: [ :line | line first isSeparator ifTrue: [ foldedLines at: foldedLines size put: (foldedLines last, line) ] ifFalse: [ foldedLines add: line ] ]. "make a dictionary mapping headers to header contents" headers _ Dictionary new. foldedLines do: [ :line | i _ line indexOf: $:. i > 0 ifTrue: [ headers at: (line copyFrom: 1 to: i-1) asLowercase put: (line copyFrom: i+1 to: line size) withBlanksTrimmed ] ].. ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/26/97 18:28'! redirect "See if the header has a 'Location: url CrLf' in it. If so, return the new URL of this page. tk 6/24/97 18:03" | this | 1 to: headerTokens size do: [:ii | this _ headerTokens at: ii. (this first asLowercase = $l and: [this asLowercase = 'location:']) ifTrue: [ ^ (headerTokens at: ii+1)]]. ^ nil "not found" ! ! !HTTPSocket methodsFor: 'as yet unclassified' stamp: 'ls 8/12/1998 00:41'! responseCode ^responseCode! ! !HTTPSocket class methodsFor: 'class initialization' stamp: 'tk 9/21/1998 10:45'! blabEmail: aRequest "Of the form 'From: me@isp.com '" HTTPBlabEmail _ aRequest! ! !HTTPSocket class methodsFor: 'class initialization' stamp: 'msk 9/28/1998 15:51'! initialize "HTTPSocket initialize" ParamDelimiters _ ' ', CrLf. HTTPPort _ 80. HTTPProxyServer _ nil. HTTPBlabEmail _ ''. " 'From: tedk@disney.com', CrLf " ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'di 5/6/1998 16:40'! httpFileInNewChangeSet: url "Do a regular file-in of a file that is served from a web site. Put it into a new changeSet." "Notes: To store a file on an HTTP server, use the program 'Fetch'. After indicating what file to store, choose 'Raw Data' from the popup menu that has MacBinary/Text/etc. Use any file extension as long as it is not one of the common ones." " HTTPSocket httpFileInNewChangeSet: '206.18.68.12/squeak/updates/83tk_test.cs' " | doc | doc _ self httpGet: url accept: 'application/octet-stream'. doc class == String ifTrue: [ PopUpMenu notify: 'Cannot seem to contact the web site']. doc reset. ChangeSorter newChangesFromStream: doc named: (url findTokens: '/') last.! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'jm 11/4/97 08:25'! httpGet: url "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " " HTTPSocket httpShowPage: 'www.apple.com/default.html' " " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " ^ self httpGet: url accept: 'application/octet-stream' ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'ls 9/15/1998 23:57'! httpGet: url accept: mimeType "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'." ^self httpGet: url args: nil accept: mimeType! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'jm 9/16/1998 10:31'! httpGet: url args: args accept: mimeType "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'." | document | document _ self httpGetDocument: url args: args accept: mimeType. (document isKindOf: String) ifTrue: [ "strings indicate errors" ^ document ]. ^ (RWBinaryOrTextStream with: document content) reset ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:25'! httpGetDocument: url "Return the exact contents of a web page or other web object. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:21" " HTTPSocket httpShowPage: 'http://www.altavista.digital.com/index.html' " " HTTPSocket httpShowPage: 'www.webPage.com/~kaehler2/ab.html' " " HTTPSocket httpShowPage: 'www.exploratorium.edu/index.html' " " HTTPSocket httpShowPage: 'www.apple.com/default.html' " " HTTPSocket httpShowPage: 'www.altavista.digital.com/' " " HTTPSocket httpShowPage: 'jumbo/tedk/ab.html' " ^ self httpGetDocument: url args: nil accept: 'application/octet-stream' request: '' ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'! httpGetDocument: url accept: mimeType "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" ^self httpGetDocument: url args: nil accept: mimeType request: ''! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:26'! httpGetDocument: url args: args "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIMI type 'application/octet-stream'." ^self httpGetDocument: url args: args accept: 'application/octet-stream' request: ''! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 17:48'! httpGetDocument: url args: args accept: mimeType "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered. Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." ^ self httpGetDocument: url args: args accept: mimeType request: ''! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 3/24/2000 11:20'! httpGetDocument: url args: args accept: mimeType request: requestString "Return the exact contents of a web object. Asks for the given MIME type. If mimeType is nil, use 'text/html'. An extra requestString may be submitted and must end with crlf. The parsed header is saved. Use a proxy server if one has been registered. tk 7/23/97 17:12" "Note: To fetch raw data, you can use the MIME type 'application/octet-stream'." | serverName serverAddr port sock header length bare page list firstData aStream index connectToHost connectToPort type newUrl | Socket initializeNetwork. bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. bare _ bare copyUpTo: $#. "remove fragment, if specified" serverName _ bare copyUpTo: $/. page _ bare copyFrom: serverName size + 1 to: bare size. (serverName includes: $:) ifTrue: [ index _ serverName indexOf: $:. port _ (serverName copyFrom: index+1 to: serverName size) asNumber. serverName _ serverName copyFrom: 1 to: index-1. ] ifFalse: [ port _ self defaultPort ]. page size = 0 ifTrue: [page _ '/']. "add arguments" args ifNotNil: [page _ page, (self argString: args) ]. HTTPProxyServer isNil ifTrue: [ connectToHost _ serverName. connectToPort _ port ] ifFalse: [ page _ 'http://', serverName, ':', port printString, page. "put back together" connectToHost _ HTTPProxyServer. connectToPort _ HTTPProxyPort]. self flag: #XXX. "this doesn't make sense if a user isn't available for questioning... -ls" self retry: [serverAddr _ NetNameResolver addressForName: connectToHost timeout: 20. serverAddr ~~ nil] asking: 'Trouble resolving server name. Keep trying?' ifGiveUp: [Socket deadServer: connectToHost. ^ 'Could not resolve the server named: ', connectToHost]. 3 timesRepeat: [ sock _ HTTPSocket new. sock connectTo: serverAddr port: connectToPort. (sock waitForConnectionUntil: (self deadlineSecs: 30)) ifFalse: [ Socket deadServer: connectToHost. sock destroy. ^ 'Server ',connectToHost,' is not responding']. Transcript cr; cr; show: url; cr. sock sendCommand: 'GET ', page, ' HTTP/1.0', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" 'User-Agent: Squeak 1.31', CrLf, 'Host: ', serverName, ':', port printString, CrLf. "blank line automatically added" list _ sock getResponseUpTo: CrLf, CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: header; cr." firstData _ list at: 3. header isEmpty ifTrue: [aStream _ 'server aborted early'] ifFalse: [ "dig out some headers" sock header: header. length _ sock getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ sock getHeader: 'content-type'. sock responseCode first = $3 ifTrue: [ newUrl _ sock getHeader: 'location'. newUrl ifNotNil: [ Transcript show: 'redirecting to ', newUrl; cr. sock destroy. ^self httpGetDocument: newUrl args: args accept: mimeType ] ]. aStream _ sock getRestOfBuffer: firstData totalLength: length. sock responseCode = '401' ifTrue: [^ header, aStream contents]. ]. sock destroy. "Always OK to destroy!!" aStream class ~~ String ifTrue: [ ^ MIMEDocument contentType: type content: aStream contents url: url]. aStream = 'server aborted early' ifFalse: [ ] ].! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'di 4/4/1999 09:57'! httpGetNoError: url args: args accept: mimeType "Return the exact contents of a web file. Do better error checking. Asks for the given MIME type. To fetch raw data, you can use the MIMI type 'application/octet-stream'. If mimeType is nil, use 'text/html'. The parsed header is saved. Use a proxy server if one has been registered." "Edited to remove a lineFeed from the source 4/4/99 - di" | document data | document _ self httpGetDocument: url args: args accept: mimeType. (document isKindOf: String) ifTrue: [ "strings indicate errors" ^ document ]. data _ document content. (data beginsWith: '' , (String with: Character linefeed) , '4') ifTrue: ["an error message 404 File not found" ^ data copyFrom: 21 to: data size-16]. ^ (RWBinaryOrTextStream with: data) reset ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 10/15/97 12:07'! httpGif: url "Fetch the given URL, parse it using the GIF reader, and return the resulting Form." " HTTPSocket httpShowGif: 'www.altavista.digital.com/av/pix/default/av-adv.gif' " " HTTPSocket httpShowGif: 'www.webPage.com/~kaehler2/ainslie.gif' " | doc ggg | doc _ self httpGet: url accept: 'image/gif'. doc class == String ifTrue: [ self inform: 'The server with that GIF is not responding'. ^ ColorForm extent: 20@20 depth: 8]. doc binary; reset. (ggg _ Smalltalk gifReaderClass new) setStream: doc. ^ ggg nextImage. ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tao 10/26/97 23:21'! httpJpeg: url "Fetch the given URL, parse it using the JPEG reader, and return the resulting Form." | doc ggg | doc _ self httpGet: url. doc binary; reset. (ggg _ Smalltalk jpegReaderClass new) setStream: doc. ^ ggg nextImage. ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'! httpPost: url args: argsDict accept: mimeType "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" | document | document _ self httpPostDocument: url args: argsDict accept: mimeType request: ''. (document isKindOf: String) ifTrue: [ "strings indicate errors" ^document ]. ^RWBinaryOrTextStream with: document content! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 23:27'! httpPostDocument: url args: argsDict "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" ^self httpPostDocument: url args: argsDict accept: 'application/octet-stream' request: ''! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 9/22/1998 20:16'! httpPostDocument: url args: argsDict accept: mimeType "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" ^ self httpPostDocument: url args: argsDict accept: mimeType request: '' ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tao 6/22/1999 07:46'! httpPostDocument: url args: argsDict accept: mimeType request: requestString "like httpGET, except it does a POST instead of a GET. POST allows data to be uploaded" | serverName serverAddr s header length bare page list firstData aStream port argsStream first specifiedServer type newUrl | Socket initializeNetwork. "parse url" bare _ (url asLowercase beginsWith: 'http://') ifTrue: [url copyFrom: 8 to: url size] ifFalse: [url]. serverName _ bare copyUpTo: $/. specifiedServer _ serverName. (serverName includes: $:) ifFalse: [ port _ self defaultPort ] ifTrue: [ port _ (serverName copyFrom: (serverName indexOf: $:) + 1 to: serverName size) asNumber. serverName _ serverName copyUpTo: $:. ]. page _ bare copyFrom: (bare indexOf: $/) to: bare size. page size = 0 ifTrue: [page _ '/']. HTTPProxyServer ifNotNil: [ page _ 'http://', serverName, ':', port printString, page. "put back together" serverName _ HTTPProxyServer. port _ HTTPProxyPort]. "encode the arguments dictionary" argsStream _ WriteStream on: String new. first _ true. argsDict associationsDo: [ :assoc | assoc value do: [ :value | first ifTrue: [ first _ false ] ifFalse: [ argsStream nextPut: $& ]. argsStream nextPutAll: assoc key encodeForHTTP. argsStream nextPut: $=. argsStream nextPutAll: value encodeForHTTP. ] ]. "make the request" self retry: [serverAddr _ NetNameResolver addressForName: serverName timeout: 20. serverAddr ~~ nil] asking: 'Trouble resolving server name. Keep trying?' ifGiveUp: [^ 'Could not resolve the server named: ', serverName]. s _ HTTPSocket new. s connectTo: serverAddr port: port. s waitForConnectionUntil: self standardDeadline. Transcript cr; show: url; cr. s sendCommand: 'POST ', page, ' HTTP/1.0', CrLf, (mimeType ifNotNil: ['ACCEPT: ', mimeType, CrLf] ifNil: ['']), 'ACCEPT: text/html', CrLf, "Always accept plain text" HTTPBlabEmail, "may be empty" requestString, "extra user request. Authorization" 'User-Agent: Squeak 1.31', CrLf, 'Content-type: application/x-www-form-urlencoded', CrLf, 'Content-length: ', argsStream contents size printString, CrLf, 'Host: ', specifiedServer, CrLf. "blank line automatically added" s sendCommand: argsStream contents. "get the header of the reply" list _ s getResponseUpTo: CrLf, CrLf ignoring: (String with: CR). "list = header, CrLf, CrLf, beginningOfData" header _ list at: 1. "Transcript show: page; cr; show: argsStream contents; cr; show: header; cr." firstData _ list at: 3. "dig out some headers" s header: header. length _ s getHeader: 'content-length'. length ifNotNil: [ length _ length asNumber ]. type _ s getHeader: 'content-type'. s responseCode first = $3 ifTrue: [ newUrl _ s getHeader: 'location'. newUrl ifNotNil: [ Transcript show: 'redirecting to: ', newUrl; cr. s destroy. ^self httpPostDocument: newUrl args: argsDict accept: mimeType ] ]. aStream _ s getRestOfBuffer: firstData totalLength: length. s responseCode = '401' ifTrue: [^ header, aStream contents]. s destroy. "Always OK to destroy!!" ^ MIMEDocument contentType: type content: aStream contents url: url! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:00'! httpShowChunk: url "From a Swiki server, get a text chunk in the changes file. Show its text in a window with style. Vertical bar separates class and selector. BE SURE TO USE ; instead of : in selectors!!" " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Socket|Comment' " " HTTPSocket httpShowChunk: 'http://206.16.12.145:80/OurOwnArea.chunk.Point|class|x;y;' " | doc text | doc _ (self httpGet: url accept: 'application/octet-stream'). " doc size = 0 ifTrue: [doc _ 'The server does not seem to be responding']." doc class == String ifTrue: [text _ doc] ifFalse: [text _ doc nextChunkText]. (StringHolder new contents: text) openLabel: url. ! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:50'! httpShowGif: url "Display the picture retrieved from the given URL, which is assumed to be a GIF file. See examples in httpGif:." self showImage: (self httpGif: url) named: (url findTokens: '/') last! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'sma 4/30/2000 09:51'! httpShowJpeg: url "Display the picture retrieved from the given URL, which is assumed to be a JPEG file. See examples in httpGif:." self showImage: (self httpJpeg: url) named: (url findTokens: '/') last! ! !HTTPSocket class methodsFor: 'get the page' stamp: 'tk 5/4/1998 17:01'! httpShowPage: url "Display the exact contents of the given URL as text. See examples in httpGet:" | doc | doc _ (self httpGet: url accept: 'application/octet-stream') contents. doc size = 0 ifTrue: [^ self error: 'Document could not be fetched']. (StringHolder new contents: doc) openLabel: url. ! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'jm 9/15/97 12:06'! proxyTestingComment "Test Kevin's SmartCache on this machine" " HTTPSocket useProxyServerNamed: '127.0.0.1' port: 8080. HTTPSocket httpShowPage: 'http://www.disneyblast.com/default.html'. HTTPSocket stopUsingProxyServer. " "Test getting to outside world from DOL" " HTTPSocket useProxyServerNamed: 'web-proxy.online.disney.com' port: 8080. HTTPSocket httpShowPage: 'http://www.apple.com/default.html'. HTTPSocket stopUsingProxyServer. " "Test Windows Machine in our cubicle at DOL" " HTTPSocket useProxyServerNamed: '206.18.67.150' port: 8080. HTTPSocket httpShowPage: 'http://kids.online.disney.com/~kevin/squeak/k_t.morph'. HTTPSocket stopUsingProxyServer. " " HTTPSocket httpShowPage: 'kids.online.disney.com/' " " HTTPSocket httpShowGif: 'kids.online.disney.com/~kevin/images/dlogo.gif' " ! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'ls 9/17/1998 07:18'! stopUsingProxyServer "Stop directing HTTP request through a proxy server." HTTPProxyServer _ nil. HTTPProxyPort _ 80. ! ! !HTTPSocket class methodsFor: 'proxy settings' stamp: 'msk 9/28/1998 15:52'! useProxyServerNamed: proxyServerName port: portNum "Direct all HTTP requests to the HTTP proxy server with the given name and port number." proxyServerName ifNil: [ "clear proxy settings" HTTPProxyServer _ nil. HTTPProxyPort _ 80. ^ self]. proxyServerName class == String ifFalse: [self error: 'Server name must be a String or nil']. HTTPProxyServer _ proxyServerName. HTTPProxyPort _ portNum. HTTPProxyPort class == String ifTrue: [HTTPPort _ portNum asNumber]. HTTPProxyPort ifNil: [HTTPProxyPort _ self defaultPort].! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'tk 7/16/1999 16:46'! argString: args "Return the args in a long string, as encoded in a url" | argsString first | args class == String ifTrue: ["sent in as a string, not a dictionary" ^ (args first = $? ifTrue: [''] ifFalse: ['?']), args]. argsString _ WriteStream on: String new. argsString nextPut: $?. first _ true. args associationsDo: [ :assoc | assoc value do: [ :value | first ifTrue: [ first _ false ] ifFalse: [ argsString nextPut: $& ]. argsString nextPutAll: assoc key encodeForHTTP. argsString nextPut: $=. argsString nextPutAll: value encodeForHTTP. ] ]. ^ argsString contents ! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'jm 9/15/97 11:10'! retry: tryBlock asking: troubleString ifGiveUp: abortActionBlock "Execute the given block. If it evaluates to true, return true. If it evaluates to false, prompt the user with the given string to see if he wants to try again. If not, evaluate the abortActionBlock and return false." | response | [tryBlock value] whileFalse: [ response _ (PopUpMenu labels: 'Retry\Give Up' withCRs) startUpWithCaption: troubleString. response = 2 ifTrue: [abortActionBlock value. ^ false]]. ^ true ! ! !HTTPSocket class methodsFor: 'utilities' stamp: 'jm 10/14/2002 07:33'! showImage: image named: imageName Smalltalk isMorphic ifTrue: [World primaryHand attachMorph: (SketchMorph withForm: image)] ifFalse: [FormView open: image named: imageName]. ! ! !HTTPSocket class methodsFor: 'magic numbers' stamp: 'ls 9/17/1998 07:17'! defaultPort "default port to connect on" ^80! ! I provide a halo of handles for my target morph. Dragging, duplicating, rotating, resizing and other operations can be done by mousing down on the appropriate handle. ! !HaloMorph methodsFor: 'initialization' stamp: 'jm 6/5/2003 21:29'! initialize super initialize. self color: (Color r: 0.6 g: 0.8 b: 1.0). growingOrRotating _ false. ! ! !HaloMorph methodsFor: 'accessing' stamp: 'sw 1/26/2000 15:36'! haloBox: aBox haloBox _ aBox! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 10/15/2002 17:36'! setTarget: aMorph "Private!! Set the target without adding handles." target _ aMorph. ! ! !HaloMorph methodsFor: 'events' stamp: 'sw 9/7/1999 15:43'! staysUpWhenMouseIsDownIn: aMorph ^ ((aMorph == target) or: [submorphs includes: aMorph]) or: ["name under edit, special case" (aMorph isKindOf: StringMorphEditor) and: [submorphs includes: aMorph owner]]! ! !HaloMorph methodsFor: 'events' stamp: 'jm 10/15/2002 17:40'! wantsKeyboardFocusFor: aSubmorph "To allow the name to be edited in the halo." ^ true ! ! !HaloMorph methodsFor: 'stepping' stamp: 'jm 10/15/2002 17:14'! step | newBounds | target ifNil: [^ self]. target isWorldMorph ifTrue: [newBounds _ target bounds] ifFalse: [newBounds _ target worldBoundsForHalo]. newBounds = self bounds ifTrue: [^ self]. growingOrRotating ifFalse: [ "adjust halo bounds if appropriate" submorphs size > 1 ifTrue: [self addHandles]. "recreates full set with new bounds" self bounds: newBounds]. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 6/5/2003 21:58'! addCircleHandles | box | target isWorldMorph ifTrue: [^ self]. self removeAllMorphs. "remove old handles, if any" self bounds: target worldBoundsForHalo. "update my size" box _ self basicBox. target addHandlesTo: self box: box. self addName. growingOrRotating _ false. self layoutChanged. self changed. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 6/5/2003 22:08'! addHandle: handleSpec for: targetMorph "Add and return the handle defined by the haloSpec for the given target morph." | helpString aPoint handle colorToUse iconName form | helpString _ handleSpec addHandleSelector copyFrom: 4 to: handleSpec addHandleSelector size - 7. (#('Menu') includes: helpString) ifTrue: [helpString _ helpString, ' for me.'] ifFalse: [helpString _ helpString, ' me.']. helpString = 'Dup me.' ifTrue: [helpString _ 'Duplicate me.']. aPoint _ self positionIn: haloBox horizontalPlacement: handleSpec horizontalPlacement verticalPlacement: handleSpec verticalPlacement. handle _ MouseHandleMorph newBounds: (Rectangle center: aPoint extent: self handleSize asPoint) color: (colorToUse _ Color colorFrom: handleSpec color). handle target: targetMorph; mouseUpTarget: self; mouseUpSelector: #endInteraction; setBalloonText: (target balloonHelpTextFor: helpString). iconName _ handleSpec iconSymbol. iconName ifNotNil: [ "add icon if available" form _ HaloIcons at: iconName ifAbsent: [nil]. form ifNotNil: [ handle addMorphCentered: (ImageMorph new form: form; color: colorToUse makeForegroundColor; lock)]]. self addMorph: handle. ^ handle ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 6/5/2003 20:28'! addHandles self addCircleHandles. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 9/8/1999 11:06'! addName self addNameBeneath: self basicBox string: target externalName ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 5/15/2003 22:25'! addNameBeneath: outerRectangle string: aString "Add a name display centered beneath the bottom of the outer rectangle. Return the handle." | nameMorph namePosition | nameMorph _ StringMorph contents: aString. nameMorph color: Color magenta. namePosition _ outerRectangle bottomCenter - ((nameMorph width // 2) @ (self handleSize negated // 2 - 1)). nameMorph position: (namePosition min: self world viewBox bottomRight - nameMorph extent y + 2). self addMorph: nameMorph. ^ nameMorph ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 12/21/1999 22:10'! basicBox | aBox minSide anExtent | minSide _ 4 * self handleSize. anExtent _ ((self width + self handleSize + 8) max: minSide) @ ((self height + self handleSize + 8) max: minSide). aBox _ Rectangle center: self center extent: anExtent. ^ self world ifNil: [aBox] ifNotNil: [aBox intersect: (self world viewBox insetBy: 8@8)] ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:36'! doDebug: evt with: menuHandle "Ask hand to invoke the a debugging menu for my inner target. If shift key is down, immediately put up an inspector on the inner target" | menu | self removeAllHandlesBut: nil. "remove all handles" self world displayWorld. evt shiftPressed ifTrue: [ self delete. ^ target inspectInMorphic]. menu _ evt hand buildDebugHandleMenuFor: target. menu addTitle: target externalName. evt hand invokeMenu: menu event: evt. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 21:28'! doDirection: anEvent with: directionHandle self removeAllHandlesBut: directionHandle! ! !HaloMorph methodsFor: 'private' stamp: 'di 9/30/1998 11:32'! doDrag: evt with: dragHandle target setConstrainedPositionFrom: (target pointFromWorld: evt cursorPoint - positionOffset). ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 9/21/1998 12:25'! doDup: evt with: dupHandle "Ask hand to duplicate my target." evt hand setArgument: target. self setTarget: evt hand duplicateMorph. self removeAllHandlesBut: dupHandle! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:53'! doGrow: evt with: growHandle | newExtent | newExtent _ (target pointFromWorld: (evt cursorPoint - positionOffset)) - target topLeft. evt shiftPressed ifTrue: [newExtent _ (newExtent x max: newExtent y) asPoint]. target extent: (newExtent max: minExtent). ((target respondsTo: #scalePoint) and: [(target scalePoint - 1.0) r < 0.15]) ifTrue: [ target scalePoint: 1.0@1.0. growHandle color: Color yellow] ifFalse: [growHandle color: Color orange]. growHandle position: evt cursorPoint - (growHandle extent // 2). self layoutChanged. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:35'! doMenu: evt with: menuHandle "Ask hand to invoke the halo menu for my inner target." | menu | self removeAllHandlesBut: nil. "remove all handles" self world displayWorld. menu _ evt hand buildMorphHandleMenuFor: target. target addTitleForHaloMenu: menu. evt hand invokeMenu: menu event: evt. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:36'! doRecolor: evt with: menuHandle target changeColor. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:35'! doRot: evt with: rotHandle "Update the rotation of my target if it is rotatable." | degrees | degrees _ (evt cursorPoint - (target pointInWorld: target referencePosition)) degrees. degrees _ degrees - angleOffset degrees. degrees _ degrees detentBy: 10.0 atMultiplesOf: 90.0 snap: false. degrees = 0.0 ifTrue: [rotHandle color: Color lightBlue] ifFalse: [rotHandle color: Color blue]. rotHandle submorphsDo: [:m | m color: rotHandle color makeForegroundColor]. ((target isKindOf: SketchMorph) and: [target rotationStyle == #normal]) ifTrue: [self removeAllHandlesBut: rotHandle]. target rotationDegrees: degrees. rotHandle position: evt cursorPoint - (rotHandle extent // 2). self layoutChanged! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 16:13'! endInteraction (target isInWorld not or: [owner == nil]) ifTrue: [^ self]. self isInWorld ifTrue: [ self comeToFront. self addHandles]. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 1/27/2000 18:42'! handleAllowanceForIconicHalos ^ 12! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 17:38'! handleSize ^ 16 ! ! !HaloMorph methodsFor: 'private' stamp: 'bolot 4/14/2000 19:32'! maybeCollapse: evt with: collapseHandle "Ask hand to collapse my target if mouse comes up in it." (collapseHandle containsPoint: evt cursorPoint) ifFalse: [self delete. target addHalo: evt] ifTrue: [self delete. target collapse]! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/11/2002 16:51'! maybeDismiss: evt with: dismissHandle "Ask hand to dismiss my target if mouse comes up in it." (dismissHandle containsPoint: evt cursorPoint) ifFalse: [ self delete. target addHalo: evt] ifTrue: [ self delete. target delete]. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/3/2002 19:41'! maybeDoDup: evt with: dupHandle ^ self doDup: evt with: dupHandle ! ! !HaloMorph methodsFor: 'private' stamp: 'sma 5/3/2000 23:12'! mouseDownInCollapseHandle: evt with: collapseHandle self removeAllHandlesBut: collapseHandle. collapseHandle color: Color tan darker! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/11/2002 16:54'! mouseDownInDimissHandle: evt with: dismissHandle self removeAllHandlesBut: dismissHandle. dismissHandle color: Color darkGray. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 10/28/1999 22:24'! prepareToTrackCenterOfRotation: anEvent with: rotationHandle self removeAllHandlesBut: rotationHandle ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 3/22/1999 21:26'! setDismissColor: evt with: dismissHandle "Called on mouseStillDown in the dismiss handle; set the color appropriately." | colorToUse | colorToUse _ (dismissHandle containsPoint: evt cursorPoint) ifFalse: [Color red muchLighter] ifTrue: [Color lightGray]. dismissHandle color: colorToUse! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/4/2002 07:08'! startDrag: evt with: dragHandle "Drag my target without removing it from its owner." self removeAllHandlesBut: dragHandle. positionOffset _ dragHandle center - target positionInWorld. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/11/2002 16:38'! startGrow: evt with: growHandle | botRt | "Initialize resizing of my target." growingOrRotating _ true. self removeAllHandlesBut: growHandle. "remove all other handles" botRt _ target pointInWorld: target bottomRight. (self world viewBox containsPoint: botRt) ifTrue: [positionOffset _ evt cursorPoint - botRt] ifFalse: [positionOffset _ 0@0]. target isAlignmentMorph ifTrue: [minExtent _ target minWidth@target minHeight] ifFalse: [minExtent _ 3@3]. ! ! !HaloMorph methodsFor: 'private' stamp: 'jm 10/15/2002 15:53'! startRot: evt with: rotHandle "Initialize rotation of my target. Assume it is rotatable." growingOrRotating _ true. self removeAllHandlesBut: rotHandle. "remove all other handles" angleOffset _ evt cursorPoint - (target pointInWorld: target referencePosition). angleOffset _ Point r: angleOffset r degrees: angleOffset degrees - target rotationDegrees. ! ! !HaloMorph methodsFor: 'private' stamp: 'sw 12/30/1999 11:35'! trackCenterOfRotation: anEvent with: rotationCenterHandle rotationCenterHandle center: anEvent cursorPoint ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:28'! addCollapseHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #mouseDownInCollapseHandle:with:; mouseMoveSelector: #setDismissColor:with:; mouseUpSelector: #maybeCollapse:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:29'! addDebugHandle: haloSpec Preferences debugHaloHandle ifTrue: [ (self addHandle: haloSpec for: self) mouseDownSelector: #doDebug:with:]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:26'! addDismissHandle: handleSpec (self addHandle: handleSpec for: self) mouseDownSelector: #mouseDownInDimissHandle:with:; mouseMoveSelector: #maybeDismiss:with:; mouseUpSelector: #setDismissColor:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:27'! addDragHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #startDrag:with:; mouseMoveSelector: #doDrag:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:30'! addDupHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #doDup:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 17:36'! addFontEmphHandle: haloSpec (target isKindOf: TextMorph) ifTrue: [ (self addHandle: haloSpec for: self) target: target; mouseDownSelector: #chooseEmphasisOrAlignment; mouseUpTarget: self].! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 17:36'! addFontSizeHandle: haloSpec (target isKindOf: TextMorph) ifTrue: [ (self addHandle: haloSpec for: self) target: target; mouseDownSelector: #chooseFont; mouseUpTarget: self].! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 17:37'! addFontStyleHandle: haloSpec (target isKindOf: TextMorph) ifTrue: [ (self addHandle: haloSpec for: self) target: target; mouseDownSelector: #chooseStyle; mouseUpTarget: self]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:31'! addGrabHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #doGrab:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 16:12'! addGrowHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #startGrow:with:; mouseMoveSelector: #doGrow:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 17:34'! addHelpHandle: haloSpec target balloonText ifNotNil: [ (self addHandle: haloSpec for: self) mouseDownSelector: #mouseDownOnHelpHandle:; mouseUpSelector: #deleteBalloon; mouseUpTarget: target]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/11/2002 17:35'! addMenuHandle: haloSpec (self addHandle: haloSpec for: self) mouseDownSelector: #doMenu:with:. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 10/15/2002 17:34'! addRecolorHandle: haloSpec target isColorable ifTrue: [ (self addHandle: haloSpec for: self) mouseDownSelector: #doRecolor:with:]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 11/15/2003 05:06'! addRepaintHandle: haloSpec (target isKindOf: SketchMorph) ifTrue: [ (self addHandle: haloSpec for: self) target: target; mouseDownSelector: #editDrawing; mouseUpTarget: self]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'jm 11/15/2003 05:05'! addRotateHandle: haloSpec self flag: 'use isRotatable here:'. (target isKindOf: SketchMorph) ifTrue: [ (self addHandle: haloSpec for: self) mouseDownSelector: #startRot:with:; mouseMoveSelector: #doRot:with:]. ! ! !HaloMorph methodsFor: 'handles' stamp: 'sw 12/21/1999 18:22'! positionIn: aBox horizontalPlacement: horiz verticalPlacement: vert | xCoord yCoord | horiz == #left ifTrue: [xCoord _ aBox left]. horiz == #leftCenter ifTrue: [xCoord _ aBox left + (aBox width // 4)]. horiz == #center ifTrue: [xCoord _ (aBox left + aBox right) // 2]. horiz == #rightCenter ifTrue: [xCoord _ aBox left + ((3 * aBox width) // 4)]. horiz == #right ifTrue: [xCoord _ aBox right]. vert == #top ifTrue: [yCoord _ aBox top]. vert == #topCenter ifTrue: [yCoord _ aBox top + (aBox height // 4)]. vert == #center ifTrue: [yCoord _ (aBox top + aBox bottom) // 2]. vert == #bottomCenter ifTrue: [yCoord _ aBox top + ((3 * aBox height) // 4)]. vert == #bottom ifTrue: [yCoord _ aBox bottom]. ^ xCoord @ yCoord! ! I record the parameters of a Halo handle including it's color, icon name, placement, and the selector that determines it's behavior. ! !HaloSpec methodsFor: 'initialization' stamp: 'jm 10/11/2002 16:41'! horizontalPlacement: hp verticalPlacement: vp color: col iconSymbol: is addHandleSelector: sel horizontalPlacement _ hp. verticalPlacement _ vp. color _ col. iconSymbol _ is asSymbol. addHandleSelector _ sel. ! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 19:54'! addHandleSelector ^ addHandleSelector! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! color ^ color! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! horizontalPlacement ^ horizontalPlacement! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! iconSymbol ^ iconSymbol! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! verticalPlacement ^ verticalPlacement! ! The cursor may be thought of as the HandMorph. The hand's submorphs hold anything being carried by dragging. There can be multiple hands in the same world, in which case the user initials are displayed for each remote hand. ! !HandMorph methodsFor: 'initialization' stamp: 'jm 8/11/2003 20:53'! initForEvents mouseDownMorph _ nil. lastEvent _ MorphicEvent new. eventTransform _ MorphicTransform identity. self resetClickState. mouseOverTimes _ Dictionary new. ! ! !HandMorph methodsFor: 'initialization' stamp: 'jm 10/14/2002 07:52'! initialize super initialize. self initForEvents. keyboardFocus _ nil. mouseOverMorphs _ OrderedCollection new. dragOverMorphs _ OrderedCollection new. bounds _ 0@0 extent: Cursor normal extent. userInitials _ ''. damageRecorder _ DamageRecorder new. cachedCanvasHasHoles _ false. grid _ 4@4. gridOn _ false. temporaryCursor _ temporaryCursorOffset _ nil ! ! !HandMorph methodsFor: 'classification' stamp: 'jm 10/14/2002 07:51'! isHandMorph ^ true ! ! !HandMorph methodsFor: 'cursor' stamp: 'jwh 6/5/2000 07:38'! cursorBounds ^temporaryCursor ifNil: [self position extent: NormalCursor extent] ifNotNil: [self position + temporaryCursorOffset extent: temporaryCursor extent]! ! !HandMorph methodsFor: 'cursor' stamp: 'di 3/6/1999 23:52'! showTemporaryCursor: cursorOrNil "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal cursor." self showTemporaryCursor: cursorOrNil hotSpotOffset: 0@0 ! ! !HandMorph methodsFor: 'cursor' stamp: 'jwh 6/5/2000 08:48'! showTemporaryCursor: cursorOrNil hotSpotOffset: hotSpotOffset "Set the temporary cursor to the given Form. If the argument is nil, revert to the normal hardware cursor." self changed. cursorOrNil == nil ifTrue: [temporaryCursor _ temporaryCursorOffset _ nil] ifFalse: [temporaryCursor _ cursorOrNil asCursorForm. temporaryCursorOffset _ temporaryCursor offset - hotSpotOffset]. bounds _ self cursorBounds. self userInitials: userInitials; layoutChanged; changed ! ! !HandMorph methodsFor: 'geometry' stamp: 'jwh 6/5/2000 08:11'! position ^temporaryCursor ifNil: [bounds topLeft] ifNotNil: [bounds topLeft - temporaryCursorOffset]! ! !HandMorph methodsFor: 'geometry' stamp: 'jwh 6/5/2000 07:52'! position: aPoint "Overridden to align submorph origins to the grid if gridding is on." | adjustedPosition | adjustedPosition := aPoint. gridOn ifTrue: [adjustedPosition := adjustedPosition grid: grid]. temporaryCursor ifNotNil: [adjustedPosition := adjustedPosition + temporaryCursorOffset]. ^super position: adjustedPosition ! ! !HandMorph methodsFor: 'geometry' stamp: 'ar 5/18/2000 18:35'! userInitials: aString | qp cb | userInitials _ aString. userInitials isEmpty ifFalse: [qp _ DisplayScanner quickPrintOn: Display. cb _ self cursorBounds. self bounds: (cb merge: (cb topRight + (0@4) extent: (qp stringWidth: userInitials)@(qp lineHeight)))] ! ! !HandMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:05'! drawOn: aCanvas "Draw the hand itself (i.e., the cursor)." temporaryCursor == nil ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft] ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft]. userInitials size > 0 ifTrue: [aCanvas text: userInitials at: (self cursorBounds topRight + (0@4)) font: nil color: color]. ! ! !HandMorph methodsFor: 'drawing' stamp: 'jm 10/14/2002 07:49'! fullDrawOn: aCanvas "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version caches an image of the morphs being held by the hand for better performance. This cache is invalidated if one of those morphs changes." | disableCaching subBnds | disableCaching _ false. disableCaching ifTrue: [self nonCachingFullDrawOn: aCanvas. ^ self]. submorphs isEmpty ifTrue: [cacheCanvas _ nil. ^ self drawOn: aCanvas]. "just draw the hand itself" subBnds _ Rectangle merging: (submorphs collect: [:m | m fullBounds]). self updateCacheCanvas: aCanvas. (cacheCanvas == nil or: [cachedCanvasHasHoles and: [cacheCanvas depth = 1]]) ifTrue: ["could not use caching due to translucency; do full draw" self nonCachingFullDrawOn: aCanvas. ^ self]. "draw the shadow" aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during:[:shadowCanvas| cachedCanvasHasHoles ifTrue: ["Have to draw the real shadow of the form" shadowCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: ["Much faster if only have to shade the edge of a solid rectangle" (subBnds areasOutside: (subBnds translateBy: self shadowOffset negated)) do: [:r | shadowCanvas fillRectangle: r color: Color black]]]. "draw morphs in front of the shadow using the cached Form" cachedCanvasHasHoles ifTrue: [aCanvas paintImage: cacheCanvas form at: subBnds origin] ifFalse: [aCanvas drawImage: cacheCanvas form at: subBnds origin sourceRect: cacheCanvas form boundingBox]. self drawOn: aCanvas. "draw the hand itself in front of morphs" ! ! !HandMorph methodsFor: 'drawing' stamp: 'ar 2/18/2000 15:19'! nonCachingFullDrawOn: aCanvas | shadowForm | "A HandMorph has unusual drawing requirements: 1. the hand itself (i.e., the cursor) appears in front of its submorphs 2. morphs being held by the hand cast a shadow on the world/morphs below The illusion is that the hand plucks up morphs and carries them above the world." "Note: This version does not cache an image of the morphs being held by the hand. Thus, it is slower for complex morphs, but consumes less space." submorphs isEmpty ifTrue: [^ self drawOn: aCanvas]. "just draw the hand itself" aCanvas asShadowDrawingCanvas translateBy: self shadowOffset during:[:shadowCanvas| "Note: We use a shadow form here to prevent drawing overlapping morphs multiple times using the transparent shadow color." shadowForm _ self shadowForm. " shadowForm displayAt: shadowForm offset negated. Display forceToScreen: (0@0 extent: shadowForm extent). " shadowCanvas paintImage: shadowForm at: shadowForm offset. "draw shadows" ]. "draw morphs in front of shadows" self drawSubmorphsOn: aCanvas. self drawOn: aCanvas. "draw the hand itself in front of morphs" ! ! !HandMorph methodsFor: 'drawing' stamp: 'di 3/19/2000 14:26'! restoreSavedPatchOn: aCanvas "Clear the changed flag and restore the part of the given canvas under this hand from the previously saved patch. If necessary, handle the transition to using the hardware cursor." hasChanged _ false. savedPatch ifNotNil: [aCanvas drawImage: savedPatch at: savedPatch offset. ((userInitials size = 0) and: [(submorphs size = 0) and: [temporaryCursor == nil]]) ifTrue: [ "Make the transition to using hardware cursor. Clear savedPatch and report one final damage rectangle to erase the image of the software cursor." super invalidRect: (savedPatch offset extent: savedPatch extent + self shadowOffset). Sensor currentCursor == Cursor normal ifFalse: [Cursor normal show]. "show hardware cursor" savedPatch _ nil]]. ! ! !HandMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 16:01'! savePatchFrom: aCanvas "Save the part of the given canvas under this hand as a Form and return its bounding rectangle." "Details: The previously used patch Form is recycled when possible to reduce the burden on storage management." | damageRect myBnds | damageRect _ myBnds _ self fullBounds. savedPatch ifNotNil: [ damageRect _ myBnds merge: (savedPatch offset extent: savedPatch extent)]. (savedPatch == nil or: [savedPatch extent ~= myBnds extent]) ifTrue: [ "allocate new patch form if needed" savedPatch _ aCanvas form allocateForm: myBnds extent]. aCanvas contentsOfArea: (myBnds translateBy: aCanvas origin) into: savedPatch. savedPatch offset: myBnds topLeft. ^ damageRect ! ! !HandMorph methodsFor: 'drawing' stamp: 'jm 11/24/2002 10:48'! shadowForm "Return a 1-bit shadow of my submorphs. Assumes submorphs is not empty" | bnds canvas | bnds _ Rectangle merging: (submorphs collect: [:m | m bounds]). canvas _ (FormCanvas extent: bnds extent depth: 1) asShadowDrawingCanvas: Color black. canvas translateBy: bnds topLeft negated during:[:tempCanvas| self drawSubmorphsOn: tempCanvas]. ^ canvas form offset: bnds topLeft! ! !HandMorph methodsFor: 'drawing' stamp: 'ar 5/28/2000 17:12'! updateCacheCanvas: aCanvas "Update the cached image of the morphs being held by this hand." | subBnds rectList | "Always check for real translucency -- can't be cached in a form" self allMorphsDo: [:m | m hasTranslucentColor ifTrue: [ cacheCanvas _ nil. cachedCanvasHasHoles _ true. ^ self]]. subBnds _ Rectangle merging: (submorphs collect: [:m | m fullBounds]). (cacheCanvas == nil or: [cacheCanvas extent ~= subBnds extent]) ifTrue: [ cacheCanvas _ (aCanvas allocateForm: subBnds extent) getCanvas. cacheCanvas translateBy: subBnds origin negated during:[:tempCanvas| self drawSubmorphsOn: tempCanvas]. self submorphsDo: [:m | (m areasRemainingToFill: subBnds) isEmpty ifTrue: [^ cachedCanvasHasHoles _ false]]. cachedCanvasHasHoles _ (cacheCanvas form tallyPixelValues at: 1) > 0. ^ self]. "incrementally update the cache canvas" rectList _ damageRecorder invalidRectsFullBounds: (0@0 extent: subBnds extent). damageRecorder reset. rectList do: [:r | cacheCanvas translateTo: subBnds origin negated clippingTo: r during:[:c| c fillColor: Color transparent. "clear to transparent" self drawSubmorphsOn: c]].! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/4/2002 17:58'! checkForMoreKeyboard "Quick check for more keyboard activity -- Allows, eg, many characters to be accumulated into a single replacement during type-in." | oldPoint | Sensor keyboardPressed ifFalse: [^ nil]. oldPoint _ lastEvent cursorPoint. lastEvent _ MorphicEvent new setKeyValue: Sensor keyboard asciiValue mousePoint: oldPoint buttons: Sensor primMouseButtons hand: self. ^ lastEvent ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/13/2002 17:33'! dragOverList: evt | p roots mList mm root | p _ evt cursorPoint. roots _ self world rootMorphsAt: p. "root morphs in world" roots isEmpty ifTrue: [^ Array empty] ifFalse: [root _ roots first]. mList _ root morphsAt: p. mList size > 0 ifTrue: ["NOTE: We really only want the top morph and all its owners" mm _ mList first. mList _ OrderedCollection new. [mm == root] whileFalse: [mList addLast: mm. mm _ mm owner]. mList add: root]. ^ mList! ! !HandMorph methodsFor: 'event handling' stamp: 'bf 1/5/2000 18:18'! gridPointRaw "Private!! Returns the nearest grid point to the cursor to be used as the coordinate for the current event. Do not include a cursor offset" | where | where _ Sensor cursorPoint. ^ gridOn ifTrue: [where grid: grid] ifFalse: [where] ! ! !HandMorph methodsFor: 'event handling' stamp: 'mir 5/9/2000 15:28'! handleDragOver: evt | mList allMouseOvers leftMorphs enteredMorphs | owner ifNil: [^ self]. "this hand is not in a world" "Start with a list consisting of the topmost unlocked morph in the innermost frame (pasteUp), and all of its containers in that frame." mList _ self dragOverList: evt. "Make a list of all potential drag-overs..." allMouseOvers _ mList select: [:m | m handlesMouseOverDragging: (evt transformedBy: (m transformFrom: self))]. leftMorphs _ dragOverMorphs select: [:m | (allMouseOvers includes: m) not]. enteredMorphs _ allMouseOvers select: [:m | (dragOverMorphs includes: m) not]. "Notify and remove any morphs that have just been left..." leftMorphs do: [:m | dragOverMorphs remove: m. m mouseLeaveDragging: (evt transformedBy: (m transformFrom: self))]. "Add any new mouse-overs and send mouseEnter:" enteredMorphs do: [:m | dragOverMorphs add: m. mouseOverMorphs remove: m ifAbsent: []. "Cant be in two places at once" m mouseEnterDragging: (evt transformedBy: (m transformFrom: self))].! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 8/11/2003 21:43'! handleEvent: evt (evt anyButtonPressed and: [evt controlKeyPressed and: [lastEvent anyButtonPressed not]]) ifTrue: [ eventTransform _ MorphicTransform identity. lastEvent _ evt. ^ self invokeMetaMenu: evt]. evt blueButtonPressed ifTrue: [ lastEvent blueButtonPressed ifFalse: [ eventTransform _ MorphicTransform identity. lastEvent _ evt. ^ self specialGesture: evt]]. lastEvent _ evt. self position ~= evt cursorPoint ifTrue: [ self position: evt cursorPoint]. evt isMouse ifTrue: [ evt isMouseMove ifTrue: [^ self handleMouseMove: evt]. evt isMouseDown ifTrue: [ ^ self handleMouseDown: evt]. evt isMouseUp ifTrue: [^ self handleMouseUp: evt]]. evt isKeystroke ifTrue: [ keyboardFocus ifNil: [self recordUnclaimedKeystroke: evt] ifNotNil: [keyboardFocus keyStroke: evt]. ^ self]. ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 7/18/2003 11:46'! handleMouseDown: evt "Dispatch a mouseDown event." | m localEvt rootForGrab aHalo | "if carrying morphs, just drop them" self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt]. clickState ~~ #idle ifTrue: [^ self checkForDoubleClick: evt]. m _ self recipientForMouseDown: (gridOn "Don't grid when determining recipient" ifTrue: ["Should really use original cursorPoint, but this should do" evt copy setCursorPoint: Sensor cursorPoint] ifFalse: [evt]). m ifNotNil: [aHalo _ self world haloMorphOrNil. (aHalo == nil or: [aHalo staysUpWhenMouseIsDownIn: m]) ifFalse: [self world abandonAllHalos]. m deleteBalloon. (m handlesMouseDown: evt) ifTrue: ["start a mouse transaction on m" (self newMouseFocus: m) ifNil: [^ self]. localEvt _ self transformEvent: evt. targetOffset _ localEvt cursorPoint - m position. m mouseDown: localEvt. clickState == #firstClickDown ifTrue: ["clickClient click: firstClickEvent"] ifFalse: ["ensure that at least one mouseMove: is reported for each mouse transaction:" m mouseMove: (localEvt copy setType: #mouseMove). (m handlesMouseOverDragging: localEvt) ifTrue: ["If m also handles dragOver, enter it in the list" dragOverMorphs add: m. mouseOverMorphs remove: m ifAbsent: []]]] ifFalse: ["grab m by the appropriate root" menuTargetOffset _ targetOffset _ evt cursorPoint. rootForGrab _ m rootForGrabOf: m. rootForGrab ifNotNil: [self grabMorph: rootForGrab] ifNil: [self newMouseFocus: m "trigger automatic viewing, for example"]]. mouseOverTimes removeKey: m ifAbsent: []]! ! !HandMorph methodsFor: 'event handling' stamp: 'di 9/3/1998 15:58'! handleMouseMove: evt "Dispatch a mouseMove event." clickState ~~ #idle ifTrue: [self checkForDoubleClick: evt]. mouseDownMorph ifNotNil: [mouseDownMorph mouseMove: (self transformEvent: evt)]. submorphs isEmpty ifTrue: [evt anyButtonPressed ifTrue: [self handleDragOver: evt] ifFalse: [self handleMouseOver: evt]] ifFalse: [self handleDragOver: evt]! ! !HandMorph methodsFor: 'event handling' stamp: 'sw 4/3/2000 17:44'! handleMouseOver: evt | mList allMouseOvers leftMorphs enteredMorphs now t oldHalo balloonHelpEnabled | owner ifNil: [^ self]. balloonHelpEnabled _ Preferences balloonHelpEnabled. "Start with a list consisting of the topmost unlocked morph in the innermost frame (pasteUp), and all of its containers in that frame." mList _ self mouseOverList: evt. now _ Time millisecondClockValue. "Make a list of all potential mouse-overs..." allMouseOvers _ mList select: [:m | m wantsHalo or: [(balloonHelpEnabled and: [m wantsBalloon]) "To start a timer" or: [m handlesMouseOver: (evt transformedBy: (m transformFrom: self))] "To send mouseEnter:"]]. leftMorphs _ mouseOverMorphs select: [:m | (allMouseOvers includes: m) not]. enteredMorphs _ allMouseOvers select: [:m | (mouseOverMorphs includes: m) not]. "Notify and remove any mouse-overs that have just been left..." leftMorphs do: [:m | mouseOverMorphs remove: m. m wantsBalloon ifTrue: [m deleteBalloon]. m mouseLeave: (evt transformedBy: (m transformFrom: self)). mouseOverTimes removeKey: m ifAbsent: [] ]. "Add any new mouse-overs and send mouseEnter: and/or start timers..." enteredMorphs do: [:m | mouseOverMorphs add: m. dragOverMorphs remove: m ifAbsent: []. "Cant be in two places at once" (m handlesMouseOver: evt) ifTrue: [m mouseEnter: (evt transformedBy: (m transformFrom: self))]. (m wantsHalo or: [m wantsBalloon]) ifTrue: [mouseOverTimes at: m put: now]]. mouseOverTimes keys do: [:m | "Check pending timers for lingering" t _ mouseOverTimes at: m. (now < t "rollover" or: [now > (t+800)]) ifTrue: ["Yes we have lingered for 0.8 seconds..." mouseOverTimes removeKey: m. m owner ifNotNil: "Not deleted during linger (--it happens ;--)" [m wantsHalo ifTrue: [oldHalo _ m world haloMorphOrNil. (oldHalo == nil or: [oldHalo target ~~ m]) ifTrue: ["Put up halo for m" self popUpHaloFor: m event: evt. (balloonHelpEnabled and: [m wantsBalloon]) ifTrue: ["...and reschedule balloon after longer linger" mouseOverTimes at: m put: now]] ifFalse: ["Halo for m is already up, so show balloon" (balloonHelpEnabled and: [m wantsBalloon]) ifTrue: [m showBalloon: m balloonText]]] ifFalse: [(balloonHelpEnabled and: [m wantsBalloon]) ifTrue: [m showBalloon: m balloonText]]]]]! ! !HandMorph methodsFor: 'event handling' stamp: 'di 9/14/1998 08:47'! handleMouseUp: evt "Dispatch a mouseUp event." | oldFocus | clickState ~~ #idle ifTrue: [self checkForDoubleClick: evt]. "drop morphs being carried, if any" self hasSubmorphs ifTrue: [self dropMorphsEvent: evt]. mouseDownMorph = nil ifTrue: [^ self]. oldFocus := mouseDownMorph. "make sure that focus becomes nil." mouseDownMorph _ nil. "mouse focus transaction ends when mouse goes up" oldFocus mouseUp: (self transformEvent: evt). dragOverMorphs copy do: [:m | dragOverMorphs remove: m. m mouseLeaveDragging: (evt transformedBy: (m transformFrom: self))]. ! ! !HandMorph methodsFor: 'event handling' stamp: 'di 1/4/1999 22:27'! mouseOverList: evt "Returns a list consisting of the topmost unlocked morph in the innermost frame (pasteUp), and all of its containers in that frame." "This new version treats halos as independent so as not to mask mouseovers of morphs beneath an active halo." | top | top _ self mouseOverList: evt rank: 1. (top isEmpty or: [(top last isKindOf: HaloMorph) not]) ifTrue: [^ top] ifFalse: [^ top , (self mouseOverList: evt rank: 2)]! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/13/2002 17:34'! mouseOverList: evt rank: rank "With rank = 1, returns a list consisting of the topmost unlocked morph in the innermost frame (pasteUp), and all of its containers in that frame. With rank = 2, returns the smae kind of list, but rooted in the next lower rootmorph. This can be useful to get mouseOvers below an active halo." | p roots mList mm r | p _ evt cursorPoint. roots _ self world rootMorphsAt: p. "root morphs in world" roots size >= rank ifTrue: [mList _ (roots at: rank) unlockedMorphsAt: p. mList size > 0 ifTrue: ["NOTE: We really only want the top morph and all its owners" mm _ mList first. r _ roots at: rank. mList _ OrderedCollection new. [mm == r] whileFalse: [mList addLast: mm. mm _ mm owner]. mList add: r]] ifFalse: [mList _ Array empty]. ^ mList! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/4/2002 07:14'! newMouseFocus: aMorphOrNil ((mouseDownMorph isKindOf: MenuItemMorph) and: [(aMorphOrNil isKindOf: MenuItemMorph) not]) ifTrue: [(mouseDownMorph owner isKindOf: MenuMorph) ifTrue: ["Crock: If a menu is proffered with the mouse up and the user clicks down outside it (as is normal in MVC), then the menu goes away and nothing else happens." mouseDownMorph owner deleteIfPopUp. ^ nil]]. mouseDownMorph _ aMorphOrNil. self updateMouseDownTransform. ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 8/11/2003 21:41'! nextUnclaimedKeystrokeOrNil "Answer the next unclaimed keystroke from the buffer or nil if there isn't one." self unclaimedKeystrokeAvailable ifTrue: [^ unclaimedKeystrokes removeFirst] ifFalse: [^ nil]. ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/4/2002 17:59'! processEvents "Process user input events from the local input devices." | griddedPoint evt | griddedPoint _ Sensor cursorPoint "- owner viewBox topLeft". gridOn ifTrue: [griddedPoint _ griddedPoint grid: grid]. evt _ MorphicEvent new setMousePoint: griddedPoint buttons: Sensor primMouseButtons lastEvent: lastEvent hand: self. self handleEvent: evt. [Sensor keyboardPressed] whileTrue: [ evt _ MorphicEvent new setKeyValue: Sensor keyboard asciiValue mousePoint: griddedPoint buttons: Sensor primMouseButtons hand: self. self handleEvent: evt]. ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 19:49'! recipientForMouseDown: evt "Return the morph that should handle the given mouseDown: event." "Details: To get mouse events, a morph must a. contain the point at which the mouse went down, and b. respond true to handlesMouseDown:, and c1. be in front of all other submorphs that respond true to handlesMouseDown: or c2. be the outer-most submorph that responds true to preemptsMouseDown: If no morph handles the mouse down, the front-most submorph is grabbed. The complexity in this description arises from the need to resolve conflicts when nested submorphs all want to handle mouse events. The preemptsMouseDown: mechanism allows a morph to intercept mouse events before its submorphs. It is needed only in unusual situations, such as parts bins containing mouse-sensitive objects." | p roots coreSample | owner ifNil: [^ nil]. "this hand is not in a world" p _ evt cursorPoint. roots _ owner rootMorphsAt: p. "root morphs in world" roots size = 0 ifTrue: [ "no morphs at the given point, so world gets it" ^ owner]. "coreSample is submorphs of the front-most root morph in front-to-back order" coreSample _ roots first unlockedMorphsAt: p. "first, look for an outer-most submorph that preempts mouse events, if any" coreSample reverseDo: [:subM | (subM preemptsMouseDown: evt) ifTrue: [^ subM]]. "second, look for the inner-most submorph that handles mouse events, if any" coreSample do: [:subM | (subM handlesMouseDown: evt) ifTrue: [^ subM]]. "no enclosing morph wants the event, so return the front-most submorph" coreSample size = 0 ifTrue: [ "no morphs at the given point, so world gets it" ^ owner]. ^ coreSample first ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 8/11/2003 21:38'! recordUnclaimedKeystroke: evt unclaimedKeystrokes ifNil: [unclaimedKeystrokes _ OrderedCollection new]. unclaimedKeystrokes addLast: evt. [unclaimedKeystrokes size > 10] whileTrue: [unclaimedKeystrokes removeFirst]. "keep only most recent N keystrokes" ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 8/11/2003 21:39'! unclaimedKeystrokeAvailable "Answer true if there are unclaimed keystrokes. Keystrokes arrive when there is no keyboard focus are considered 'unclaimed'." ^ unclaimedKeystrokes notNil and: [unclaimedKeystrokes size > 0] ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 8/11/2003 21:36'! unclaimedKeystrokes unclaimedKeystrokes ifNil: [unclaimedKeystrokes _ OrderedCollection new]. ^ unclaimedKeystrokes ! ! !HandMorph methodsFor: 'event handling' stamp: 'jm 6/17/1998 08:57'! updateMouseDownTransform "To help with, eg, autoscrolling" mouseDownMorph ifNil: [eventTransform _ MorphicTransform identity] ifNotNil: [eventTransform _ mouseDownMorph transformFrom: self]. ! ! !HandMorph methodsFor: 'double click support' stamp: 'jm 7/18/2003 11:43'! checkForDoubleClick: evt "Process the given mouse event to detect a click, double-click, or drag." | t | t _ Time millisecondClockValue - firstClickTime. clickState = #firstClickDown ifTrue: [ (t > DoubleClickTime or: [(evt cursorPoint - firstClickEvent cursorPoint) r > 15]) ifTrue: [ "consider it a drag if hand moves or timeout expires" clickClient startDrag: firstClickEvent. ^ self resetClickState]. evt isMouseUp ifTrue: [ clickState _ #firstClickUp. ^ self]]. clickState = #firstClickUp ifTrue: [ evt isMouseDown ifTrue: [ clickClient doubleClick: firstClickEvent. ^ self resetClickState]. t > DoubleClickTime ifTrue: [ clickClient click: firstClickEvent. ^ self resetClickState]]. ! ! !HandMorph methodsFor: 'double click support' stamp: 'di 10/21/1999 21:10'! resetClickState "Reset the double-click detection state to normal (i.e., not waiting for a double-click)." clickClient _ nil. clickState _ #idle. eventTransform _ MorphicTransform identity. firstClickEvent _ nil. firstClickTime _ nil. ! ! !HandMorph methodsFor: 'double click support' stamp: 'jm 6/29/2003 15:14'! waitForClicksOrDrag: aMorph event: evt "Wait until the difference between click, double-click, or drag gesture is known, then inform the given morph what transpired. This message is sent when the given morph first receives a mouse-down event. If the mouse button goes up, then down again within DoubleClickTime, then 'doubleClick: evt' is sent to the morph. If the mouse button goes up but not down again within DoubleClickTime, then the message 'click: evt' is sent to the morph. Finally, if the button does not go up within DoubleClickTime, then 'startDrag: evt' is sent to the morph. In all cases, the event supplied is the original mouseDown event that initiated the gesture. mouseMove: and mouseUp: events are not sent to the morph until it becomes the mouse focus, which is typically done by the client in its click:, doubleClick:, or startDrag: methods." clickClient _ aMorph. clickState _ #firstClickDown. firstClickEvent _ evt. firstClickTime _ Time millisecondClockValue. ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'sw 11/10/1999 08:23'! attachMorph: m "Position the center of the given morph under this hand, then grab it. This method is used to grab far away or newly created morphs." | delta | delta _ m bounds extent // 2. gridOn ifTrue: [delta _ delta grid: grid]. m position: (formerPosition _ self position - delta). self addMorphBack: m.! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'jm 10/15/2002 16:21'! dropMorphsEvent: evt "Drop all the morphs this hand is currently holding in response to the given event." "Details: All submorphs of the front-most composite morph under the hand are given an opportunity to accept the dropping morph. If none of these accepts it, or if there is no morph under the hand, then the morph drops into the world." | newOwner morphToDrop tfm localPt grabbedMorph | owner ifNil: [^ self]. self changed. self submorphs reverseDo: [:m | "drop in reverse order to maintain back-to-front ordering" grabbedMorph _ m. newOwner _ self dropTargetFor: grabbedMorph event: evt. newOwner ifNil: [ "drop not allowed" self rejectDropMorph: grabbedMorph event: evt. ^ self]. morphToDrop _ newOwner morphToDropFrom: grabbedMorph. morphToDrop == grabbedMorph ifFalse: [ submorphs size == 1 ifTrue: [ self privateRemoveMorph: m. m privateOwner: nil]]. "the above says: the thing to drop is not what I was carrying; silently vaporize what I was carrying lest it cause trouble later; keep the owner/submorph relationship invariant, but don't go through the standard delete protocol" tfm _ newOwner transformFromWorld. localPt _ tfm globalPointToLocal: self position. morphToDrop position: localPt + (morphToDrop position - self position). newOwner acceptDroppingMorph: morphToDrop event: evt. morphToDrop justDroppedInto: newOwner event: evt. morphToDrop owner = self ifTrue: [self world addMorphFront: m]]. self layoutChanged. formerOwner _ nil. formerPosition _ nil. ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'jm 10/11/2002 06:45'! dropTargetFor: aMorph event: evt "Return the morph that the given morph is to be dropped onto. Return nil if we must repel the morph. Return the world, if no other morph wants the dropping morph." | root coreSample | aMorph willingToBeEmbeddedUponLanding ifFalse: [^ self world]. root _ nil. owner submorphs reverseDo: [:m | ((m fullContainsPoint: evt cursorPoint) and: [(m isKindOf: HaloMorph) not]) ifTrue: [root _ m]]. root == nil ifTrue: [^ self world]. coreSample _ root morphsAt: evt cursorPoint. coreSample do: [:m | (m repelsMorph: aMorph event: evt) ifTrue: [^ nil]]. coreSample do: [:m | (m wantsDroppedMorph: aMorph event: evt) ifTrue: [^ m]]. ^ self world ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'jm 10/15/2002 16:28'! grabMorph: aMorph "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." | localPt morphToGrab | formerOwner _ aMorph owner. formerPosition _ aMorph position. localPt _ aMorph pointFromWorld: self position. morphToGrab _ aMorph aboutToBeGrabbedBy: self. morphToGrab ifNil: [^ self]. morphToGrab position: self position + (morphToGrab position - localPt). gridOn ifTrue: [morphToGrab position: (morphToGrab position grid: grid)]. self addMorphBack: morphToGrab. ! ! !HandMorph methodsFor: 'grabbing/dropping' stamp: 'jm 10/15/2002 16:30'! grabMorphFromMenu: aMorph "Grab the given morph (i.e., add it to this hand and remove it from its current owner) without changing its position. This is used to pick up a morph under the hand's current position, versus attachMorph: which is used to pick up a morph that may not be near this hand." | morphToGrab delta | morphToGrab _ aMorph aboutToBeGrabbedBy: self. delta _ morphToGrab positionInWorld - menuTargetOffset. gridOn ifTrue: [delta _ delta grid: grid]. morphToGrab position: self position + delta. self addMorphBack: morphToGrab. ! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:51'! appearanceDo "Build and show the appearance menu for the world." self appearanceMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 7/20/2003 20:41'! appearanceMenu "Build the appearance menu for the world." | screenCtrl menu | screenCtrl _ ScreenController new. menu _ (MenuMorph entitled: 'appearance...') defaultTarget: self. menu addStayUpItem. menu add: 'set display depth...' action: #setDisplayDepth. menu balloonTextForLastItem: 'set the number of bits per pixel for the display'. menu add: 'set desktop color...' action: #changeBackgroundColor. menu balloonTextForLastItem: 'set a color to use as desktop background'. menu addLine. menu add: 'full screen on' target: screenCtrl action: #fullScreenOn. menu balloonTextForLastItem: 'puts you in full-screen mode, if not already there'. menu add: 'full screen off' target: screenCtrl action: #fullScreenOff. menu balloonTextForLastItem: 'if in full-screen mode, takes you out of it'. menu addLine. menu add: 'window colors...' target: Preferences action: #windowSpecificationPanel. menu balloonTextForLastItem: 'Lets you specify colors for standard system windows'. menu add: 'system fonts...' target: self action: #standardFontDo. menu balloonTextForLastItem: 'Choose the standard fonts to use for code, lists, menus, window titles, etc'. menu add: 'text highlight color...' target: Preferences action: #chooseTextHighlightColor. menu balloonTextForLastItem: 'Choose which color should be used for text highlighting in Morphic'. menu add: 'insertion point color...' target: Preferences action: #chooseInsertionPointColor. menu balloonTextForLastItem: 'Choose which color to use for the text insertion point in Morphic'. menu addLine. menu addUpdating: #menuColorString target: Preferences action: #toggleMenuColorPolicy. menu balloonTextForLastItem: 'Governs whether menu colors should be derived from the desktop color'. menu addUpdating: #roundedCornersString target: Preferences action: #toggleRoundedCorners. menu balloonTextForLastItem: 'Governs whether morphic windows and menus should have rounded corners'. menu addLine. menu add: 'clear turtle trails from desktop' target: self world action: #clearTurtleTrails. menu balloonTextForLastItem: 'remove trails left by objects moving with their pens down'. menu add: 'unlock locked objects' action: #unlockWorldContents. menu balloonTextForLastItem: 'If any items on the world desktop are currently locked, unlock them'. menu add: 'unhide hidden objects' action: #showHiders. menu balloonTextForLastItem: 'If any items on the world desktop are currently hidden, make them visible'. ^ menu! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 5/31/2003 16:37'! buildWorldMenu "Build the meta menu for the world." | menu | menu _ MenuMorph new defaultTarget: self. menu addStayUpItem. menu add: 'previous project' target: owner action: #goBack. menu add: 'jump to project...' target: owner action: #jumpToProject. menu addLine. menu add: 'restore display' target: self world action: #restoreDisplay. menu addLine. menu add: 'open...' action: #openWindow. menu add: 'windows...' action: #windowsDo. menu add: 'changes...' action: #changesDo. menu add: 'help...' action: #helpDo. menu add: 'appearance...' action: #appearanceDo. menu addLine. menu add: 'new morph...' action: #newMorph. menu add: 'debug...' action: #debugDo. menu addLine. menu add: 'save' action: #saveSession. menu add: 'save as...' action: #saveAs. menu add: 'save and quit' action: #saveAndQuit. menu add: 'quit' action: #quitSession. ^ menu ! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:52'! changesDo "Build and show the changes menu for the world." self changesMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 5/31/2003 15:44'! changesMenu "Build the changes menu for the world." | menu | menu _ (MenuMorph entitled: 'changes...') defaultTarget: self. menu addStayUpItem. menu add: 'file out current change set' target: Utilities action: #fileOutChanges. menu balloonTextForLastItem: 'Write the current change set out to a file whose name reflects the change set name and the current date & time.'. menu add: 'create new change set...' target: ChangeSorter action: #newChangeSet. menu balloonTextForLastItem: 'Create a new change set and make it the current one.'. menu add: 'browse changed methods' action: #browseChangedMessages. menu balloonTextForLastItem: 'Open a message-list browser showing all methods in the current change set'. menu add: 'check change set for slips' target: Smalltalk changes action: #lookForSlips. menu balloonTextForLastItem: 'Check the current change set for halts, references to the Transcript, etc., and if any such thing is found, open up a message-list browser detailing all possible slips.'. menu addLine. menu add: 'simple change sorter' selector: #openChangeSorter: argument: 1. menu balloonTextForLastItem: 'Open a 3-paned changed-set viewing tool'. menu add: 'dual change sorter' selector: #openChangeSorter: argument: 2. menu balloonTextForLastItem: 'Open a change sorter that shows you two change sets at a time, making it easy to copy and move methods and classes between them.'. menu addLine. menu add: 'recently logged changes...' action: #openChangesLog. menu balloonTextForLastItem: 'Open a change-list browser on the latter part of the changes log.'. menu add: 'recent log file...' action: #fileForRecentLog. menu balloonTextForLastItem: 'Create a file holding the logged changes (going as far back as you wish), and open a window on that file.'. ^ menu ! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:52'! debugDo "Build and show the debug menu for the world." self debugMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 10/31/2002 14:01'! debugMenu "Build the scripting menu for the world." | menu | menu _ (MenuMorph entitled: 'debug...') defaultTarget: self. menu addStayUpItem. menu add: 'inspect world' target: owner action: #inspect. menu add: 'explore world' target: owner action: #explore. menu add: 'start MessageTally' action: #startMessageTally. menu addLine. "(self hasProperty: #errorOnDraw) ... Later make following come up only when needed:" menu add: 'start drawing again' target: owner action: #resumeAfterDrawError. menu add: 'start stepping again' target: owner action: #resumeAfterStepError. ^ menu ! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:52'! helpDo "Build and show the help menu for the world." self helpMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 5/31/2003 17:12'! helpMenu "Build the help menu for the world." | screenCtrl menu | screenCtrl _ ScreenController new. menu _ (MenuMorph entitled: 'help...') defaultTarget: self. menu addStayUpItem. menu add: 'about this system...' target: Smalltalk action: #aboutThisSystem. menu balloonTextForLastItem: 'current version information'. menu add: 'command-key help' target: Utilities action: #openCommandKeyHelp. menu balloonTextForLastItem: 'summary of keyboard shortcuts'. menu add: 'preferences...' target: Preferences action: #openPreferencesInspector. menu balloonTextForLastItem: 'view and change various options'. menu addLine. menu add: 'set author initials...' target: screenCtrl action: #setAuthorInitials. menu balloonTextForLastItem: 'set initials used to identify method editors'. menu add: 'memory statistics' target: screenCtrl action: #vmStatistics. menu balloonTextForLastItem: 'memory and garbage collection statistics'. menu add: 'space left' target: screenCtrl action: #garbageCollect. menu balloonTextForLastItem: 'do a full garbage collect and report space left'. ^ menu ! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 8/11/2003 21:09'! newMorph | menu catDict cat subMenu | menu _ (MenuMorph entitled: 'Add a new morph') defaultTarget: self. menu addStayUpItem. menu add: 'grab patch from screen' action: #grabDrawingFromScreen. menu addLine. menu add: 'from paste buffer' action: #pasteMorph. menu add: 'from alphabetical list' subMenu: self alphabeticalMorphMenu. menu addLine. catDict _ Dictionary new. self morphClassesForNewMorphMenu do: [:c | cat _ c category. (cat beginsWith: 'Morphic-') ifTrue: [cat _ cat copyFrom: ('Morphic-' size + 1) to: cat size]. (catDict includesKey: cat) ifTrue: [(catDict at: cat) addLast: c] ifFalse: [catDict at: cat put: (OrderedCollection with: c)]]. catDict keys asArray sort do: [:k | subMenu _ MenuMorph new. ((catDict at: k) asArray sort: [:c1 :c2 | c1 name < c2 name]) do: [:c | subMenu add: c name target: self selector: #newMorphOfClass:event: argument: c]. menu add: k subMenu: subMenu]. menu popUpForHand: self. ! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 11/15/2003 05:06'! openMenu "Build the open window menu for the world." | menu | menu _ (MenuMorph entitled: 'open...') defaultTarget: self. menu addStayUpItem. menu add: 'browser' action: #openBrowser. menu add: 'workspace' action: #openWorkspace. menu add: 'file list' action: #openFileList. menu add: 'transcript' action: #openTranscript. menu addLine. menu add: 'simple change sorter' selector: #openChangeSorter: argument: 1. menu add: 'dual change sorter' selector: #openChangeSorter: argument: 2. menu addLine. (Smalltalk includesKey: #StandardSystemView) ifTrue: [ menu add: 'mvc project' action: #openMVCProject]. menu add: 'morphic project' action: #openMorphicProject. ^ menu ! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:53'! openWindow "Build and show the open menu for the world." self openMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:57'! standardFontDo "Build and show the standard font menu" Preferences fontConfigurationMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'sma 6/5/2000 13:57'! windowsDo "Build the windows menu for the world." self windowsMenu popUpForHand: self! ! !HandMorph methodsFor: 'world menu' stamp: 'jm 10/5/2002 06:34'! windowsMenu "Build the windows menu for the world." | menu | menu _ (MenuMorph entitled: 'windows...') defaultTarget: self. menu addStayUpItem. menu add: 'find window' action: #findWindow. menu balloonTextForLastItem: 'Presents a list of all windows; if you choose one from the list, it becomes the active window.'. menu add: 'find changed browsers...' action: #findDirtyBrowsers. menu balloonTextForLastItem: 'Presents a list of browsers that have unsubmitted changes; if you choose one from the list, it becomes the active window.'. menu add: 'find changed windows...' action: #findDirtyWindows. menu balloonTextForLastItem: 'Presents a list of all windows that have unsubmitted changes; if you choose one from the list, it becomes the active window.'. menu addLine. menu add: 'collapse all windows' action: #collapseAll. menu balloonTextForLastItem: 'Reduce all open windows to collapsed forms that only show titles.'. menu add: 'expand all windows' action: #expandAll. menu balloonTextForLastItem: 'Expand all collapsed windows back to their expanded forms.'. menu addLine. menu add: 'delete unchanged windows' action: #closeUnchangedWindows. menu balloonTextForLastItem: 'Deletes all windows that do not have unsaved text edits.'. menu addLine. menu addUpdating: #staggerPolicyString target: Preferences action: #toggleWindowPolicy. menu balloonTextForLastItem: 'stagger: new windows positioned so you can see a portion of each one. tile: new windows positioned so that they do not overlap others, if possible.'. ^ menu! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 8/4/1999 15:41'! argumentOrNil "Answer the root of the front-most morph under the cursor. If the cursor is not over any morph, answer nil." owner submorphsDo: [:m | ((m fullContainsPoint: targetOffset) and: [m isLocked not]) ifTrue: [^ m rootAt: targetOffset]]. ^ nil ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 8/5/1998 16:53'! browseChangedMessages Smalltalk browseChangedMessages! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 8/19/1998 11:54'! buildDebugHandleMenuFor: argMorph "Build the menu for the given morph's halo's debug handle." argument _ argMorph. ^ argMorph debuggingMenuFor: self! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/7/2002 07:33'! buildMorphHandleMenuFor: argMorph "Build the morph menu for the given morph's halo's menu handle. This menu has two sections. The first section contains commands that are interpreted by the hand; the second contains commands provided by the target morph. This method allows the morph to decide which items should be included in the hand's section of the menu." | menu | argMorph == owner "i.e., the world" ifTrue: [^ self buildWorldMenu]. argument _ argMorph. menu _ MenuMorph new defaultTarget: self. menu addStayUpItem. argMorph addAddHandMenuItemsForHalo: menu hand: self. menu defaultTarget: argMorph. argMorph addCustomHaloMenuItems: menu hand: self. menu defaultTarget: self. menu addLine. ^ menu ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/9/2002 07:11'! buildMorphMenuFor: argMorph "Build the morph menu. This menu has two sections. The first section contains commands that are handled by the hand; the second contains commands handled by the argument morph." | menu | argument _ argMorph. menu _ MenuMorph new defaultTarget: self. menu addStayUpItem. menu add: 'grab' action: #grabMorph. menu add: 'delete' action: #dismissMorph. menu add: 'duplicate' action: #duplicateMorph. menu add: 'resize' action: #resizeMorph. menu add: 'change color...' target: argMorph action: #changeColor. menu addLine. menu add: 'go behind' action: #goBehind. menu add: 'add halo' action: #addHalo. menu add: 'copy to paste buffer' action: #copyToPasteBuffer. menu addLine. self potentialEmbeddingTargets size > 1 ifTrue: [menu add: 'embed...' action: #placeArgumentIn]. (argMorph morphsAt: targetOffset) size > 1 ifTrue: [ menu add: 'submorphs...' target: self selector: #selectSubmorphToOperateOn:sending:event: argumentList: (Array with: argMorph with: #operateOnSubmorph:event:)]. menu addLine. Smalltalk isMorphic ifTrue: [menu add: 'inspect' action: #inspectMorph] ifFalse: [menu add: 'inspect (in MVC)' action: #inspectMorph. menu add: 'inspect' action: #inspectMorphInMorphic]. menu add: 'explore' target: argument action: #explore. menu add: 'browse' target: argument action: #browseHierarchy. menu add: 'make own subclass' action: #subclassMorph. menu addLine. "add commands supplied by the morph itself" menu defaultTarget: argMorph. argMorph addCustomMenuItems: menu hand: self. ^ menu ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 9/3/1999 09:28'! changeBackgroundColor self changeColorTarget: self world selector: #color: originalColor: self world color. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 6/17/1999 14:03'! changeColor argument changeColor! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 9/3/1999 09:15'! changeColorTarget: aMorph selector: aSymbol ^ self changeColorTarget: aMorph selector: aSymbol originalColor: Color white! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 11/28/1999 23:17'! changeColorTarget: aMorph selector: aSymbol originalColor: aColor ^ ColorPickerMorph new sourceHand: self; target: aMorph; selector: aSymbol; originalColor: aColor; addToWorld: self world near: (aMorph ifNil: [Rectangle center: self position extent: 20] ifNotNil: [aMorph == self world ifTrue: [aMorph viewBox bottomLeft + (20@-20) extent: 200] ifFalse: [aMorph fullBounds]]); yourself! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 9/23/1998 01:33'! closeUnchangedWindows "Present a menu of window titles for all windows with changes, and activate the one that gets chosen." (SelectionMenu confirm: 'Do you really want to close all windows except those with unaccepted edits?') ifFalse: [^ self]. (SystemWindow windowsIn: self world satisfying: [:w | w model canDiscardEdits]) do: [:w | w delete]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 2/21/2000 16:01'! collapseAll "Collapse all windows" (SystemWindow windowsIn: self world satisfying: [:w | w isCollapsed not]) reverseDo: [:w | w collapseOrExpand. self world displayWorld]. self collapseNonWindows! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/5/2002 06:37'! collapseNonWindows | nonWindowMorphs | nonWindowMorphs _ self world submorphs select: [:m | (m isKindOf: SystemWindow) not]. nonWindowMorphs do: [:m | m collapse]. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/15/2002 17:18'! copyToPasteBuffer "Save this morph in the paste buffer. This is useful for copying morphs between projects." argument isMorph ifTrue: [ Cursor wait showWhile: [ PasteBuffer _ argument fullCopy. PasteBuffer aboutToBeGrabbedBy: self]] ifFalse: [PasteBuffer _ nil]. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/7/2002 07:27'! duplicateMorph | newMorph | newMorph _ argument fullCopy. self grabMorphFromMenu: newMorph. formerPosition _ argument position. ^ newMorph ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 2/3/2000 16:22'! fileForRecentLog Smalltalk writeRecentToFile! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 11/11/1998 15:20'! findDirtyBrowsers "Present a menu of window titles for browsers with changes, and activate the one that gets chosen." | menu | menu _ MenuMorph new. (SystemWindow windowsIn: self world satisfying: [:w | (w model isKindOf: Browser) and: [w model canDiscardEdits not]]) do: [:w | menu add: w label target: w action: #activate]. menu submorphs size > 0 ifTrue: [self invokeMenu: menu event: lastEvent]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 11/11/1998 15:22'! findDirtyWindows "Present a menu of window titles for all windows with changes, and activate the one that gets chosen." | menu | menu _ MenuMorph new. (SystemWindow windowsIn: self world satisfying: [:w | w model canDiscardEdits not]) do: [:w | menu add: w label target: w action: #activate]. menu submorphs size > 0 ifTrue: [self invokeMenu: menu event: lastEvent]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 6/15/2003 12:11'! findWindow "Present a menu of window titles, and activate the one that gets chosen. Collapsed windows appear below the line, expand if chosen." | menu expanded collapsed nakedMorphs | menu _ MenuMorph new. expanded _ SystemWindow windowsIn: self world satisfying: [:w | w isCollapsed not]. collapsed _ SystemWindow windowsIn: self world satisfying: [:w | w isCollapsed]. nakedMorphs _ self world submorphs select: [:m | (m isKindOf: SystemWindow) not]. (expanded isEmpty & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ self beep]. (expanded asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #activateAndForceLabelToShow. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. (expanded isEmpty | (collapsed isEmpty & nakedMorphs isEmpty)) ifFalse: [menu addLine]. (collapsed asSortedCollection: [:w1 :w2 | w1 label caseInsensitiveLessOrEqual: w2 label]) do: [:w | menu add: w label target: w action: #collapseOrExpand. w model canDiscardEdits ifFalse: [menu lastItem color: Color red]]. nakedMorphs isEmpty ifFalse: [menu addLine]. (nakedMorphs asSortedCollection: [:w1 :w2 | w1 externalName caseInsensitiveLessOrEqual: w2 externalName]) do: [:w | menu add: w externalName target: w action: #comeToFrontAndAddHalo]. menu addTitle: 'find window'. self invokeMenu: menu event: lastEvent! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sma 6/5/2000 13:28'! invokeMenu: menu event: evt "Invoke the given menu for the given event." menu popUpEvent: evt! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/16/2002 12:46'! invokeMetaMenu: evt "Invoke the meta menu. If the hand is over the background, the world menu is presented. If it is over a morph, a menu of operations for that morph is presented. Each menu entry contains a string to be presented in the menu and a selector. If the selector takes an argument, the mouse-down event that invoked the menu is passed as an argument. This lets the command know which hand invoked it in order to do things like attaching the result of the command to that hand. If the hand is over the background and the shift key is pressed, the find-window menu is immediately put up. If the hand is over the background but the yellow button was pressed, an alternate menu, which individual users are encouraged to personalize, is put up -- see HandMorph.yellowButtonClickOnDesktopWithEvent:" | menu | Preferences noviceMode ifTrue: [^ self]. "if carrying morphs, just drop them" self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt]. targetOffset _ menuTargetOffset _ self position. argument _ self argumentOrNil. argument == nil ifTrue: [ evt shiftPressed ifFalse: [ "put put screen menu" menu _ self buildWorldMenu. menu addTitle: 'World'] ifTrue: [^ self findWindow]] ifFalse: [ menu _ self buildMorphMenuFor: argument. menu addTitle: argument class name]. self invokeMenu: menu event: evt. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sma 6/5/2000 13:52'! jumpToProject (Project buildJumpToMenu: (MenuMorph new defaultTarget: Project; addTitle: 'Projects')) popUpForHand: self! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 7/23/2003 23:30'! newMorphOfClass: morphClass event: evt "Attach a new morph of the given class to the invoking hand." | m | m _ morphClass new. evt hand attachMorph: m. owner startSteppingSubmorphsOf: m. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/7/2002 06:42'! objectToPaste ^ Cursor wait showWhile: [PasteBuffer fullCopy] ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 12/6/1999 10:04'! openBrowser Browser openBrowser! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 10/18/1999 22:44'! openChangeSorter: oneOrTwo oneOrTwo = 1 ifTrue: [ChangeSorter new morphicWindow openInWorld: self world] ifFalse: [DualChangeSorter new morphicWindow openInWorld: self world]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 8/4/1998 18:21'! openFileList FileList openAsMorph openInWorld: self world! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 6/9/1999 15:45'! openMorphicProject (ProjectViewMorph newMorphicProjectOn: nil) openInWorld. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'di 10/18/1999 22:39'! openTranscript (Transcript openAsMorphLabel: 'Transcript') openInWorld: self world! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 8/4/1998 18:21'! openWorkspace Workspace new openAsMorphLabel: 'Workspace' inWorld: self world! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/7/2002 07:50'! pasteMorph | aPastee | PasteBuffer ifNil: [^ self inform: 'Nothing to paste.']. self attachMorph: (aPastee _ self objectToPaste). aPastee align: aPastee center with: self position. ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 9/9/1998 15:49'! placeArgumentIn "Let the user choose a new layer in the core sample for the argument to reside in, but don't allow strange loops" | targetMorph | targetMorph _ self selectEmbedTargetMorph: ('Place ', argument externalName, ' in...'). targetMorph ifNotNil: [targetMorph addMorphFront: argument fromWorldPosition: argument position] ! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 5/29/2003 19:49'! potentialEmbeddingTargets "Answer a list of targets into which the hand's arguement could be embedded" | possibleTargets | possibleTargets _ self world morphsAt: menuTargetOffset. argument ifNotNil: [possibleTargets removeAll: argument allMorphs]. ^ possibleTargets! ! !HandMorph methodsFor: 'world menu commands' stamp: 'tk 3/10/2000 21:05'! projectThumbnail "Offer the user a menu of project names. Attach to the hand a thumbnail of the project the user selects." | menu projName pr | menu _ MVCMenuMorph entitled: 'Select Project'. menu add: (Project current name, ' (current)') action: Project current name. menu addLine. Project allNames do: [:n | menu add: n action: n]. projName _ menu invokeAt: self position in: self world. projName ifNotNil: [(pr _ Project named: projName) ifNotNil: [self attachMorph: (ProjectViewMorph on: pr)] ifNil: [self inform: 'can''t seem to find that project']].! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sw 9/9/1998 16:07'! selectEmbedTargetMorph: caption "Put up a menu of morphs found in a core sample taken of the world at the receiver's menuTargetOffset, with the given caption" | menu | menu _ CustomMenu new. self potentialEmbeddingTargets do: [:m | menu add: (self submorphNameFor: m) action: m]. ^ caption size == 0 ifTrue: [menu startUp] ifFalse: [menu startUpWithCaption: caption]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sma 6/5/2000 13:42'! selectSubmorphToOperateOn: rootMorph sending: aSymbol event: evt "Let the user select a submorph of the given root morph. When selected, the given selector is sent with the selected submorph as an argument." | possibleTargets menu | possibleTargets _ rootMorph morphsAt: targetOffset. possibleTargets size = 1 ifTrue: [^ self perform: aSymbol with: possibleTargets first with: evt]. menu _ MenuMorph new. possibleTargets do: [:m | menu add: (self submorphNameFor: m) target: self selector: aSymbol argumentList: (Array with: m with: evt)]. menu popUpEvent: evt! ! !HandMorph methodsFor: 'world menu commands' stamp: 'sma 4/30/2000 09:57'! setDisplayDepth "Let the user choose a new depth for the display. " | result oldDepth | oldDepth _ Display depth. (result _ (SelectionMenu selections: Display supportedDisplayDepths) startUpWithCaption: 'Choose a display depth (it is currently ' , oldDepth printString , ')') ifNotNil: [Display newDepth: result]. (Smalltalk isMorphic and: [(Display depth < 4) ~= (oldDepth < 4)]) ifTrue: ["Repaint windows since they look better all white in depth < 4" (SystemWindow windowsIn: World satisfying: [:w | true]) do: [:w | oldDepth < 4 ifTrue: [w restoreDefaultPaneColor] ifFalse: [w updatePaneColors]]]! ! !HandMorph methodsFor: 'world menu commands' stamp: 'jm 10/4/2002 07:19'! submorphNameFor: aMorph ^ aMorph class name asString ! ! !HandMorph methodsFor: 'special gestures' stamp: 'jm 9/30/2003 00:24'! specialGesture: evt "A special gesture (cmd-mouse on the Macintosh) supports different ways to bring up halos on a morph." Preferences cmdGesturesEnabled ifFalse: [^ self]. Preferences noviceMode ifTrue: [^ self]. self newMouseFocus: nil. "if carrying morphs, just drop them" self hasSubmorphs ifTrue: [^ self dropMorphsEvent: evt]. targetOffset _ menuTargetOffset _ self position. argument _ self argumentOrNil. self popUpHaloFromClick: evt. ! ! !HandMorph methodsFor: 'halos' stamp: 'jm 9/30/2003 00:19'! addHalo argument addHalo: nil. ! ! !HandMorph methodsFor: 'halos' stamp: 'jm 9/30/2003 00:13'! addHalo: evt argument addHalo: evt. ! ! !HandMorph methodsFor: 'halos' stamp: 'jm 9/30/2003 00:16'! popUpHaloFor: aMorph event: evt self world abandonAllHalos. targetOffset _ self position. aMorph addHalo: evt. ! ! !HandMorph methodsFor: 'halos' stamp: 'jm 9/30/2003 00:15'! popUpHaloFromClick: evt "Pop up a halo on a suitable morph below the hand. If there are multiple possible targets, and one of them already has a halo, then choose the next inner target. That is, unless we are already at the bottom, in which case go topmost again." | oldTargets targets anIndex | oldTargets _ OrderedCollection new. self world haloMorphs do: [:h | oldTargets addLast: h target. h delete]. targetOffset _ self position. (argument _ self argumentOrNil) ifNil: [^ owner "the world" addHalo: evt]. argument submorphCount = 0 ifTrue: [^ argument wantsHaloFromClick ifTrue: [argument addHalo: evt "sole target"]]. "Multiple possible targets, choose the outermost suitable one first, but if one already has a halo, then choose the next farther in." targets _ argument unlockedMorphsAt: targetOffset. targets _ targets reversed select: [:aMorph | aMorph wantsHaloFromClick]. targets size = 0 ifTrue: [^ argument wantsHaloFromClick ifTrue: [argument addHalo: evt "sole target"] ifFalse: ["no halo recipient"]]. targets size = 1 ifTrue: [^ targets first addHalo: evt "sole target"]. anIndex _ targets findFirst: [:t | oldTargets includes: t]. anIndex = 0 ifTrue: [^ self popUpNewHaloFromClick: evt targets: targets]. ^ (targets atWrap: anIndex + 1) addHalo: evt ! ! !HandMorph methodsFor: 'halos' stamp: 'sw 1/25/2000 16:57'! popUpNewHaloFromClick: evt targets: targets | outer possible haloRecipient | "Pop up a halo for the most opportune morph, given that this is not a progressive halo transfer. evt is the precipitating mouse event, and targets is the list of potential targets under the mouse" possible _ targets detect: [:aMorph | (aMorph isKindOf: PasteUpMorph) not and: [(aMorph isKindOf: BookMorph) not]] ifNone: [targets last]. outer _ possible owner ifNil: [targets first]. haloRecipient _ targets reversed detect: [:aMorph | aMorph == outer or: [aMorph seeksOutHalo and: [outer defersHaloOnClickTo: aMorph]]] ifNone: [outer]. haloRecipient _ targets detect: [:aMorph | (aMorph defersHaloOnClickTo: haloRecipient) not] ifNone: [haloRecipient]. haloRecipient addHalo: evt ! ! !HandMorph methodsFor: 'from EToyHand' stamp: 'jm 10/11/2002 16:55'! rejectDropMorph: aMorph event: evt "aMorph has been rejected, and must be put back somewhere. There are three cases: (1) It remembers its former owner and position, and goes right back there (2) It remembers its former position only, in which case it was torn off from a parts bin, and the UI is that it floats back to its donor position and then vanishes. (3) Neither former owner nor position is remembered, in which case it is just deleted" (formerOwner notNil and: [formerOwner isPartsBin not]) ifTrue: [^ aMorph slideBackToFormerSituation: evt]. formerPosition ifNotNil: "Position but no owner -- can just make it vanish" [^ aMorph vanishAfterSlidingTo: formerPosition event: evt]. aMorph delete. ! ! !HandMorph methodsFor: 'from EToyHand' stamp: 'jm 10/14/2002 08:56'! showHiders | container | container _ argument ifNotNil: [argument] ifNil: [self world]. container allMorphsDo: [:m | m isHidden: false]. ! ! !HandMorph methodsFor: 'private' stamp: 'jm 6/20/2003 09:37'! alphabeticalMorphMenu | menu morphClasses | menu _ MenuMorph new defaultTarget: self. morphClasses _ self morphClassesForNewMorphMenu. (morphClasses asArray sort: [:c1 :c2 | c1 name < c2 name]) do: [:cl | menu add: cl name target: self selector: #newMorphOfClass:event: argument: cl]. ^ menu ! ! !HandMorph methodsFor: 'private' stamp: 'jm 5/31/2003 20:15'! morphClassesForNewMorphMenu "Answer a collection of morph classes for the 'new morph...' menu." "HandMorph someInstance morphClassesForNewMorphMenu" ^ Morph allSubclasses asArray select: [:c | (c class includesSelector: #includeInNewMorphMenu) and: [c includeInNewMorphMenu]] ! ! !HandMorph methodsFor: 'private' stamp: 'tk 9/26/1999 16:23'! releaseCachedState | svg svgon oo | super releaseCachedState. cacheCanvas _ nil. svg _ grid. svgon _ gridOn. oo _ owner. self removeAllMorphs. self initialize. "nuke everything" self privateOwner: oo. grid _ svg. gridOn _ svgon. mouseDownMorph _ nil. argument _ nil. formerOwner _ nil.! ! !HandMorph class methodsFor: 'accessing' stamp: 'jm 10/14/2002 07:34'! clearPasteBuffer "Clear the paste buffer." PasteBuffer _ nil. ! ! A HandleMorph provides mouse-up control behavior.! !HandleMorph methodsFor: 'stepping' stamp: 'ar 6/18/1999 07:44'! startStepping "Make the receiver the keyboard focus for editing" super startStepping. owner isHandMorph ifTrue:[owner newKeyboardFocus: self].! ! !HandleMorph methodsFor: 'termination' stamp: 'ar 6/18/1999 07:51'! justDroppedInto: aMorph event: anEvent "So that when the hand drops me (into the world) I go away" anEvent hand keyboardFocus == self ifTrue:[anEvent hand newKeyboardFocus: nil]. self changed. self delete. ! ! !HandleMorph methodsFor: 'events' stamp: 'ar 6/18/1999 08:10'! keyStroke: evt "Check for cursor keys" | keyValue | owner isHandMorph ifFalse:[^self]. keyValue _ evt keyValue. keyValue = 28 ifTrue:[^self position: self position - (1@0)]. keyValue = 29 ifTrue:[^self position: self position + (1@0)]. keyValue = 30 ifTrue:[^self position: self position - (0@1)]. keyValue = 31 ifTrue:[^self position: self position + (0@1)]. "Special case for return" keyValue = 13 ifTrue:[ "Drop the receiver and be done" owner newKeyboardFocus: nil. self delete]. ! ! Class Heap implements a special data structure commonly referred to as 'heap'. Heaps are more efficient than SortedCollections if: a) Elements are only removed at the beginning b) Elements are added with arbitrary sort order. The sort time for a heap is O(n log n) in all cases. Instance variables: array <Array> the data repository tally <Integer> the number of elements in the heap sortBlock <Block|nil> a two-argument block defining the sort order, or nil in which case the default sort order is [:element1 :element2| element1 <= element2]! !Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'! at: index "Return the element at the given position within the receiver" (index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index]. ^array at: index! ! !Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:14'! at: index put: newObject "Heaps are accessed with #add: not #at:put:" ^self shouldNotImplement! ! !Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 13:02'! first "Return the first element in the receiver" self emptyCheck. ^array at: 1! ! !Heap methodsFor: 'accessing' stamp: 'ar 9/10/1999 14:08'! reSort "Resort the entire heap" self isEmpty ifTrue:[^self]. tally // 2 to: 1 by: -1 do:[:i| self downHeap: i].! ! !Heap methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:37'! size "Answer how many elements the receiver contains." ^ tally! ! !Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'! sortBlock ^sortBlock! ! !Heap methodsFor: 'accessing' stamp: 'ar 7/1/1999 04:21'! sortBlock: aBlock sortBlock _ aBlock. sortBlock fixTemps. self reSort.! ! !Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! isEmpty "Answer whether the receiver contains any elements." ^tally = 0! ! !Heap methodsFor: 'testing' stamp: 'ar 9/10/1999 13:03'! sorts: element1 before: element2 "Return true if element1 should be sorted before element2. This method defines the sort order in the receiver" ^sortBlock == nil ifTrue:[element1 <= element2] ifFalse:[sortBlock value: element1 value: element2].! ! !Heap methodsFor: 'adding' stamp: 'ar 9/10/1999 13:04'! add: anObject "Include newObject as one of the receiver's elements. Answer newObject." tally = array size ifTrue:[self grow]. array at: (tally _ tally + 1) put: anObject. self upHeap: tally. ^anObject! ! !Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:04'! remove: oldObject ifAbsent: aBlock "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." 1 to: tally do:[:i| (array at: i) = oldObject ifTrue:[^self privateRemoveAt: i]]. ^aBlock value! ! !Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'! removeAt: index "Remove the element at given position" (index < 1 or:[index > tally]) ifTrue:[^self errorSubscriptBounds: index]. ^self privateRemoveAt: index! ! !Heap methodsFor: 'removing' stamp: 'ar 9/10/1999 13:05'! removeFirst "Remove the first element from the receiver" ^self removeAt: 1! ! !Heap methodsFor: 'comparing' stamp: 'ar 9/10/1999 13:05'! = aHeap "Answer true if my and aHeap's species are the same, and if our blocks are the same, and if our elements are the same." self species = aHeap species ifFalse: [^ false]. sortBlock = aHeap sortBlock ifTrue: [^ super = aHeap] ifFalse: [^ false]! ! !Heap methodsFor: 'enumerating' stamp: 'ar 9/10/1999 13:05'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." 1 to: tally do:[:i| aBlock value: (array at: i)]! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:17'! grow "Become larger." self growTo: self size + self growSize.! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! growSize "Return the size by which the receiver should grow if there are no empty slots left." ^array size max: 5! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! growTo: newSize "Grow to the requested size." | newArray | newArray _ Array new: (newSize max: tally). newArray replaceFrom: 1 to: array size with: array startingAt: 1. array _ newArray! ! !Heap methodsFor: 'growing' stamp: 'ar 7/1/1999 04:18'! trim "Remove any empty slots in the receiver." self growTo: self size.! ! !Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'! downHeap: anIndex "Check the heap downwards for correctness starting at anIndex. Everything above (i.e. left of) anIndex is ok." | value k n j | anIndex = 0 ifTrue:[^self]. n _ tally bitShift: -1. k _ anIndex. value _ array at: anIndex. [k <= n] whileTrue:[ j _ k + k. "use max(j,j+1)" (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) ifTrue:[ j _ j + 1]. "check if position k is ok" (self sorts: value before: (array at: j)) ifTrue:[ "yes -> break loop" n _ k - 1] ifFalse:[ "no -> make room at j by moving j-th element to k-th position" array at: k put: (array at: j). "and try again with j" k _ j]]. array at: k put: value.! ! !Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'! downHeapSingle: anIndex "This version is optimized for the case when only one element in the receiver can be at a wrong position. It avoids one comparison at each node when travelling down the heap and checks the heap upwards after the element is at a bottom position. Since the probability for being at the bottom of the heap is much larger than for being somewhere in the middle this version should be faster." | value k n j | anIndex = 0 ifTrue:[^self]. n _ tally bitShift: -1. k _ anIndex. value _ array at: anIndex. [k <= n] whileTrue:[ j _ k + k. "use max(j,j+1)" (j < tally and:[self sorts: (array at: j+1) before: (array at: j)]) ifTrue:[ j _ j + 1]. array at: k put: (array at: j). "and try again with j" k _ j]. array at: k put: value. self upHeap: k! ! !Heap methodsFor: 'private-heap' stamp: 'ar 7/1/1999 04:34'! upHeap: anIndex "Check the heap upwards for correctness starting at anIndex. Everything below anIndex is ok." | value k kDiv2 tmp | anIndex = 0 ifTrue:[^self]. k _ anIndex. value _ array at: anIndex. [ (k > 1) and:[self sorts: value before: (tmp _ array at: (kDiv2 _ k bitShift: -1))] ] whileTrue:[ array at: k put: tmp. k _ kDiv2]. array at: k put: value.! ! !Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:19'! array ^array! ! !Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:36'! privateRemoveAt: index "Remove the element at the given index and make sure the sorting order is okay" | removed | removed _ array at: index. array at: index put: (array at: tally). array at: tally put: nil. tally _ tally - 1. "Use #downHeapSingle: since only one element has been removed" self downHeapSingle: index. ^removed! ! !Heap methodsFor: 'private' stamp: 'ar 7/1/1999 04:35'! setCollection: aCollection array _ aCollection. tally _ 0.! ! !Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'! setCollection: aCollection tally: newTally array _ aCollection. tally _ newTally.! ! !Heap methodsFor: 'private' stamp: 'sma 4/22/2000 19:30'! species ^ Array! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! new ^self new: 10! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 7/1/1999 04:20'! new: n ^super new setCollection: (Array new: n)! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 14:13'! sortBlock: aBlock "Create a new heap sorted by the given block" ^self new sortBlock: aBlock! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 9/10/1999 13:23'! withAll: aCollection "Create a new heap with all the elements from aCollection" ^(self basicNew) setCollection: aCollection asArray copy tally: aCollection size; reSort; yourself! ! !Heap class methodsFor: 'examples' stamp: 'ar 9/10/1999 14:07'! heapExample "Heap heapExample" "Create a sorted collection of numbers, remove the elements sequentially and add new objects randomly. Note: This is the kind of benchmark a heap is designed for." | n rnd array time sorted | n _ 5000. "# of elements to sort" rnd _ Random new. array _ (1 to: n) collect:[:i| rnd next]. "First, the heap version" time _ Time millisecondsToRun:[ sorted _ Heap withAll: array. 1 to: n do:[:i| sorted removeFirst. sorted add: rnd next]. ]. Transcript cr; show:'Time for Heap: ', time printString,' msecs'. "The quicksort version" time _ Time millisecondsToRun:[ sorted _ SortedCollection withAll: array. 1 to: n do:[:i| sorted removeFirst. sorted add: rnd next]. ]. Transcript cr; show:'Time for SortedCollection: ', time printString,' msecs'. ! ! !Heap class methodsFor: 'examples' stamp: 'ar 9/10/1999 13:32'! heapSortExample "Heap heapSortExample" "Sort a random collection of Floats and compare the results with SortedCollection (using the quick-sort algorithm) and ArrayedCollection>>mergeSortFrom:to:by: (using the merge-sort algorithm)." | n rnd array out time sorted | n _ 10000. "# of elements to sort" rnd _ Random new. array _ (1 to: n) collect:[:i| rnd next]. "First, the heap version" out _ Array new: n. "This is where we sort into" time _ Time millisecondsToRun:[ sorted _ Heap withAll: array. 1 to: n do:[:i| sorted removeFirst]. ]. Transcript cr; show:'Time for heap-sort: ', time printString,' msecs'. "The quicksort version" time _ Time millisecondsToRun:[ sorted _ SortedCollection withAll: array. ]. Transcript cr; show:'Time for quick-sort: ', time printString,' msecs'. "The merge-sort version" time _ Time millisecondsToRun:[ array mergeSortFrom: 1 to: array size by: [:v1 :v2| v1 <= v2]. ]. Transcript cr; show:'Time for merge-sort: ', time printString,' msecs'. ! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:28'! changed: sym sym == #classList ifTrue: [self updateAfterClassChange]. super changed: sym! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:02'! initHierarchyForClass: aClassOrMetaClass | tab stab index nonMetaClass | centralClass _ aClassOrMetaClass. nonMetaClass _ aClassOrMetaClass theNonMetaClass. self systemOrganizer: SystemOrganization. metaClassIndicated _ aClassOrMetaClass isMeta. classList _ OrderedCollection new. tab _ ''. nonMetaClass allSuperclasses reverseDo: [:aClass | classList add: tab , aClass name. tab _ tab , ' ']. index _ classList size + 1. nonMetaClass allSubclassesWithLevelDo: [:aClass :level | stab _ ''. 1 to: level do: [:i | stab _ stab , ' ']. classList add: tab , stab , aClass name] startingLevel: 0. self classListIndex: index! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 11/8/1999 09:38'! potentialClassNames "Answer the names of all the classes that could be viewed in this browser" ^ self classList collect: [:aName | aName copyWithout: $ ]! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'di 4/26/2000 20:20'! systemCategorySingleton | cls | cls _ self selectedClass. ^ cls ifNil: [Array new] ifNotNil: [Array with: cls category]! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:04'! updateAfterClassChange "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser." centralClass ifNotNil: [self initHierarchyForClass: centralClass]! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 13:35'! systemCatSingletonKey: aChar from: aView ^ self systemCatListKey: aChar from: aView! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 14:08'! systemCatSingletonMenu: aMenu ^ aMenu labels: 'find class... (f) browse printOut fileOut update rename... remove' lines: #(1 4) selections: #(findClass buildSystemCategoryBrowser printOutSystemCategory fileOutSystemCategory updateSystemCategories renameSystemCategory removeSystemCategory ) ! ! !HierarchyBrowser methodsFor: 'class list' stamp: 'mir 3/22/2000 13:02'! classList classList _ classList select: [:each | Smalltalk includesKey: each withBlanksTrimmed asSymbol]. ^ classList! ! !HierarchyBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 5/8/2000 02:10'! newFor: aClass "Open a new HierarchyBrowser on the given class" | newBrowser | newBrowser _ HierarchyBrowser new initHierarchyForClass: aClass. Browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: aClass theNonMetaClass name, ' hierarchy' "HierarchyBrowser newFor: Boolean"! ! The Class apes StandardFileStream, but converts the text to HTML before putting it out (primarily intended for printOut). It can be invoked with ((FileStream fileNamed: 'changes.html') asHtml) fileOutChanges Use usual FileStream methods to put out text converted to HTML fairly approximating that text (for best looks, use method:, methodHeader:, methodBody:, for code); verbatim: puts text out without conversion; command: put out HTML items, such as <br>, supplying the brackets. header: and trailer: put out an HTML wrapper (preamble and closing text) nextPut does the actual conversion, nextPutAll: defers characters to nextPut. The code is fairly dumb at present, doing a wooden straightforward conversion of the text without attempting to capture the style or fonts in which the original text was rendered. Tabs are handled awkwardly, using  , so that probably only leading strings are working right. Style sheets now permit us to do a much neater looking job if there is interest in improving the looks of things.! ]style[(1039)f1cred;! !HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/01/1999 13:59'! nextPut: char "Put a character on the file, but translate it first. 4/6/96 tk 1/1/98 acg" char = $< ifTrue: [^ super nextPutAll: '<']. char = $> ifTrue: [^ super nextPutAll: '>']. char = $& ifTrue: [^ super nextPutAll: '&']. char asciiValue = 13 "return" ifTrue: [self command: 'br']. char = $ "tab" ifTrue: [self verbatim: TabThing. ^super nextPut: char]. ^ super nextPut: char! ! !HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/07/1999 09:24'! trailer "append the HTML trailer. Call this just before file close. 4/4/96 tk" | cr | cr _ String with: Character cr. self command: '/BODY'; verbatim: cr. self command: '/HTML'; verbatim: cr. ! ]style[(7 192)f1bcblue;,f1! ! !HtmlFileStream methodsFor: 'read, write, position' stamp: 'acg 01/02/1999 00:38'! verbatim: aString "Put out the string without HTML conversion. 1/1/99 acg" super nextPutAll: aString "'super verbatim:' in the 2.3beta draft didn't perform as expected -- the code was printed with conversion. In a sense, that wouldn't make sense either -- we don't want strictly verbatim printing, just printing without the HTML conversion (that is, skipping around just the nextPut: and nextPutAll: for just this Class). If there were intermediate conversions (say, CRLF!!), we would want those to happen as advertised -- perhaps we should use a differently named selector, perhaps something like nextPutWithoutHTMLConversion:, so that verbatim isn't overridden?"! ! !HtmlFileStream class methodsFor: 'instance creation' stamp: 'acg 01/07/1999 09:24'! newFrom: aFileStream "Answer an HtmlFileStream that is 'like' aFileStream. As a side-effect, the surviving fileStream answered by this method replaces aFileStream on the finalization registry. 1/6/99 acg" |inst| inst _ super newFrom: aFileStream. StandardFileStream unregister: aFileStream. HtmlFileStream register: inst. inst detectLineEndConvention. ^inst ! ! !HtmlFileStream class methodsFor: 'class initialization' stamp: 'acg 01/01/1999 13:57'! initialize "HtmlFileStream initialize" TabThing _ '   ' "I took Ted's suggestion to use  , which works far better for the HTML. Style sheets provide an alternative, possibly better, solution since they permit finer-grain control of the HTML formatting, and thus would permit capturing the style in which text was originally rendered. Internal tabbings would still get lost. 1/1/99 acg."! ! A "Simple Button" in which the appearance is provided by a Form.! !IconicButton methodsFor: 'as yet unclassified' stamp: 'sw 9/28/1999 20:42'! addLabelItemsTo: aCustomMenu hand: aHandMorph "don't do the inherited behavior, since there is no textual label in this case"! ! !IconicButton methodsFor: 'as yet unclassified' stamp: 'jm 10/19/2002 10:09'! initialize super initialize. self useSquareCorners. ! ! !IconicButton methodsFor: 'as yet unclassified' stamp: 'di 2/17/2000 20:30'! labelGraphic: aForm | oldLabel graphicalMorph | (oldLabel _ self findA: SketchMorph) ifNotNil: [oldLabel delete]. graphicalMorph _ SketchMorph withForm: aForm. self extent: graphicalMorph extent + (borderWidth + 6). graphicalMorph position: self center - (graphicalMorph extent // 2). self addMorph: graphicalMorph. graphicalMorph lock ! ! !IconicButton methodsFor: 'as yet unclassified' stamp: 'jm 1/11/2003 08:55'! setDefaultLabel self labelGraphic: SketchMorph paintingForm. ! ! !IdentityDictionary methodsFor: 'private' stamp: 'di 12/1/1999 20:54'! 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." self associationsDo: [:association | value == association value ifTrue: [^ association key]]. ^ exceptionBlock value! ! I am used to display a simple image with no rotation or scaling. I'm often used to create icons, halo handles, or simple buttons. form -- a Form or ColorForm; the image that I draw transparency -- a number (usually a Float) between 0.0 to 1.0 ! !ImageMorph methodsFor: 'initialization' stamp: 'jm 6/30/2003 18:00'! initialize super initialize. self form: DefaultForm. transparency _ 1.0. ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 11/13/2002 10:59'! color: aColor "If my Form is one bit deep, change its non-transparent pixels to the given color. The color must be a solid color, not a stipple." (form depth = 1 and: [aColor isColor]) ifTrue: [ color _ aColor. form colors: (Array with: Color transparent with: aColor). self changed]. ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 11/13/2002 11:00'! form ^ form ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 11/13/2002 11:00'! form: aForm "Set my image to the given Form. If it is a 1-bit Form, treat white pixels as transparent." self changed. aForm depth = 1 ifTrue: [form _ ColorForm mappingWhiteToTransparentFrom: aForm] ifFalse: [form _ aForm]. super extent: form extent. ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 6/30/2003 18:02'! transparency ^ transparency ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 6/30/2003 18:04'! transparency: aNumber transparency _ aNumber. self changed. ! ! !ImageMorph methodsFor: 'other' stamp: 'jm 6/30/2003 18:00'! drawOn: aCanvas "Draw my image. If transparency is between 0.0 and 1.0, display with alpha blending. If transparency is 0.0, don't draw at all." | alpha | transparency ifNil: [transparency _ 1.0]. "backward compatability" transparency < 1.0 ifTrue: [ transparency > 0.0 ifTrue: [ alpha _ (255.0 * transparency) truncated. aCanvas paintImage: form at: bounds origin sourceRect: form boundingBox alpha: alpha]. ^ self]. aCanvas paintImage: form at: bounds origin. ! ! !ImageMorph methodsFor: 'other' stamp: 'jm 11/13/2002 10:59'! releaseCachedState super releaseCachedState. form hibernate. ! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:00'! includeInNewMorphMenu ^ true ! ! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. I am an abstract class to provide for encoding and/or decoding an image on a stream. Instance Variables: stream <ReadStream | WriteStream> stream for image storage Subclasses must implement the following messages: nextImage nextPutImage: Subclasses typically also implement: understandsImageFormat ! !ImageReadWriter methodsFor: 'accessing'! nextImage "Dencoding an image on stream and answer the image." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'accessing'! nextPutImage: anImage "Encoding anImage on stream." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'stream access'! atEnd ^stream atEnd! ! !ImageReadWriter methodsFor: 'stream access'! close "close if you can" (stream respondsTo: #close) ifTrue: [ stream closed ifFalse: [stream close]]! ! !ImageReadWriter methodsFor: 'stream access'! contents ^stream contents! ! !ImageReadWriter methodsFor: 'stream access'! cr ^stream nextPut: Character cr asInteger! ! !ImageReadWriter methodsFor: 'stream access'! lf "PPM and PBM are used LF as CR." ^stream nextPut: Character lf asInteger! ! !ImageReadWriter methodsFor: 'stream access'! next ^stream next! ! !ImageReadWriter methodsFor: 'stream access'! next: size ^stream next: size! ! !ImageReadWriter methodsFor: 'stream access'! nextLong "Read a 32-bit quantity from the input stream." ^(stream next bitShift: 24) + (stream next bitShift: 16) + (stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access'! nextPut: aByte ^stream nextPut: aByte! ! !ImageReadWriter methodsFor: 'stream access'! nextPutAll: aByteArray ^stream nextPutAll: aByteArray! ! !ImageReadWriter methodsFor: 'stream access'! nextWord "Read a 16-bit quantity from the input stream." ^(stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access'! nextWordPut: a16BitW "Write out a 16-bit integer as 16 bits." stream nextPut: ((a16BitW bitShift: -8) bitAnd: 16rFF). stream nextPut: (a16BitW bitAnd: 16rFF). ^a16BitW! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'! peekFor: aValue ^stream peekFor: aValue! ! !ImageReadWriter methodsFor: 'stream access'! position ^stream position! ! !ImageReadWriter methodsFor: 'stream access'! position: anInteger ^stream position: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! size ^stream size! ! !ImageReadWriter methodsFor: 'stream access'! skip: anInteger ^stream skip: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! space ^stream nextPut: Character space asInteger! ! !ImageReadWriter methodsFor: 'stream access'! tab ^stream nextPut: Character tab asInteger! ! !ImageReadWriter methodsFor: 'private' stamp: 'di 9/15/1998 11:42'! on: aStream (stream _ aStream) reset. (stream respondsTo: #binary) ifTrue: [stream binary]. "Note that 'reset' makes a file be text. Must do this after."! ! !ImageReadWriter methodsFor: 'testing' stamp: 'tao 10/27/97 09:26'! understandsImageFormat "Test to see if the image stream format is understood by this decoder. This should be implemented in each subclass of ImageReadWriter so that a proper decoder can be selected without ImageReadWriter having to know about all possible image file types." ^ false! ! !ImageReadWriter class methodsFor: 'instance creation'! on: aStream "Answer an instance of the receiver for encoding and/or decoding images on the given." ^ self new on: aStream ! ! !ImageReadWriter class methodsFor: 'image reading/writing' stamp: 'ls 9/15/1998 19:10'! formFromStream: aBinaryStream "Answer a ColorForm stored on the given stream. closes the stream" | reader readerClass form | readerClass _ self withAllSubclasses detect: [:subclass | aBinaryStream reset. (subclass new on: aBinaryStream) understandsImageFormat] ifNone: [ (aBinaryStream respondsTo: #close) ifTrue: [ aBinaryStream close ]. ^self error: 'image format not recognized']. reader _ readerClass new on: aBinaryStream reset. Cursor read showWhile: [ form _ reader nextImage. reader close]. ^ form ! ! !ImageReadWriter class methodsFor: 'image reading/writing'! putForm: aForm onFileNamed: fileName "Store the given form on a file of the given name." | writer | writer _ self on: (FileStream newFileNamed: fileName) binary. Cursor write showWhile: [writer nextPutImage: aForm]. writer close. ! ! I represent a Form obtained by replicating a pattern form indefinitely in all directions.! !InfiniteForm methodsFor: 'displaying' stamp: 'jm 5/29/2003 18:01'! displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm "This is the real display message, but it doesn't get used until the new display protocol is installed." | targetBox patternBox bb | (patternForm isKindOf: Form) ifFalse: [^ aDisplayMedium fill: clipRectangle rule: ruleInteger fillColor: patternForm]. "Do it iteratively" targetBox _ aDisplayMedium boundingBox intersect: clipRectangle. patternBox _ patternForm boundingBox. bb _ BitBlt destForm: aDisplayMedium sourceForm: patternForm fillColor: aForm combinationRule: ruleInteger destOrigin: 0@0 sourceOrigin: 0@0 extent: patternBox extent clipRect: clipRectangle. bb colorMap: (patternForm colormapIfNeededForDepth: aDisplayMedium depth). (targetBox left truncateTo: patternBox width) to: targetBox right - 1 by: patternBox width do: [:x | (targetBox top truncateTo: patternBox height) to: targetBox bottom - 1 by: patternBox height do: [:y | bb destOrigin: x@y; copyBits]]! ! !InfiniteForm methodsFor: 'displaying' stamp: 'jm 5/12/2003 19:58'! displayUsingBitBlt: aBitBlt at: offset | targetBox patternBox savedMap top left | (patternForm isKindOf: Form) ifFalse: [ "patternForm is a Pattern or Color; just use it as a mask for BitBlt" ^ aBitBlt fill: aBitBlt clipRect fillColor: patternForm rule: Form over]. "do it iteratively" targetBox _ aBitBlt clipRect. patternBox _ patternForm boundingBox. savedMap _ aBitBlt colorMap. aBitBlt sourceForm: patternForm; fillColor: nil; combinationRule: Form over; sourceRect: (0@0 extent: patternBox extent); colorMap: (patternForm colormapIfNeededForDepth: aBitBlt destForm depth). top _ (targetBox top truncateTo: patternBox height) - (offset y \\ patternBox height). left _ (targetBox left truncateTo: patternBox width) - (offset x \\ patternBox width). left to: (targetBox right - 1) by: patternBox width do: [:x | top to: (targetBox bottom - 1) by: patternBox height do: [:y | aBitBlt destOrigin: x@y; copyBits]]. aBitBlt colorMap: savedMap. ! ! !InfiniteForm methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:20'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^ 0@0 corner: SmallInteger maxVal @ SmallInteger maxVal ! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'! bitPatternForDepth: suspectedDepth ^ patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! direction ^patternForm width @ 0! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! form "Bitmap fills respond to #form" ^patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 9/2/1999 14:32'! isTranslucent "Return true since the bitmap may be translucent and we don't really want to check" ^true! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:57'! normal ^0 @ patternForm height! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin ^0@0! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin: aPoint "Ignored" ! ! This class implements the Inflate decompression algorithm as defined by RFC1951 and used in PKZip, GZip and ZLib (and many, many more). It is a variant of the LZ77 compression algorithm described in [LZ77] Ziv J., Lempel A., "A Universal Algorithm for Sequential Data Compression", IEEE Transactions on Information Theory", Vol. 23, No. 3, pp. 337-343. [RFC1951] Deutsch. P, "DEFLATE Compressed Data Format Specification version 1.3" For more information see the above mentioned RFC 1951 which can for instance be found at http://www.leo.org/pub/comp/doc/standards/rfc/index.html Huffman Tree Implementation Notes: =========================================== The huffman tree used for decoding literal, distance and length codes in the inflate algorithm has been encoded in a single Array. The tree is made up of subsequent tables storing all entries at the current bit depth. Each entry in the table (e.g., a 32bit Integer value) is either a leaf or a non-leaf node. Leaf nodes store the immediate value in its low 16 bits whereas non-leaf nodes store the offset of the subtable in its low 16bits. The high 8 bits of non-leaf nodes contain the number of additional bits needed for the sub table (the high 8 bits of leaf-nodes are always zero). The first entry in each table is always a non-leaf node indicating how many bits we need to fetch initially. We can thus travel down the tree as follows (written in sort-of-pseudocode the actual implementation can be seen in InflateStream>>decodeValueFrom:): table _ initialTable. bitsNeeded _ high 8 bits of (table at: 1). "Determine initial bits" table _ initialTable + (low 16 bits of (table at: 1)). "Determine start of first real table" [bits _ fetch next bitsNeeded bits. "Grab the bits" value _ table at: bits. "Lookup the value" value has high 8 bit set] whileTrue:[ "Check if it's leaf" table _ initialTable + (low 16 bits of value). "No - compute new sub table start" bitsNeeded _ high 8 bit of value]. "Compute additional number of bits needed" ^value ! !InflateStream methodsFor: 'initialize' stamp: 'jm 6/6/2003 07:39'! on: aCollectionOrStream (aCollectionOrStream isKindOf: Stream) ifTrue: [ sourceStream _ aCollectionOrStream. self getFirstBuffer] ifFalse: [ source _ aCollectionOrStream]. ^ self on: source from: 1 to: source size ! ! !InflateStream methodsFor: 'initialize' stamp: 'ar 12/23/1999 15:35'! on: aCollection from: firstIndex to: lastIndex bitBuf _ bitPos _ 0. "The decompression buffer has a size of at 64k, since we may have distances up to 32k back and repetitions of at most 32k length forward" collection _ aCollection species new: 1 << 16. readLimit _ 0. "Not yet initialized" position _ 0. source _ aCollection. sourceLimit _ lastIndex. sourcePos _ firstIndex-1. state _ StateNewBlock.! ! !InflateStream methodsFor: 'initialize' stamp: 'ar 12/3/1998 16:32'! reset "Position zero - nothing decoded yet" position _ readLimit _ 0. sourcePos _ 0. bitBuf _ bitPos _ 0. state _ 0.! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! close sourceStream ifNotNil:[sourceStream close].! ! !InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'! contents ^ self upToEnd! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 01:29'! next "Answer the next decompressed object in the Stream represented by the receiver." <primitive: 65> position >= readLimit ifTrue: [^self pastEndRead] ifFalse: [^collection at: (position _ position + 1)]! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:18'! next: anInteger "Answer the next anInteger elements of my collection. overriden for simplicity" | newArray | newArray _ collection species new: anInteger. 1 to: anInteger do: [:index | newArray at: index put: self next]. ^newArray! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 16:06'! next: n into: buffer startingAt: startIndex "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." | c numRead count | numRead _ 0. ["Force decompression if necessary" (c _ self next) == nil ifTrue:[^buffer copyFrom: 1 to: startIndex+numRead-1]. "Store the first value which provoked decompression" buffer at: startIndex + numRead put: c. numRead _ numRead + 1. "After collection has been filled copy as many objects as possible" count _ (readLimit - position) min: (n - numRead). buffer replaceFrom: startIndex + numRead to: startIndex + numRead + count - 1 with: collection startingAt: position+1. position _ position + count. numRead _ numRead + count. numRead = n] whileFalse. ^buffer! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! size "This is a compressed stream - we don't know the size beforehand" ^self shouldNotImplement! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:54'! sourceLimit ^sourceLimit! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'! sourcePosition ^sourcePos! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! sourceStream ^sourceStream! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/3/1998 16:19'! upTo: anObject "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of anObject in the receiver. If anObject is not in the collection, answer the entire rest of the receiver." | newStream element | newStream _ WriteStream on: (collection species new: 100). [self atEnd or: [(element _ self next) = anObject]] whileFalse: [newStream nextPut: element]. ^newStream contents! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/22/1999 02:04'! upToEnd "Answer a subcollection from the current access position through the last element of the receiver." | newStream buffer | buffer _ collection species new: 1000. newStream _ WriteStream on: (collection species new: 100). [self atEnd] whileFalse: [newStream nextPutAll: (self nextInto: buffer)]. ^ newStream contents! ! !InflateStream methodsFor: 'testing' stamp: 'ar 12/27/1999 13:43'! atEnd "Note: It is possible that we have a few bits left, representing just the EOB marker. To check for this we must force decompression of the next block if at end of data." super atEnd ifFalse:[^false]. "Primitive test" (position >= readLimit and:[state = StateNoMoreData]) ifTrue:[^true]. "Force decompression, by calling #next. Since #moveContentsToFront will never move data to the beginning of the buffer it is safe to skip back the read position afterwards" self next == nil ifTrue:[^true]. position _ position - 1. ^false! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 02:24'! decodeValueFrom: table "Decode the next value in the receiver using the given huffman table." | bits bitsNeeded tableIndex value | bitsNeeded _ (table at: 1) bitShift: -24. "Initial bits needed" tableIndex _ 2. "First real table" [bits _ self nextSingleBits: bitsNeeded. "Get bits" value _ table at: (tableIndex + bits). "Lookup entry in table" (value bitAnd: 16r3F000000) = 0] "Check if it is a non-leaf node" whileFalse:["Fetch sub table" tableIndex _ value bitAnd: 16rFFFF. "Table offset in low 16 bit" bitsNeeded _ (value bitShift: -24) bitAnd: 255. "Additional bits in high 8 bit" bitsNeeded > MaxBits ifTrue:[^self error:'Invalid huffman table entry']]. ^value! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 3/15/1999 15:38'! decompressBlock: llTable with: dTable "Process the compressed data in the block. llTable is the huffman table for literal/length codes and dTable is the huffman table for distance codes." | value extra length distance oldPos oldBits oldBitPos | [readLimit < collection size and:[sourcePos <= sourceLimit]] whileTrue:[ "Back up stuff if we're running out of space" oldBits _ bitBuf. oldBitPos _ bitPos. oldPos _ sourcePos. value _ self decodeValueFrom: llTable. value < 256 ifTrue:[ "A literal" collection byteAt: (readLimit _ readLimit + 1) put: value. ] ifFalse:["length/distance or end of block" value = 256 ifTrue:["End of block" state _ state bitAnd: StateNoMoreData. ^self]. "Compute the actual length value (including possible extra bits)" extra _ #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0) at: value - 256. length _ #(3 4 5 6 7 8 9 10 11 13 15 17 19 23 27 31 35 43 51 59 67 83 99 115 131 163 195 227 258) at: value - 256. extra > 0 ifTrue:[length _ length + (self nextBits: extra)]. "Compute the distance value" value _ self decodeValueFrom: dTable. extra _ #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13) at: value+1. distance _ #(1 2 3 4 5 7 9 13 17 25 33 49 65 97 129 193 257 385 513 769 1025 1537 2049 3073 4097 6145 8193 12289 16385 24577) at: value+1. extra > 0 ifTrue:[distance _ distance + (self nextBits: extra)]. (readLimit + length >= collection size) ifTrue:[ bitBuf _ oldBits. bitPos _ oldBitPos. sourcePos _ oldPos. ^self]. collection replaceFrom: readLimit+1 to: readLimit + length + 1 with: collection startingAt: readLimit - distance + 1. readLimit _ readLimit + length. ]. ].! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedDynamicBlock self decompressBlock: litTable with: distTable! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedFixedBlock self decompressBlock: litTable with: distTable! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! proceedStoredBlock "Proceed decompressing a stored (e.g., uncompressed) block" | length decoded | "Literal table must be nil for a stored block" litTable == nil ifFalse:[^self error:'Bad state']. length _ distTable. [length > 0 and:[readLimit < collection size and:[sourcePos < sourceLimit]]] whileTrue:[ collection at: (readLimit _ readLimit + 1) put: (source at: (sourcePos _ sourcePos + 1)). length _ length - 1]. length = 0 ifTrue:[state _ state bitAnd: StateNoMoreData]. decoded _ length - distTable. distTable _ length. ^decoded! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 01:46'! processDynamicBlock | nLit nDist nLen codeLength lengthTable bits | nLit _ (self nextBits: 5) + 257. nDist _ (self nextBits: 5) + 1. nLen _ (self nextBits: 4) + 4. codeLength _ Array new: 19. codeLength atAllPut: 0. 1 to: nLen do:[:i| bits _ #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15) at: i. codeLength at: bits+1 put: (self nextBits: 3). ]. lengthTable _ self huffmanTableFrom: codeLength mappedBy: nil. "RFC 1951: In other words, all code lengths form a single sequence..." codeLength _ self decodeDynamicTable: nLit+nDist from: lengthTable. litTable _ self huffmanTableFrom: (codeLength copyFrom: 1 to: nLit) mappedBy: self literalLengthMap. distTable _ self huffmanTableFrom: (codeLength copyFrom: nLit+1 to: codeLength size) mappedBy: self distanceMap. state _ state bitOr: BlockProceedBit. self proceedDynamicBlock.! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/4/1998 19:13'! processFixedBlock litTable _ self huffmanTableFrom: FixedLitCodes mappedBy: self literalLengthMap. distTable _ self huffmanTableFrom: FixedDistCodes mappedBy: self distanceMap. state _ state bitOr: BlockProceedBit. self proceedFixedBlock.! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/27/1999 13:49'! processStoredBlock | chkSum length | "Skip to byte boundary" self nextBits: (bitPos bitAnd: 7). length _ self nextBits: 16. chkSum _ self nextBits: 16. (chkSum bitXor: 16rFFFF) = length ifFalse:[^self error:'Bad block length']. litTable _ nil. distTable _ length. state _ state bitOr: BlockProceedBit. ^self proceedStoredBlock! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! decompressAll "Profile the decompression speed" [self atEnd] whileFalse:[ position _ readLimit. self next "Provokes decompression" ].! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:15'! getFirstBuffer "Get the first source buffer after initialization has been done" sourceStream == nil ifTrue:[^self]. source _ sourceStream next: 1 << 16. "This is more than enough..." sourceLimit _ source size.! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/3/1998 17:32'! getNextBlock ^self nextBits: 3! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:17'! moveContentsToFront "Move the decoded contents of the receiver to the front so that we have enough space for decoding more data." | delta | readLimit > 32768 ifTrue:[ delta _ readLimit - 32767. collection replaceFrom: 1 to: collection size - delta + 1 with: collection startingAt: delta. position _ position - delta + 1. readLimit _ readLimit - delta + 1].! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/23/1999 15:27'! moveSourceToFront "Move the encoded contents of the receiver to the front so that we have enough space for decoding more data." (sourceStream == nil or:[sourceStream atEnd]) ifTrue:[^self]. sourcePos > 10000 ifTrue:[ source replaceFrom: 1 to: source size - sourcePos with: source startingAt: sourcePos + 1. source _ sourceStream next: sourcePos into: source startingAt: source size - sourcePos + 1. sourcePos _ 0. sourceLimit _ source size].! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/27/1999 15:25'! pastEndRead "A client has attempted to read beyond the read limit. Check in what state we currently are and perform the appropriate action" | blockType | state = StateNoMoreData ifTrue:[^nil]. "Get out early if possible" "Check if we can move decoded data to front" self moveContentsToFront. "Check if we can fetch more source data" self moveSourceToFront. state = StateNewBlock ifTrue:[state _ self getNextBlock]. blockType _ state bitShift: -1. self perform: (BlockTypes at: blockType+1). ^self next! ! !InflateStream methodsFor: 'private' stamp: 'ar 12/4/1998 02:03'! profile "Profile the decompression speed" MessageTally spyOn:[self decompressAll].! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/21/1999 22:59'! computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits "Assign numerical values to all codes. Note: The values are stored according to the bit length" | offsets values baseOffset codeLength | offsets _ Array new: maxBits. offsets atAllPut: 0. baseOffset _ 1. minBits to: maxBits do:[:bits| offsets at: bits put: baseOffset. baseOffset _ baseOffset + (counts at: bits+1)]. values _ WordArray new: aCollection size. 1 to: aCollection size do:[:i| codeLength _ aCollection at: i. codeLength > 0 ifTrue:[ baseOffset _ offsets at: codeLength. values at: baseOffset put: i-1. offsets at: codeLength put: baseOffset + 1]]. ^values! ! !InflateStream methodsFor: 'huffman trees' stamp: 'sma 5/12/2000 10:49'! createHuffmanTables: values counts: counts from: minBits to: maxBits "Create the actual tables" | table tableStart tableSize tableEnd valueIndex tableStack numValues deltaBits maxEntries lastTable lastTableStart tableIndex lastTableIndex | table _ WordArray new: ((4 bitShift: minBits) max: 16). "Create the first entry - this is a dummy. It gives us information about how many bits to fetch initially." table at: 1 put: (minBits bitShift: 24) + 2. "First actual table starts at index 2" "Create the first table from scratch." tableStart _ 2. "See above" tableSize _ 1 bitShift: minBits. tableEnd _ tableStart + tableSize. "Store the terminal symbols" valueIndex _ (counts at: minBits+1). tableIndex _ 0. 1 to: valueIndex do:[:i| table at: tableStart + tableIndex put: (values at: i). tableIndex _ self increment: tableIndex bits: minBits]. "Fill up remaining entries with invalid entries" tableStack _ OrderedCollection new: 10. "Should be more than enough" tableStack addLast: (Array with: minBits "Number of bits (e.g., depth) for this table" with: tableStart "Start of table" with: tableIndex "Next index in table" with: minBits "Number of delta bits encoded in table" with: tableSize - valueIndex "Entries remaining in table"). "Go to next value index" valueIndex _ valueIndex + 1. "Walk over remaining bit lengths and create new subtables" minBits+1 to: maxBits do:[:bits| numValues _ counts at: bits+1. [numValues > 0] whileTrue:["Create a new subtable" lastTable _ tableStack last. lastTableStart _ lastTable at: 2. lastTableIndex _ lastTable at: 3. deltaBits _ bits - (lastTable at: 1). "Make up a table of deltaBits size" tableSize _ 1 bitShift: deltaBits. tableStart _ tableEnd. tableEnd _ tableEnd + tableSize. [tableEnd > table size ] whileTrue:[table _ self growHuffmanTable: table]. "Connect to last table" self assert:[(table at: lastTableStart + lastTableIndex) = 0]."Entry must be unused" table at: lastTableStart + lastTableIndex put: (deltaBits bitShift: 24) + tableStart. lastTable at: 3 put: (self increment: lastTableIndex bits: (lastTable at: 4)). lastTable at: 5 put: (lastTable at: 5) - 1. self assert:[(lastTable at: 5) >= 0]. "Don't exceed tableSize" "Store terminal values" maxEntries _ numValues min: tableSize. tableIndex _ 0. 1 to: maxEntries do:[:i| table at: tableStart + tableIndex put: (values at: valueIndex). valueIndex _ valueIndex + 1. numValues _ numValues - 1. tableIndex _ self increment: tableIndex bits: deltaBits]. "Check if we have filled up the current table completely" maxEntries = tableSize ifTrue:[ "Table has been filled. Back up to the last table with space left." [tableStack isEmpty not and:[(tableStack last at: 5) = 0]] whileTrue:[tableStack removeLast]. ] ifFalse:[ "Table not yet filled. Put it back on the stack." tableStack addLast: (Array with: bits "Nr. of bits in this table" with: tableStart "Start of table" with: tableIndex "Index in table" with: deltaBits "delta bits of table" with: tableSize - maxEntries "Unused entries in table"). ]. ]. ]. ^table copyFrom: 1 to: tableEnd-1! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:25'! decodeDynamicTable: nItems from: aHuffmanTable "Decode the code length of the literal/length and distance table in a block compressed with dynamic huffman trees" | values index value repCount theValue | values _ Array new: nItems. index _ 1. theValue _ 0. [index <= nItems] whileTrue:[ value _ self decodeValueFrom: aHuffmanTable. value < 16 ifTrue:[ "Immediate values" theValue _ value. values at: index put: value. index _ index+1. ] ifFalse:[ "Repeated values" value = 16 ifTrue:[ "Repeat last value" repCount _ (self nextBits: 2) + 3. ] ifFalse:[ "Repeat zero value" theValue _ 0. value = 17 ifTrue:[repCount _ (self nextBits: 3) + 3] ifFalse:[value = 18 ifTrue:[repCount _ (self nextBits: 7) + 11] ifFalse:[^self error:'Invalid bits tree value']]]. 0 to: repCount-1 do:[:i| values at: index+i put: theValue]. index _ index + repCount]. ]. ^values! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:51'! distanceMap "This is used by the fast decompressor" ^nil! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/3/1998 13:16'! growHuffmanTable: table | newTable | newTable _ table species new: table size * 2. newTable replaceFrom: 1 to: table size with: table startingAt: 1. ^newTable! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:27'! huffmanTableFrom: aCollection mappedBy: valueMap "Create a new huffman table from the given code lengths. Map the actual values by valueMap if it is given. See the class comment for a documentation of the huffman tables used in this decompressor." | counts values table minBits maxBits | minBits _ MaxBits + 1. maxBits _ 0. "Count the occurences of each code length and compute minBits and maxBits" counts _ Array new: MaxBits+1. counts atAllPut: 0. aCollection do:[:length| length > 0 ifTrue:[ length < minBits ifTrue:[minBits _ length]. length > maxBits ifTrue:[maxBits _ length]. counts at: length+1 put: (counts at: length+1)+1]]. maxBits = 0 ifTrue:[^nil]. "Empty huffman table" "Assign numerical values to all codes." values _ self computeHuffmanValues: aCollection counts: counts from: minBits to: maxBits. "Map the values if requested" self mapValues: values by: valueMap. "Create the actual tables" table _ self createHuffmanTables: values counts: counts from: minBits to: maxBits. ^table! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:48'! increment: value bits: nBits "Increment a value of nBits length. The fast decompressor will do this differently" ^value+1! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 01:50'! literalLengthMap "This is used by the fast decompressor" ^nil! ! !InflateStream methodsFor: 'huffman trees' stamp: 'ar 12/4/1998 02:28'! mapValues: values by: valueMap | oldValue | valueMap ifNil:[^values]. 1 to: values size do:[:i| oldValue _ values at: i. "Note: there may be nil values if not all values are used" oldValue isNil ifTrue:[^values] ifFalse:[values at: i put: (valueMap at: oldValue+1)]]. ! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/27/1999 13:47'! bitPosition "Return the current bit position of the source" sourceStream == nil ifTrue:[^sourcePos * 8 + bitPos] ifFalse:[^sourceStream position + sourcePos * 8 + bitPos]! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:00'! nextBits: n | bits | [bitPos < n] whileTrue:[ bitBuf _ bitBuf + (self nextByte bitShift: bitPos). bitPos _ bitPos + 8]. bits _ bitBuf bitAnd: (1 bitShift: n)-1. bitBuf _ bitBuf bitShift: 0 - n. bitPos _ bitPos - n. ^bits! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/5/1998 14:54'! nextByte ^source byteAt: (sourcePos _ sourcePos + 1)! ! !InflateStream methodsFor: 'bit access' stamp: 'ar 12/4/1998 02:01'! nextSingleBits: n | out | out _ 0. 1 to: n do:[:i| out _ (out bitShift: 1) + (self nextBits: 1)]. ^out! ! !InflateStream class methodsFor: 'class initialization' stamp: 'ar 12/4/1998 19:12'! initialize "InflateStream initialize" MaxBits _ 16. StateNewBlock _ 0. StateNoMoreData _ 1. BlockProceedBit _ 8. BlockTypes _ #( processStoredBlock "New block in stored format" processFixedBlock "New block with fixed huffman tables" processDynamicBlock "New block with dynamic huffman tables" errorBadBlock "Bad block format" proceedStoredBlock "Continue block in stored format" proceedFixedBlock "Continue block in fixed format" proceedDynamicBlock "Continue block in dynamic format" errorBadBlock "Bad block format"). "Initialize fixed block values" FixedLitCodes _ ((1 to: 144) collect:[:i| 8]), ((145 to: 256) collect:[:i| 9]), ((257 to: 280) collect:[:i| 7]), ((281 to: 288) collect:[:i| 8]). FixedDistCodes _ ((1 to: 32) collect:[:i| 5]).! ! I represent an interface to the user input devices. There is at least one instance of me named Sensor in the system.! !InputSensor methodsFor: 'modifier keys' stamp: 'di 9/28/1999 08:29'! anyModifierKeyPressed "ignore, however, the shift keys 'cause that's not REALLY a command key" ^ self primMouseButtons anyMask: 16r70 "cmd | opt | ctrl"! ! !InputSensor methodsFor: 'modifier keys' stamp: 'bf 9/22/1999 15:47'! macOptionKeyPressed "Answer whether the option key on the Macintosh keyboard is being held down. Macintosh specific." Preferences macOptionKeyAllowed ifFalse: [self notify: 'Portability note: InputSensor>>macOptionKeyPressed is not portable. Please use InputSensor>>yellowButtonPressed instead!!']. ^ self primMouseButtons anyMask: 32! ! !InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:59'! blueButtonPressed "Answer whether only the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^self buttons = 1! ! !InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:43'! redButtonPressed "Answer true if the red mouse button is being pressed. This is the first mouse button." ^self buttons = 4! ! !InputSensor methodsFor: 'mouse' stamp: 'bf 11/1/1999 20:12'! waitButton "Wait for the user to press any mouse button and then answer with the current location of the cursor." [self anyButtonPressed] whileFalse: [(Delay forMilliseconds: 50) wait]. ^self cursorPoint! ! !InputSensor methodsFor: 'mouse' stamp: 'sma 5/28/2000 12:04'! waitButtonOrKeyboard "Wait for the user to press either any mouse button or any key. Answer the current cursor location or nil if a keypress occured." [self anyButtonPressed] whileFalse: [(Delay forMilliseconds: 50) wait. self keyboardPressed ifTrue: [^ nil]]. ^ self cursorPoint! ! !InputSensor methodsFor: 'mouse' stamp: 'bf 11/1/1999 20:22'! waitNoButton "Wait for the user to release any mouse button and then answer with the current location of the cursor." [self anyButtonPressed] whileTrue: [(Delay forMilliseconds: 50) wait]. ^self cursorPoint! ! !InputSensor methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:43'! yellowButtonPressed "Answer whether only the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^self buttons = 2! ! !InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:15'! currentCursor "The current cursor is maintained in class Cursor." ^ Cursor currentCursor! ! !InputSensor methodsFor: 'cursor' stamp: 'di 4/13/2000 12:16'! currentCursor: newCursor "The current cursor is maintained in class Cursor." Cursor currentCursor: newCursor.! ! !InputSensor methodsFor: 'joystick' stamp: 'di 4/13/1999 14:32'! testJoystick: index "Sensor testJoystick: 3" | f pt buttons status | f _ Form extent: 110@50. [Sensor anyButtonPressed] whileFalse: [ pt _ Sensor joystickXY: index. buttons _ Sensor joystickButtons: index. status _ 'xy: ', pt printString, ' buttons: ', buttons hex. f fillWhite. status displayOn: f at: 10@10. f displayOn: Display at: 10@10. ]. ! ! !InputSensor methodsFor: 'user interrupts' stamp: 'di 2/4/1999 15:24'! userInterruptWatcher "Wait for user interrupts and open a notifier on the active process when one occurs." [true] whileTrue: [ InterruptSemaphore wait. Display deferUpdates: false. Smalltalk at: #SoundPlayer ifPresent: [:theClass | theClass shutDown]. Smalltalk handleUserInterrupt] ! ! !InputSensor methodsFor: 'private' stamp: 'jm 5/8/2003 19:10'! fileDropPoint "Answer the point a which a file (or files) were dropped or nil if no file has been dropped. Requires Squeak VM version 3.1 or later." | evtBuf | evtBuf _ Array new: 8. [true] whileTrue: [ evtBuf at: 1 put: 0. Sensor primGetNextEvent: evtBuf. evtBuf first = 0 ifTrue: [^ nil]. (evtBuf first = 3 and: [(evtBuf at: 3) = 4]) ifTrue: [ ^ (evtBuf at: 4) @ (evtBuf at: 5)]]. ! ! !InputSensor methodsFor: 'private' stamp: 'jm 5/4/2003 08:26'! primGetNextEvent: array "Store the next OS event available into the given 8-element array. This primitive was added around Squeak version 2.9." "The event structure is for file drop events is: <type=3><timestamp><subtype><x><y><0><count><0> The subtypes are: 1=start, 2=move, 3=end, 4=dropped" <primitive: 94> ! ! !InputSensor methodsFor: 'private' stamp: 'jm 4/12/1999 13:04'! primTabletGetParameters: cursorIndex "Answer the pen tablet parameters. For parameters that differ from cursor to cursor, answer those associated with the cursor having the given index. Answer nil if there is no pen tablet. The parameters are: 1. tablet width, in tablet units 2. tablet height, in tablet units 3. number of tablet units per inch 4. number of cursors (pens, pucks, etc; some tablets have more than one) 5. this cursor index 6. and 7. x scale and x offset for scaling tablet coordintes (e.g., to fit the screen) 8. and 9. y scale and y offset for scaling tablet coordintes (e.g., to fit the screen) 10. number of pressure levels 11. presure threshold needed close pen tip switch 12. number of pen tilt angles" <primitive: 548> ^ nil ! ! !InputSensor methodsFor: 'private' stamp: 'jm 4/10/1999 22:57'! primTabletRead: cursorIndex "Answer the pen tablet data for the cursor having the given index. Answer nil if there is no pen tablet. The data is: 1. index of the cursor to which this data applies 2. timestamp of the last state chance for this cursor 3., 4., and 5. x, y, and z coordinates of the cursor (z is typically 0) 6. and 7. xTilt and yTilt of the cursor; (signed) 8. type of cursor (0 = unknown, 1 = pen, 2 = puck, 3 = eraser) 9. cursor buttons 10. cursor pressure, downward 11. cursor pressure, tangential 12. flags" <primitive: 549> self primitiveFailed ! ! !InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 22:14'! hasTablet "Answer true if there is a pen tablet available on this computer." ^ (self primTabletGetParameters: 1) notNil ! ! !InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:02'! tabletExtent "Answer the full tablet extent in tablet coordinates." | params | params _ self primTabletGetParameters: 1. params ifNil: [^ self error: 'no tablet available']. ^ (params at: 1)@(params at: 2) ! ! !InputSensor methodsFor: 'tablet' stamp: 'jm 4/13/1999 11:12'! tabletPoint "Answer the current position of the first tablet pointing device (pen, puck, or eraser) in tablet coordinates." | data | data _ self primTabletRead: 1. "state of first/primary pen" ^ (data at: 3) @ (data at: 4) ! ! !InputSensor methodsFor: 'tablet' stamp: 'jm 4/12/1999 13:05'! tabletPressure "Answer the current pressure of the first tablet pointing device (pen, puck, or eraser), a number between 0.0 (no pressure) and 1.0 (max pressure)" | params data | params _ self primTabletGetParameters: 1. params ifNil: [^ self]. data _ self primTabletRead: 1. "state of first/primary pen" ^ (data at: 10) asFloat / ((params at: 10) - 1) ! ! !InputSensor methodsFor: 'tablet' stamp: 'jm 4/10/1999 23:03'! tabletTimestamp "Answer the time (in tablet clock ticks) at which the tablet's primary pen last changed state. This can be used in polling loops; if this timestamp hasn't changed, then the pen state hasn't changed either." | data | data _ self primTabletRead: 1. "state of first/primary pen" ^ data at: 2 ! ! I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.! !Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:57'! modelWakeUpIn: aWindow | newText | self updateListsAndCodeIn: aWindow. newText _ self contentsIsString ifTrue: [newText _ self selection] ifFalse: ["keep it short to reduce time to compute it" self selectionPrintString ]. newText = contents ifFalse: [contents _ newText. self changed: #contents]! ! !Inspector methodsFor: 'accessing' stamp: 'sw 10/30/1999 23:59'! noteSelectionIndex: anInteger for: aSymbol aSymbol == #fieldList ifTrue: [selectionIndex _ anInteger]! ! !Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:57'! stepAt: millisecondClockValue in: aWindow | newText | (Preferences smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds" ifTrue: [self updateListsAndCodeIn: aWindow. timeOfLastListUpdate _ millisecondClockValue]. newText _ self contentsIsString ifTrue: [newText _ self selection] ifFalse: ["keep it short to reduce time to compute it" self selectionPrintString ]. newText = contents ifFalse: [contents _ newText. self changed: #contents]! ! !Inspector methodsFor: 'accessing' stamp: 'sw 10/20/1999 15:54'! timeOfLastListUpdate ^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate _ 0]! ! !Inspector methodsFor: 'accessing' stamp: 'tk 6/11/1998 22:23'! trash: newText "Don't save it" ^ true! ! !Inspector methodsFor: 'accessing' stamp: 'svp 3/14/2000 21:56'! update "Reshow contents, assuming selected value may have changed." selectionIndex = 0 ifFalse: [contents _ self selectionPrintString. self changed: #selection. self changed: #selectionIndex]! ! !Inspector methodsFor: 'accessing' stamp: 'di 1/13/1999 14:36'! wantsSteps ^ true! ! !Inspector methodsFor: 'selecting' stamp: 'jm 11/23/2003 10:45'! accept: aString | result | result _ Compiler new evaluate: (ReadStream on: aString) in: self doItContext to: self doItReceiver notifying: nil "fix this" ifFail: [^ false]. result == #failedDoit ifFalse: [contents _ result printString. self replaceSelectionValue: result. "may put contents back" self changed: #contents. ^ true]. ^ false! ! !Inspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:24'! contentsIsString "Hacked so contents empty when deselected and = long printString when item 2" ^ (selectionIndex = 2) | (selectionIndex = 0)! ! !Inspector methodsFor: 'selecting' stamp: 'hg 10/8/2000 14:46'! selectedSlotName ^ self fieldList at: self selectionIndex! ! !Inspector methodsFor: 'selecting' stamp: 'jm 11/24/2003 18:35'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." | basicIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object]. selectionIndex = 2 ifTrue: [ (object respondsTo: #longPrintString) ifTrue: [^ object longPrintString] ifFalse: [^ '<not supported>']]. (selectionIndex - 2) <= object class instSize ifTrue: [^ object instVarAt: selectionIndex - 2]. basicIndex _ selectionIndex - 2 - object class instSize. (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) ifTrue: [^ object basicAt: basicIndex] ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! ! !Inspector methodsFor: 'selecting' stamp: 'jm 5/22/2003 20:35'! selectionPrintString | text | ^ [self selection printStringLimitedTo: 5000] ifError: [ text _ ('<printing error>') asText. text addAttribute: TextColor red from: 1 to: text size. text] ! ! !Inspector methodsFor: 'selecting' stamp: 'svp 3/14/2000 22:00'! 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. self contentsIsString ifTrue: [contents _ self selection] ifFalse: [contents _ self selectionPrintString]]. self changed: #selection. self changed: #contents. self changed: #selectionIndex.! ! !Inspector methodsFor: 'menu commands' stamp: 'di 4/28/1999 11:33'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1). " | sel aClass | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass _ self object class) isVariable ifTrue: [^ self changed: #flash]. sel _ aClass allInstVarNames at: selectionIndex - 2. (self selection isKindOf: Collection) ifTrue: [sel _ '(',sel,' at: 1)']. ParagraphEditor clipboardTextPut: sel asText. "no undo allowed"! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 10/10/1999 14:34'! defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what currently selected. " | aClass sel | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass _ self object class) isVariable ifTrue: [^ self changed: #flash]. sel _ aClass allInstVarNames at: self selectionIndex - 2. aClass browseAllStoresInto: sel! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:16'! exploreSelection self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ^ self selection explore! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 11:55'! fieldListMenu: aMenu | sel | ((((sel _ self selection) isMemberOf: Array) or: [sel isMemberOf: OrderedCollection]) and: [sel size >= 1]) ifTrue: [^ self fieldListMenuForCollection: aMenu]. ^ aMenu labels: 'inspect (i) explore (I) method refs to this inst var methods storing into this inst var objects pointing to this value copy name browse full (b) browse class browse hierarchy inst var refs... inst var defs... class var refs... class variables class refs basic inspect' lines: #(2 5 6 9 11 14) selections: #(inspectSelection exploreSelection referencesToSelection defsOfSelection objectReferencesToSelection copyName browseMethodFull browseClass classHierarchy browseInstVarRefs browseInstVarDefs classVarRefs browseClassVariables browseClassRefs inspectBasic). ! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 11:45'! fieldListMenuForCollection: aMenu ^ aMenu labels: 'inspect (i) inspect element... explore (I) method refs to this inst var methods storing into this inst var objects pointing to this value copy name browse full (b) browse class browse hierarchy inst var refs... inst var defs... class var refs... class variables class refs basic inspect' lines: #(3 6 7 10 12 15) selections: #(inspectSelection inspectElement exploreSelection referencesToSelection defsOfSelection objectReferencesToSelection copyName browseMethodFull browseClass classHierarchy browseInstVarRefs browseInstVarDefs classVarRefs browseClassVariables browseClassRefs inspectBasic). ! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 1/14/2000 12:19'! inspectElement | sel selSize countString count | "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((sel _ self selection) isKindOf: SequenceableCollection) ifFalse: [^ sel inspect]. (selSize _ sel size) == 1 ifTrue: [^ sel first inspect]. selSize <= 10 ifTrue: [count _ (SelectionMenu selections: (1 to: selSize) asArray) startUpWithCaption: 'which element?'. count ifNil: [^ self] ifNotNil: [^ (sel at: count) inspect]]. countString _ FillInTheBlank request: 'Which element? (1 - ', selSize printString, ')' initialAnswer: '1'. countString isEmptyOrNil ifTrue: [^ self]. count _ Integer readFrom: (ReadStream on: countString). (count > 0 and: [count <= selSize]) ifTrue: [(sel at: count) inspect] ifFalse: [self beep]! ! !Inspector methodsFor: 'menu commands' stamp: 'jm 11/24/2003 18:37'! inspectSelection "Create and schedule an Inspector on the receiver's model's currently selected object." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ^ Inspector openOn: self selection withEvalPane: true ! ! !Inspector methodsFor: 'menu commands' stamp: 'jm 11/28/2003 13:33'! inspectorKey: aChar from: view "respond to a Command key. Got here from a list of fields being inspected" aChar == $i ifTrue: [Inspector openOn: self selection]. aChar == $I ifTrue: [self selection explore]. aChar == $b ifTrue: [self browseMethodFull]. aChar == $c ifTrue: [self copyName]. ^ self arrowKey: aChar from: view! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'! horizontalDividerProportion ^ 0.3! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:16'! openAsMorphOn: anObject ^ self openAsMorphOn: anObject withLabel: anObject defaultLabelForInspector! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 9/23/1998 08:30'! openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass "Note: for now, this always adds an eval pane, and ignores the valueViewClass" (self openAsMorphOn: anObject withLabel: label) openInWorld! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 1/12/2000 16:34'! openAsMorphOn: anObject withLabel: aLabel "(Inspector openAsMorphOn: SystemOrganization) openInMVC" | window inspector | inspector _ self inspect: anObject. window _ (SystemWindow labelled: aLabel) model: inspector. window addMorph: ((PluggableListMorph on: inspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: ((inspector isMemberOf: DictionaryInspector) ifTrue: [#dictionaryMenu:] ifFalse: [#fieldListMenu:]) keystroke: #inspectorKey:from:) doubleClickSelector: #inspectSelection) frame: (0@0 corner: self horizontalDividerProportion @ self verticalDividerProportion). window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (self horizontalDividerProportion @0 corner: 1@self verticalDividerProportion). window addMorph: ((PluggableTextMorph on: inspector text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) askBeforeDiscardingEdits: false) frame: (0@self verticalDividerProportion corner: 1@1). window setUpdatablePanesFrom: #(fieldList). window position: 16@0. "Room for scroll bar." ^ window! ! !Inspector class methodsFor: 'instance creation' stamp: 'jm 11/24/2003 18:33'! openOn: anObject "Create and schedule an instance of me to inspect the given object." ^ self openOn: anObject withEvalPane: false ! ! !Inspector class methodsFor: 'instance creation' stamp: 'jm 11/24/2003 18:30'! openOn: anObject withEvalPane: withEval "Create and schedule an instance of me on the model, anInspector. " | label | label _ [anObject defaultLabelForInspector] ifError: ['an object']. ^ self openOn: anObject withEvalPane: withEval withLabel: label! ! !Inspector class methodsFor: 'instance creation' stamp: 'di 2/16/2000 10:52'! openOn: anObject withEvalPane: withEval withLabel: label Smalltalk isMorphic ifTrue: [^ self openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: nil]. ^ self openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: PluggableTextView ! ! !Inspector class methodsFor: 'instance creation' stamp: 'di 2/16/2000 10:52'! openOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass | topView inspector listView valueView evalView | inspector _ self inspect: anObject. topView _ StandardSystemView new model: inspector. topView borderWidth: 1. listView _ PluggableListView on: inspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:. (inspector isMemberOf: DictionaryInspector) ifTrue: [listView menu: #dictionaryMenu:]. listView window: (0 @ 0 extent: 40 @ 40). topView addSubView: listView. valueView _ valueViewClass new. "PluggableTextView or PluggableFormView" (valueView respondsTo: #getText) ifTrue: [ valueView on: inspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:]. (valueViewClass inheritsFrom: FormView) ifTrue: [ valueView model: inspector]. valueView window: (0 @ 0 extent: 75 @ 40). topView addSubView: valueView toRightOf: listView. withEval ifTrue: [evalView _ PluggableTextView new on: inspector text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. evalView window: (0 @ 0 extent: 115 @ 20). evalView askBeforeDiscardingEdits: false. topView addSubView: evalView below: listView]. topView label: label. topView minimumSize: 180 @ 120. topView setUpdatablePanesFrom: #(fieldList). topView controller open! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'! verticalDividerProportion ^ 0.7! ! My instances can print the object code of a CompiledMethod in symbolic format. They print into an instance variable, stream, and uses oldPC to determine how many bytes to print in the listing. The inherited variable, sender, is used in an ugly way to hold the method being printed.! My instances can interpret the byte-encoded Smalltalk instruction set. They maintain a program counter (pc) for streaming through CompiledMethods. My subclasses are Contexts, which inherit this capability. They store the return pointer in the instance variable sender, and the current position in their method in the instance variable pc. For other users, sender can hold a method to be similarly interpreted. The unclean re-use of sender to hold the method was to avoid a trivial subclass for the stand-alone scanning function.! !InstructionStream methodsFor: 'testing' stamp: 'di 1/29/2000 14:42'! willJumpIfTrue "Answer whether the next bytecode is a jump-if-true." | byte | byte _ self method at: pc. ^ byte between: 168 and: 171! ! I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. Integer division consists of: / exact division, answers a fraction if result is not a whole integer // answers an Integer, rounded towards negative infinity \\ is modulo rounded towards negative infinity quo: truncated division, rounded towards zero! !Integer methodsFor: 'testing' stamp: 'ar 6/9/2000 18:56'! isPowerOfTwo "Return true if the receiver is an integral power of two." ^ (self bitAnd: self-1) = 0! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! * aNumber "Refer to the comment in Number * " aNumber isInteger ifTrue: [^ self digitMultiply: aNumber neg: self negative ~~ aNumber negative]. ^ aNumber adaptToInteger: self andSend: #*! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! + aNumber "Refer to the comment in Number + " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ (self digitAdd: aNumber) normalize] ifFalse: [^ self digitSubtract: aNumber]]. ^ aNumber adaptToInteger: self andSend: #+! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! - aNumber "Refer to the comment in Number - " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ self digitSubtract: aNumber] ifFalse: [^ (self digitAdd: aNumber) normalize]]. ^ aNumber adaptToInteger: self andSend: #-! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'! / aNumber "Refer to the comment in Number / " | quoRem | aNumber isInteger ifTrue: [quoRem _ self digitDiv: aNumber abs "*****I've added abs here*****" neg: self negative ~~ aNumber negative. (quoRem at: 2) = 0 ifTrue: [^ (quoRem at: 1) normalize] ifFalse: [^ (Fraction numerator: self denominator: aNumber) reduced]]. ^ aNumber adaptToInteger: self andSend: #/! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:00'! quo: aNumber "Refer to the comment in Number quo: " | ng quo | aNumber isInteger ifTrue: [ng _ self negative == aNumber negative == false. quo _ (self digitDiv: (aNumber class == SmallInteger ifTrue: [aNumber abs] ifFalse: [aNumber]) neg: ng) at: 1. ^ quo normalize]. ^ aNumber adaptToInteger: self andSend: #quo:! ! !Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! < aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^ (self digitCompare: aNumber) > 0] ifFalse: [^ (self digitCompare: aNumber) < 0]] ifFalse: [^ self negative]]. ^ aNumber adaptToInteger: self andSend: #<! ! !Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! = aNumber aNumber isNumber ifFalse: [^ false]. aNumber isInteger ifTrue: [aNumber negative == self negative ifTrue: [^ (self digitCompare: aNumber) = 0] ifFalse: [^ false]]. ^ aNumber adaptToInteger: self andSend: #=! ! !Integer methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! > aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^(self digitCompare: aNumber) < 0] ifFalse: [^(self digitCompare: aNumber) > 0]] ifFalse: [^ aNumber negative]]. ^ aNumber adaptToInteger: self andSend: #>! ! !Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'! atRandom "Answer a random integer from 1 to self. This implementation uses a shared generator. Heavy users should their own implementation or use Interval>atRandom: directly." ^ self atRandom: Collection randomForPicking! ! !Integer methodsFor: 'truncation and round off' stamp: 'sma 5/12/2000 12:35'! atRandom: aGenerator "Answer a random integer from 1 to self picked from aGenerator." ^ aGenerator nextInt: self! ! !Integer methodsFor: 'mathematical functions' stamp: 'LC 6/17/1998 19:22'! gcd: anInteger "See Knuth, Vol 2, 4.5.2, Algorithm L" "Initialize" | higher u v k uHat vHat a b c d vPrime vPrimePrime q t | higher _ SmallInteger maxVal highBit. u _ self abs max: (v _ anInteger abs). v _ self abs min: v. [v class == SmallInteger] whileFalse: [(uHat _ u bitShift: (k _ higher - u highBit)) class == SmallInteger ifFalse: [k _ k - 1. uHat _ uHat bitShift: -1]. vHat _ v bitShift: k. a _ 1. b _ 0. c _ 0. d _ 1. "Test quotient" [(vPrime _ vHat + d) ~= 0 and: [(vPrimePrime _ vHat + c) ~= 0 and: [(q _ uHat + a // vPrimePrime) = (uHat + b // vPrime)]]] whileTrue: ["Emulate Euclid" c _ a - (q * (a _ c)). d _ b - (q * (b _ d)). vHat _ uHat - (q * (uHat _ vHat))]. "Multiprecision step" b = 0 ifTrue: [v _ u rem: (u _ v)] ifFalse: [t _ u * a + (v * b). v _ u * c + (v * d). u _ t]]. ^ v gcd: u! ! !Integer methodsFor: 'bit manipulation' stamp: 'dwh 8/18/1999 21:57'! >> shiftAmount "right shift" shiftAmount < 0 ifTrue: [self error: 'negative arg']. ^ self bitShift: 0 - shiftAmount! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:14'! anyBitOfMagnitudeFrom: start to: stopArg "Tests for any magnitude bits in the interval from start to stopArg." | magnitude firstDigitIx lastDigitIx rightShift leftShift stop | <primitive: 'primAnyBitFromTo' module:'LargeIntegers'> start < 1 | (stopArg < 1) ifTrue: [^ self error: 'out of range']. magnitude _ self abs. stop _ stopArg min: magnitude highBit. start > stop ifTrue: [^ false]. firstDigitIx _ start - 1 // 8 + 1. lastDigitIx _ stop - 1 // 8 + 1. rightShift _ (start - 1 \\ 8) negated. leftShift _ 7 - (stop - 1 \\ 8). firstDigitIx = lastDigitIx ifTrue: [| digit mask | mask _ (255 bitShift: rightShift negated) bitAnd: (255 bitShift: leftShift negated). digit _ magnitude digitAt: firstDigitIx. ^ (digit bitAnd: mask) ~= 0]. ((magnitude digitAt: firstDigitIx) bitShift: rightShift) ~= 0 ifTrue: [^ true]. firstDigitIx + 1 to: lastDigitIx - 1 do: [:ix | (magnitude digitAt: ix) ~= 0 ifTrue: [^ true]]. ((magnitude digitAt: lastDigitIx) bitShift: leftShift) ~= 0 ifTrue: [^ true]. ^ false! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitAnd: n "Answer an Integer whose bits are the logical AND of the receiver's bits and those of the argument, n." | norm | <primitive: 'primDigitBitAnd' module:'LargeIntegers'> norm _ n normalize. ^ self digitLogic: norm op: #bitAnd: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitOr: n "Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument, n." | norm | <primitive: 'primDigitBitOr' module:'LargeIntegers'> norm _ n normalize. ^ self digitLogic: norm op: #bitOr: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 10:09'! bitShift: shiftCount "Answer an Integer whose value (in twos-complement representation) is the receiver's value (in twos-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts." | magnitudeShift | magnitudeShift _ self bitShiftMagnitude: shiftCount. ^ ((self negative and: [shiftCount negative]) and: [self anyBitOfMagnitudeFrom: 1 to: shiftCount negated]) ifTrue: [magnitudeShift - 1] ifFalse: [magnitudeShift]! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/9/2000 14:02'! bitShiftMagnitude: shiftCount "Answer an Integer whose value (in magnitude representation) is the receiver's value (in magnitude representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts." | rShift | <primitive: 'primDigitBitShiftMagnitude' module:'LargeIntegers'> shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount]. rShift _ 0 - shiftCount. ^ (self digitRshift: (rShift bitAnd: 7) bytes: (rShift bitShift: -3) lookfirst: self digitLength) normalize! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitXor: n "Answer an Integer whose bits are the logical XOR of the receiver's bits and those of the argument, n." | norm | <primitive: 'primDigitBitXor' module:'LargeIntegers'> norm _ n normalize. ^ self digitLogic: norm op: #bitXor: length: (self digitLength max: norm digitLength)! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:13'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self subclassResponsibility! ! !Integer methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 01:55'! highBitOfMagnitude "Answer the index of the high order bit of the magnitude of the receiver, or zero if the receiver is zero." ^ self subclassResponsibility! ! !Integer methodsFor: 'converting' stamp: 'di 11/6/1998 13:43'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert me to a Fraction." ^ rcvr perform: selector with: self asFraction! ! !Integer methodsFor: 'converting' stamp: 'ar 10/31/1998 23:04'! asColorOfDepth: d "Return a color value representing the receiver as color of the given depth" ^Color colorFromPixelValue: self depth: d! ! !Integer methodsFor: 'converting' stamp: 'di 1/13/1999 12:45'! asFloat "Answer a Float that represents the value of the receiver. Optimized to process only the significant digits of a LargeInteger. SqR: 11/30/1998 21:11" | sum firstByte shift | shift _ 0. sum _ 0.0. firstByte _ self size - 7 max: 1. firstByte to: self size do: [:byteIndex | sum _ ((self digitAt: byteIndex) asFloat timesTwoPower: shift) + sum. shift _ shift + 8]. ^sum * self sign asFloat timesTwoPower: firstByte - 1 * 8! ! !Integer methodsFor: 'converting' stamp: 'ls 5/26/1998 20:53'! asHexDigit ^'0123456789ABCDEF' at: self+1! ! !Integer methodsFor: 'printing' stamp: 'sw 11/24/1998 14:53'! asStringWithCommas "123456789 asStringWithCommas" "-123456789 asStringWithCommas" | digits | digits _ self abs printString. ^ String streamContents: [:strm | self sign = -1 ifTrue: [strm nextPut: $-]. 1 to: digits size do: [:i | strm nextPut: (digits at: i). (i < digits size and: [(i - digits size) \\ 3 = 0]) ifTrue: [strm nextPut: $,]]]! ! !Integer methodsFor: 'printing' stamp: 'sw 11/13/1999 23:00'! asTwoCharacterString "Answer a two-character string representing the receiver, with leading zero if required. Intended for use with integers in the range 0 to 99, but plausible replies given for other values too" ^ (self >= 0 and: [self < 10]) ifTrue: ['0', self printString] ifFalse: [self printString copyFrom: 1 to: 2] " 2 asTwoCharacterString 11 asTwoCharacterString 1943 asTwoCharacterString 0 asTwoCharacterString -2 asTwoCharacterString -234 asTwoCharacterString "! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:14'! destinationBuffer:digitLength digitLength <= 1 ifTrue: [self] ifFalse: [LargePositiveInteger new: digitLength].! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'! digitBuffer:digitLength ^Array new:digitLength*8.! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 01:04'! printOn: aStream base: b "Print a representation of the receiver on the stream, aStream, in base, b, where 2<=b<=16." | digits source dest i j pos t rem | self negative ifTrue:[aStream nextPut:$-]. b = 10 ifFalse: [aStream print: b; nextPut: $r]. i _ self digitLength. "Estimate size of result, conservatively" digits _ Array new: i * 8. pos _ 0. dest _ i <= 1 ifTrue: [self] ifFalse: [LargePositiveInteger new: i]. source _ self. [i >= 1] whileTrue: [rem _ 0. j _ i. [j > 0] whileTrue: [t _ (rem bitShift: 8) + (source digitAt: j). dest digitAt: j put: t // b. rem _ t \\ b. j _ j - 1]. pos _ pos + 1. digits at: pos put: rem. source _ dest. (source digitAt: i) = 0 ifTrue: [i _ i - 1]]. "(dest digitAt: 1) printOn: aStream base: b." [pos > 0] whileTrue: [aStream nextPut: (Character digitValue: (digits at: pos)). pos _ pos - 1]! ! !Integer methodsFor: 'printing' stamp: 'jm 5/22/2003 19:33'! romanString "Answer myself as represented in Roman numerals." "1999 romanString" self assert: [self > 0]. ^ String streamContents: [:s | self // 1000 timesRepeat: [s nextPut: $M]. self romanDigits: 'MDC' for: 100 on: s. self romanDigits: 'CLX' for: 10 on: s. self romanDigits: 'XVI' for: 1 on: s] ! ! !Integer methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:26'! lastDigit "Answer the last digit of the integer base 256. LargePositiveInteger uses bytes of base two number, and each is a 'digit'." ^self digitAt: self digitLength! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:41'! digitAdd: arg | len arglen accum sum | <primitive: 'primDigitAdd' module:'LargeIntegers'> accum _ 0. (len _ self digitLength) < (arglen _ arg digitLength) ifTrue: [len _ arglen]. "Open code max: for speed" sum _ Integer new: len neg: self negative. 1 to: len do: [:i | accum _ (accum bitShift: -8) + (self digitAt: i) + (arg digitAt: i). sum digitAt: i put: (accum bitAnd: 255)]. accum > 255 ifTrue: [sum _ sum growby: 1. sum at: sum digitLength put: (accum bitShift: -8)]. ^ sum! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:43'! digitCompare: arg "Compare the magnitude of self with that of arg. Return a code of 1, 0, -1 for self >, = , < arg" | len arglen argDigit selfDigit | <primitive: 'primDigitCompare' module:'LargeIntegers'> len _ self digitLength. (arglen _ arg digitLength) ~= len ifTrue: [arglen > len ifTrue: [^ -1] ifFalse: [^ 1]]. [len > 0] whileTrue: [(argDigit _ arg digitAt: len) ~= (selfDigit _ self digitAt: len) ifTrue: [argDigit < selfDigit ifTrue: [^ 1] ifFalse: [^ -1]]. len _ len - 1]. ^ 0! ! !Integer methodsFor: 'private' stamp: 'jm 5/22/2003 19:57'! digitDiv: arg neg: ng "Answer with an array of (quotient, remainder)." | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | <primitive: 'primDigitDivNegative' module:'LargeIntegers'> arg = 0 ifTrue: [^ self error: 'division by 0']. "TFEI added this line" l _ self digitLength - arg digitLength + 1. l <= 0 ifTrue: [^ Array with: 0 with: self]. "shortcut against #highBit" d _ 8 - arg lastDigit highBitOfPositiveReceiver. div _ arg digitLshift: d. div _ div growto: div digitLength + 1. "shifts so high order word is >=128" rem _ self digitLshift: d. rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1]. "makes a copy and shifts" quo _ Integer new: l neg: ng. dl _ div digitLength - 1. "Last actual byte of data" ql _ l. dh _ div digitAt: dl. dnh _ dl = 1 ifTrue: [0] ifFalse: [div digitAt: dl - 1]. 1 to: ql do: [:k | "maintain quo*arg+rem=self" "Estimate rem/div by dividing the leading to bytes of rem by dh." "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." j _ rem digitLength + 1 - k. "r1 _ rem digitAt: j." (rem digitAt: j) = dh ifTrue: [qhi _ qlo _ 15 "i.e. q=255"] ifFalse: ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. Note that r1,r2 are bytes, not nibbles. Be careful not to generate intermediate results exceeding 13 bits." "r2 _ (rem digitAt: j - 1)." t _ ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4). qhi _ t // dh. t _ (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15). qlo _ t // dh. t _ t \\ dh. "Next compute (hi,lo) _ q*dnh" hi _ qhi * dnh. lo _ qlo * dnh + ((hi bitAnd: 15) bitShift: 4). hi _ (hi bitShift: -4) + (lo bitShift: -8). lo _ lo bitAnd: 255. "Correct overestimate of q. Max of 2 iterations through loop -- see Knuth vol. 2" r3 _ j < 3 ifTrue: [0] ifFalse: [rem digitAt: j - 2]. [(t < hi or: [t = hi and: [r3 < lo]]) and: ["i.e. (t,r3) < (hi,lo)" qlo _ qlo - 1. lo _ lo - dnh. lo < 0 ifTrue: [hi _ hi - 1. lo _ lo + 256]. hi >= dh]] whileTrue: [hi _ hi - dh]. qlo < 0 ifTrue: [qhi _ qhi - 1. qlo _ qlo + 16]]. "Subtract q*div from rem" l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | hi _ (div digitAt: i) * qhi. lo _ a + (rem digitAt: l) - ((hi bitAnd: 15) bitShift: 4) - ((div digitAt: i) * qlo). rem digitAt: l put: lo - (lo // 256 * 256). "sign-tolerant form of (lo bitAnd: 255)" a _ lo // 256 - (hi bitShift: -4). l _ l + 1]. a < 0 ifTrue: ["Add div back into rem, decrease q by 1" qlo _ qlo - 1. l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | a _ (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i). rem digitAt: l put: (a bitAnd: 255). l _ l + 1]]. quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo]. rem _ rem digitRshift: d bytes: 0 lookfirst: dl. ^ Array with: quo with: rem! ! !Integer methodsFor: 'private' stamp: 'sr 6/8/2000 01:30'! digitLshift: shiftCount | carry rShift mask len result digit byteShift bitShift highBit | (highBit _ self highBitOfMagnitude) = 0 ifTrue: [^ 0]. len _ highBit + shiftCount + 7 // 8. result _ Integer new: len neg: self negative. byteShift _ shiftCount // 8. bitShift _ shiftCount \\ 8. bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts" ^ result replaceFrom: byteShift + 1 to: len with: self startingAt: 1]. carry _ 0. rShift _ bitShift - 8. mask _ 255 bitShift: 0 - bitShift. 1 to: byteShift do: [:i | result digitAt: i put: 0]. 1 to: len - byteShift do: [:i | digit _ self digitAt: i. result digitAt: i + byteShift put: (((digit bitAnd: mask) bitShift: bitShift) bitOr: carry). carry _ digit bitShift: rShift]. ^ result! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'! digitMultiply: arg neg: ng | prod prodLen carry digit k ab | <primitive: 'primDigitMultiplyNegative' module:'LargeIntegers'> (arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^ 0]. (self digitLength = 1 and: [(self digitAt: 1) = 0]) ifTrue: [^ 0]. prodLen _ self digitLength + arg digitLength. prod _ Integer new: prodLen neg: ng. "prod starts out all zero" 1 to: self digitLength do: [:i | (digit _ self digitAt: i) ~= 0 ifTrue: [k _ i. carry _ 0. "Loop invariant: 0<=carry<=0377, k=i+j-1" 1 to: arg digitLength do: [:j | ab _ (arg digitAt: j) * digit + carry + (prod digitAt: k). carry _ ab bitShift: -8. prod digitAt: k put: (ab bitAnd: 255). k _ k + 1]. prod digitAt: k put: carry]]. ^ prod normalize! ! !Integer methodsFor: 'private' stamp: 'sr 1/23/2000 05:46'! digitSubtract: arg | smaller larger z sum sl al ng | <primitive: 'primDigitSubtract' module:'LargeIntegers'> sl _ self digitLength. al _ arg digitLength. (sl = al ifTrue: [[(self digitAt: sl) = (arg digitAt: sl) and: [sl > 1]] whileTrue: [sl _ sl - 1]. al _ sl. (self digitAt: sl) < (arg digitAt: sl)] ifFalse: [sl < al]) ifTrue: [larger _ arg. smaller _ self. ng _ self negative == false. sl _ al] ifFalse: [larger _ self. smaller _ arg. ng _ self negative]. sum _ Integer new: sl neg: ng. z _ 0. "Loop invariant is -1<=z<=1" 1 to: sl do: [:i | z _ z + (larger digitAt: i) - (smaller digitAt: i). sum digitAt: i put: z - (z // 256 * 256). "sign-tolerant form of (z bitAnd: 255)" z _ z // 256]. ^ sum normalize! ! !Integer methodsFor: 'private' stamp: 'sma 5/20/2000 17:00'! romanDigits: digits for: base on: aStream | n | n _ self \\ (base * 10) // base. n = 9 ifTrue: [^ aStream nextPut: digits last; nextPut: digits first]. n = 4 ifTrue: [^ aStream nextPut: digits last; nextPut: digits second]. n > 4 ifTrue: [aStream nextPut: digits second]. n \\ 5 timesRepeat: [aStream nextPut: digits last]! ! !Integer methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'! benchFib "Handy send-heavy benchmark" "(result // seconds to run) = approx calls per second" " | r t | t _ Time millisecondsToRun: [r _ 26 benchFib]. (r * 1000) // t" "138000 on a Mac 8100/100" ^ self < 2 ifTrue: [1] ifFalse: [(self-1) benchFib + (self-2) benchFib + 1] ! ! !Integer methodsFor: 'benchmarks' stamp: 'di 4/11/1999 11:20'! benchmark "Handy bytecode-heavy benchmark" "(500000 // time to run) = approx bytecodes per second" "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000" "3059000 on a Mac 8100/100" | size flags prime k count | size _ 8190. 1 to: self do: [:iter | count _ 0. flags _ (Array new: size) atAllPut: true. 1 to: size do: [:i | (flags at: i) ifTrue: [prime _ i+1. k _ i + prime. [k <= size] whileTrue: [flags at: k put: false. k _ k + prime]. count _ count + 1]]]. ^ count! ! !Integer methodsFor: 'benchmarks' stamp: 'dwh 11/21/1999 16:40'! tinyBenchmarks "Report the results of running the two tiny Squeak benchmarks. ar 9/10/1999: Adjusted to run at least 1 sec to get more stable results" "0 tinyBenchmarks" "On a 292 MHz G3 Mac: 22727272 bytecodes/sec; 984169 sends/sec" "On a 400 MHz PII/Win98: 18028169 bytecodes/sec; 1081272 sends/sec" | t1 t2 r n1 n2 | n1 _ 1. [t1 _ Time millisecondsToRun: [n1 benchmark]. t1 < 1000] whileTrue:[n1 _ n1 * 2]. "Note: #benchmark's runtime is about O(n)" n2 _ 28. [t2 _ Time millisecondsToRun: [r _ n2 benchFib]. t2 < 1000] whileTrue:[n2 _ n2 + 1]. "Note: #benchFib's runtime is about O(k^n), where k is the golden number = (1 + 5 sqrt) / 2 = 1.618...." ^ ((n1 * 500000 * 1000) // t1) printString, ' bytecodes/sec; ', ((r * 1000) // t2) printString, ' sends/sec'! ! !Integer class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'! basicNew self == Integer ifTrue: [ ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. ^ super basicNew! ! !Integer class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 22:01'! new self == Integer ifTrue: [ ^ self error: 'Integer is an abstract class. Make a concrete subclass.']. ^ super new! ! !Integer class methodsFor: 'instance creation' stamp: 'ls 6/23/1999 20:37'! readFrom: aStream base: base "Answer an instance of one of my concrete subclasses. Initial minus sign accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not allowed--use Number readFrom: for that. Answer zero (not an error) if there are no digits." | digit value neg startPos | neg _ aStream peekFor: $-. neg ifFalse: [aStream peekFor: $+]. value _ 0. startPos _ aStream position. [aStream atEnd] whileFalse: [digit _ aStream next digitValue. (digit < 0 or: [digit >= base]) ifTrue: [aStream skip: -1. aStream position = startPos ifTrue: [self error: 'At least one digit expected here']. neg ifTrue: [^ value negated]. ^ value] ifFalse: [value _ value * base + digit]]. neg ifTrue: [^ value negated]. ^ value! ! IntegerArrays store 32bit signed Integer values. Negative values are stored as 2's complement.! !IntegerArray methodsFor: 'accessing'! at: index | word | word _ self basicAt: index. word < 16r3FFFFFFF ifTrue:[^word]. "Avoid LargeInteger computations" ^word >= 16r80000000 "Negative?!!" ifTrue:["word - 16r100000000" (word bitInvert32 + 1) negated] ifFalse:[word]! ! !IntegerArray methodsFor: 'accessing' stamp: 'jm 3/19/1999 09:35'! at: index put: anInteger | word | anInteger < 0 ifTrue:["word _ 16r100000000 + anInteger" word _ (anInteger + 1) negated bitInvert32] ifFalse:[word _ anInteger]. self basicAt: index put: word. ^anInteger! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'! asIntegerArray ^self! ! 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. NOTE: Here follows a list of things to be borne in mind when working on this code, or when making changes for the future. 1. There are a number of things that should be done the next time we plan to release a copletely incompatible image format. These include unifying the instanceSize field of the class format word -- see instantiateClass:indexableSize:, and unifying the bits of the method primitive index (if we decide we need more than 512, after all) -- see primitiveIndexOf:. Also, contexts should be given a special format code (see next item). 2. There are several fast checks for contexts (see isContextHeader: and isMethodContextHeader:) which will fail if the compact class indices of BlockContext or MethodContext change. This is necessary because the oops may change during a compaction when the oops are being adjusted. It's important to be aware of this when writing a new image using the systemTracer. A better solution would be to reserve one of the format codes for Contexts only. 3. We have made normal files tolerant to size and positions up to 32 bits. This has not been done for async files, since they are still experimental. The code in size, at: and at:put: should work with sizes and indices up to 31 bits, although I have not tested it (di 12/98); it might or might not work with 32-bit sizes. 4. Note that 0 is used in a couple of places as an impossible oop. This should be changed to a constant that really is impossible (or perhaps there is code somewhere that guarantees it --if so it should be put in this comment). The places include the method cache and the at cache. ! !Interpreter methodsFor: 'initialization' stamp: 'jm 11/15/2003 06:42'! initializeInterpreter: bytesToShift "Initialize Interpreter state before starting execution of a new image." self initializeObjectMemory: bytesToShift. self initBBOpTable. activeContext _ nilObj. theHomeContext _ nilObj. method _ nilObj. receiver _ nilObj. messageSelector _ nilObj. newMethod _ nilObj. self flushMethodCache. self loadInitialContext. interruptCheckCounter _ 0. nextPollTick _ 0. nextWakeupTick _ 0. lastTick _ 0. interruptKeycode _ 2094. "cmd-." interruptPending _ false. semaphoresToSignalCount _ 0. deferDisplayUpdates _ false. pendingFinalizationSignals _ 0. ! ! !Interpreter methodsFor: 'initialization'! loadInitialContext | sched proc | sched _ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation). proc _ self fetchPointer: ActiveProcessIndex ofObject: sched. activeContext _ self fetchPointer: SuspendedContextIndex ofObject: proc. (activeContext < youngStart) ifTrue: [ self beRootIfOld: activeContext ]. self fetchContextRegisters: activeContext. reclaimableContextCount _ 0.! ! !Interpreter methodsFor: 'utilities'! areIntegers: oop1 and: oop2 ^ ((oop1 bitAnd: oop2) bitAnd: 1) ~= 0! ! !Interpreter methodsFor: 'utilities' stamp: 'jm 2/15/98 17:11'! arrayValueOf: arrayOop "Return the address of first indexable field of resulting array object, or fail if the instance variable does not contain an indexable bytes or words object." "Note: May be called by translated primitive code." self returnTypeC: 'void *'. ((self isIntegerObject: arrayOop) not and: [self isWordsOrBytes: arrayOop]) ifTrue: [^ self cCode: '(void *) (arrayOop + 4)']. self primitiveFail. ! ! !Interpreter methodsFor: 'utilities'! assertClassOf: oop is: classOop "Succeed if the given (non-integer) object is an instance of the given class. Fail if the object is an integer." | ccIndex cl | self inline: true. (self isIntegerObject: oop) ifTrue: [ successFlag _ false. ^ nil ]. ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F. ccIndex = 0 ifTrue: [ cl _ ((self classHeader: oop) bitAnd: AllButTypeMask) ] ifFalse: [ "look up compact class" cl _ (self fetchPointer: (ccIndex - 1) ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop))]. self success: cl = classOop. ! ! !Interpreter methodsFor: 'utilities' stamp: 'jm 12/10/1998 19:18'! booleanCheat: cond | bytecode offset | self inline: true. bytecode _ self fetchByte. "assume next bytecode is jumpIfFalse (99%)" self internalPop: 2. (bytecode < 160 and: [bytecode > 151]) ifTrue: [ "short jumpIfFalse" cond ifTrue: [^ self fetchNextBytecode] ifFalse: [^ self jump: bytecode - 151]]. bytecode = 172 ifTrue: [ "long jumpIfFalse" offset _ self fetchByte. cond ifTrue: [^ self fetchNextBytecode] ifFalse: [^ self jump: offset]]. "not followed by a jumpIfFalse; undo instruction fetch and push boolean result" localIP _ localIP - 1. self fetchNextBytecode. cond ifTrue: [self internalPush: trueObj] ifFalse: [self internalPush: falseObj]. ! ! !Interpreter methodsFor: 'utilities'! booleanValueOf: obj obj = trueObj ifTrue: [ ^ true ]. obj = falseObj ifTrue: [ ^ false ]. successFlag _ false. ^ nil! ! !Interpreter methodsFor: 'utilities'! checkedIntegerValueOf: intOop "Note: May be called by translated primitive code." (self isIntegerObject: intOop) ifTrue: [ ^ self integerValueOf: intOop ] ifFalse: [ self primitiveFail. ^ 0 ]! ! !Interpreter methodsFor: 'utilities' stamp: 'jm 12/7/1998 07:35'! externalizeIPandSP "Copy the local instruction and stack pointer to global variables for use in primitives and other functions outside the interpret loop." instructionPointer _ self cCoerce: localIP to: 'int'. stackPointer _ self cCoerce: localSP to: 'int'. theHomeContext _ localHomeContext. ! ! !Interpreter methodsFor: 'utilities'! fetchInteger: fieldIndex ofObject: objectPointer "Note: May be called by translated primitive code." | intOop | self inline: false. intOop _ self fetchPointer: fieldIndex ofObject: objectPointer. (self isIntegerObject: intOop) ifTrue: [ ^ self integerValueOf: intOop ] ifFalse: [ self primitiveFail. ^ 0 ]! ! !Interpreter methodsFor: 'utilities'! fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer "Return the integer value of the given field of the given object. If the field contains a Float, truncate it and return its integral part. Fail if the given field does not contain a small integer or Float, or if the truncated Float is out of the range of small integers." "Note: May be called by translated primitive code." | intOrFloat floatVal frac trunc | self inline: false. self var: #floatVal declareC: 'double floatVal'. self var: #frac declareC: 'double frac'. self var: #trunc declareC: 'double trunc'. intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer. (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat]. self assertClassOf: intOrFloat is: (self splObj: ClassFloat). successFlag ifTrue: [ self fetchFloatAt: intOrFloat + BaseHeaderSize into: floatVal. self cCode: 'frac = modf(floatVal, &trunc)'. "the following range check is for C ints, with range -2^31..2^31-1" self cCode: 'success((-2147483648.0 <= trunc) && (trunc <= 2147483647.0))']. successFlag ifTrue: [^ self cCode: '((int) trunc)'] ifFalse: [^ 0]. ! ! !Interpreter methodsFor: 'utilities' stamp: 'di 11/16/1998 20:55'! floatObjectOf: aFloat | resultOop | self var: #aFloat declareC: 'double aFloat'. resultOop _ self clone: (self splObj: FloatProto). self storeFloatAt: resultOop + BaseHeaderSize from: aFloat. ^ resultOop. ! ! !Interpreter methodsFor: 'utilities'! floatValueOf: oop "Fetch the instance variable at the given index of the given object. Return the C double precision floating point value of that instance variable, or fail if it is not a Float." "Note: May be called by translated primitive code." | result | self returnTypeC: 'double'. self var: #result declareC: 'double result'. self assertClassOf: oop is: (self splObj: ClassFloat). successFlag ifTrue: [self fetchFloatAt: oop + BaseHeaderSize into: result] ifFalse: [result _ 0.0]. ^ result! ! !Interpreter methodsFor: 'utilities' stamp: 'jm 12/7/1998 07:35'! internalizeIPandSP "Copy the local instruction and stack pointer to local variables for rapid access within the interpret loop." localIP _ self cCoerce: instructionPointer to: 'char *'. localSP _ self cCoerce: stackPointer to: 'char *'. localHomeContext _ theHomeContext. ! ! !Interpreter methodsFor: 'utilities' stamp: 'di 11/27/1998 21:20'! loadFloatOrIntFrom: floatOrInt "If floatOrInt is an integer, then convert it to a C double float and return it. If it is a Float, then load its value and return it. Otherwise fail -- ie return with successFlag set to false." self inline: true. self returnTypeC: 'double'. (self isIntegerObject: floatOrInt) ifTrue: [^ self cCode: '((double) (floatOrInt >> 1))']. (self fetchClassOfNonInt: floatOrInt) = (self splObj: ClassFloat) ifTrue: [^ self floatValueOf: floatOrInt]. successFlag _ false! ! !Interpreter methodsFor: 'utilities'! makePointwithxValue: xValue yValue: yValue | pointResult | pointResult _ self instantiateSmallClass: (self splObj: ClassPoint) sizeInBytes: 12 fill: nilObj. self storePointer: XIndex ofObject: pointResult withValue: (self integerObjectOf: xValue). self storePointer: YIndex ofObject: pointResult withValue: (self integerObjectOf: yValue). ^ pointResult! ! !Interpreter methodsFor: 'utilities'! quickFetchInteger: fieldIndex ofObject: objectPointer "Return the integer value of the field without verifying that it is an integer value!! For use in time-critical places where the integer-ness of the field can be guaranteed." ^ self integerValueOf: (self fetchPointer: fieldIndex ofObject: objectPointer).! ! !Interpreter methodsFor: 'utilities'! signExtend16: int16 "Convert a signed 16-bit integer into a signed 32-bit integer value. The integer bit is not added here." (int16 bitAnd: 16r8000) = 0 ifTrue: [ ^ int16 ] ifFalse: [ ^ int16 - 16r10000 ].! ! !Interpreter methodsFor: 'utilities' 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 ! ! !Interpreter methodsFor: 'utilities'! storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue "Note: May be called by translated primitive code." (self isIntegerValue: integerValue) ifTrue: [ self storeWord: fieldIndex ofObject: objectPointer withValue: (self integerObjectOf: integerValue). ] ifFalse: [ self primitiveFail ].! ! !Interpreter methodsFor: 'utilities' stamp: 'ikp 12/12/1998 14:35'! transfer: count from: src to: dst | in out lastIn | self inline: true. in _ src - 4. lastIn _ in + (count * 4). out _ dst - 4. [in < lastIn] whileTrue: [ self longAt: (out _ out + 4) put: (self longAt: (in _ in + 4)). ].! ! !Interpreter methodsFor: 'utilities'! transfer: count fromIndex: firstFrom ofObject: fromOop toIndex: firstTo ofObject: toOop "Assume: beRootIfOld: will be called on toOop." | fromIndex toIndex lastFrom | self inline: true. fromIndex _ fromOop + (firstFrom * 4). toIndex _ toOop + (firstTo * 4). lastFrom _ fromIndex + (count * 4). [fromIndex < lastFrom] whileTrue: [ fromIndex _ fromIndex + 4. toIndex _ toIndex + 4. self longAt: toIndex put: (self longAt: fromIndex). ].! ! !Interpreter methodsFor: 'object memory support'! mapInterpreterOops "Map all oops in the interpreter's state to their new values during garbage collection or a become: operation." "Assume: All traced variables contain valid oops." | oop | nilObj _ self remap: nilObj. falseObj _ self remap: falseObj. trueObj _ self remap: trueObj. specialObjectsOop _ self remap: specialObjectsOop. stackPointer _ stackPointer - activeContext. "*rel to active" activeContext _ self remap: activeContext. stackPointer _ stackPointer + activeContext. "*rel to active" theHomeContext _ self remap: theHomeContext. instructionPointer _ instructionPointer - method. "*rel to method" method _ self remap: method. instructionPointer _ instructionPointer + method. "*rel to method" receiver _ self remap: receiver. messageSelector _ self remap: messageSelector. newMethod _ self remap: newMethod. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ remapBuffer at: i put: (self remap: oop). ]. ]. "The method cache uses oops as hashes -- toss the whole thing." self flushMethodCache.! ! !Interpreter methodsFor: 'object memory support' stamp: 'jm 11/15/2003 06:45'! markAndTraceInterpreterOops "Mark and trace all oops in the interpreter's state." "Assume: All traced variables contain valid oops." | oop | self markAndTrace: specialObjectsOop. "also covers nilObj, trueObj, falseObj, and compact classes" self markAndTrace: activeContext. "traces entire stack" "also covers theHomeContext, receiver, method" self markAndTrace: messageSelector. self markAndTrace: newMethod. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ self markAndTrace: oop. ]. ].! ! !Interpreter methodsFor: 'object memory support' stamp: 'jm 11/15/2003 06:41'! postGCAction "Mark the active and home contexts as roots if old. This allows the interpreter to use storePointerUnchecked to store into them." (activeContext < youngStart) ifTrue: [ self beRootIfOld: activeContext ]. (theHomeContext < youngStart) ifTrue: [ self beRootIfOld: theHomeContext ]. ! ! !Interpreter methodsFor: 'object memory support' stamp: 'jm 12/30/2003 20:14'! preGCAction activeContext == nilObj ifFalse: [self storeContextRegisters: activeContext]. ! ! !Interpreter methodsFor: 'compiled methods' stamp: 'ar 10/13/1998 13:50'! argumentCountOf: methodPointer ^ ((self headerOf: methodPointer) >> 25) bitAnd: 16r0F! ! !Interpreter methodsFor: 'compiled methods'! headerOf: methodPointer ^self fetchPointer: HeaderIndex ofObject: methodPointer! ! !Interpreter methodsFor: 'compiled methods'! literal: offset ^self literal: offset ofMethod: method! ! !Interpreter methodsFor: 'compiled methods'! literal: offset ofMethod: methodPointer ^ self fetchPointer: offset + LiteralStart ofObject: methodPointer ! ! !Interpreter methodsFor: 'compiled methods'! literalCountOf: methodPointer ^self literalCountOfHeader: (self headerOf: methodPointer)! ! !Interpreter methodsFor: 'compiled methods'! literalCountOfHeader: headerPointer ^ (headerPointer >> 10) bitAnd: 16rFF! ! !Interpreter methodsFor: 'compiled methods'! methodClassOf: methodPointer ^ self fetchPointer: ValueIndex ofObject: (self literal: (self literalCountOf: methodPointer) - 1 ofMethod: methodPointer)! ! !Interpreter methodsFor: 'compiled methods' stamp: 'jm 9/18/97 21:06'! primitiveIndexOf: methodPointer "Note: We now have 11 bits of primitive index, but they are in two places for temporary backward compatibility. The time to unpack is negligible, since the reconstituted full index is stored in the method cache." | primBits | primBits _ ((self headerOf: methodPointer) >> 1) bitAnd: 16r300001FF. primBits > 16r1FF ifTrue: [^ (primBits bitAnd: 16r1FF) + (primBits >> 19)] ifFalse: [^ primBits]! ! !Interpreter methodsFor: 'compiled methods'! primitiveNewMethod | header bytecodeCount class size theMethod literalCount | header _ self popStack. bytecodeCount _ self popInteger. self success: (self isIntegerObject: header). successFlag ifFalse: [self unPop: 2]. class _ self popStack. size _ (self literalCountOfHeader: header) + 1 * 4 + bytecodeCount. theMethod _ self instantiateClass: class indexableSize: size. self storePointer: HeaderIndex ofObject: theMethod withValue: header. literalCount _ self literalCountOfHeader: header. 1 to: literalCount do: [:i | self storePointer: i ofObject: theMethod withValue: nilObj]. self push: theMethod! ! !Interpreter methodsFor: 'contexts'! argumentCountOfBlock: blockPointer | argCount | argCount _ self fetchPointer: BlockArgumentCountIndex ofObject: blockPointer. (self isIntegerObject: argCount) ifTrue: [ ^ self integerValueOf: argCount ] ifFalse: [ self primitiveFail. ^0 ].! ! !Interpreter methodsFor: 'contexts'! caller ^self fetchPointer: CallerIndex ofObject: activeContext! ! !Interpreter methodsFor: 'contexts'! fetchContextRegisters: activeCntx "Note: internalFetchContextRegisters: should track changes to this method." | tmp | self inline: true. tmp _ self fetchPointer: MethodIndex ofObject: activeCntx. (self isIntegerObject: tmp) ifTrue: [ "if the MethodIndex field is an integer, activeCntx is a block context" tmp _ self fetchPointer: HomeIndex ofObject: activeCntx. (tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ]. ] ifFalse: [ "otherwise, it is a method context and is its own home context" tmp _ activeCntx. ]. theHomeContext _ tmp. receiver _ self fetchPointer: ReceiverIndex ofObject: tmp. method _ self fetchPointer: MethodIndex ofObject: tmp. "the instruction pointer is a pointer variable equal to method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx. instructionPointer _ method + tmp + BaseHeaderSize - 2. "the stack pointer is a pointer variable also..." tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx. stackPointer _ activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4).! ! !Interpreter methodsFor: 'contexts' stamp: 'di 11/29/1998 16:24'! fetchStackPointerOf: aContext "Return the stackPointer of a Context or BlockContext." | sp | self inline: true. sp _ self fetchPointer: StackPointerIndex ofObject: aContext. (self isIntegerObject: sp) ifFalse: [^ 0]. ^ self integerValueOf: sp! ! !Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 08:37'! internalFetchContextRegisters: activeCntx "Inlined into return bytecodes. The only difference between this method and fetchContextRegisters: is that this method sets the local IP and SP." | tmp | self inline: true. tmp _ self fetchPointer: MethodIndex ofObject: activeCntx. (self isIntegerObject: tmp) ifTrue: [ "if the MethodIndex field is an integer, activeCntx is a block context" tmp _ self fetchPointer: HomeIndex ofObject: activeCntx. (tmp < youngStart) ifTrue: [ self beRootIfOld: tmp ]. ] ifFalse: [ "otherwise, it is a method context and is its own home context" tmp _ activeCntx. ]. localHomeContext _ tmp. receiver _ self fetchPointer: ReceiverIndex ofObject: tmp. method _ self fetchPointer: MethodIndex ofObject: tmp. "the instruction pointer is a pointer variable equal to method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" tmp _ self quickFetchInteger: InstructionPointerIndex ofObject: activeCntx. localIP _ self cCoerce: method + tmp + BaseHeaderSize - 2 to: 'char *'. "the stack pointer is a pointer variable also..." tmp _ self quickFetchInteger: StackPointerIndex ofObject: activeCntx. localSP _ self cCoerce: activeCntx + BaseHeaderSize + ((TempFrameStart + tmp - 1) * 4) to: 'char *'.! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 15:55'! internalNewActiveContext: aContext "The only difference between this method and newActiveContext: is that this method uses internal context registers." self inline: true. self internalStoreContextRegisters: activeContext. (aContext < youngStart) ifTrue: [ self beRootIfOld: aContext ]. activeContext _ aContext. self internalFetchContextRegisters: aContext.! ! !Interpreter methodsFor: 'contexts'! internalPop: nItems localSP _ localSP - (nItems * 4).! ! !Interpreter methodsFor: 'contexts'! internalPop: nItems thenPush: oop self longAt: (localSP _ localSP - ((nItems - 1) * 4)) put: oop. ! ! !Interpreter methodsFor: 'contexts'! internalPush: object self longAt: (localSP _ localSP + 4) put: object.! ! !Interpreter methodsFor: 'contexts'! internalStackTop ^ self longAt: localSP! ! !Interpreter methodsFor: 'contexts'! internalStackValue: offset ^ self longAt: localSP - (offset * 4)! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 22:57'! internalStoreContextRegisters: activeCntx "The only difference between this method and fetchContextRegisters: is that this method stores from the local IP and SP." "InstructionPointer is a pointer variable equal to method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" self inline: true. self storeWord: InstructionPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: (localIP asInteger + 2 - (method + BaseHeaderSize))). self storeWord: StackPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: (((localSP asInteger - (activeCntx + BaseHeaderSize)) >> 2) - TempFrameStart + 1)). ! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/27/1998 23:32'! isContextHeader: aHeader | ccIndex | self inline: true. ccIndex _ (aHeader >> 12) bitAnd: 16r1F. ^ ccIndex = 13 or: [ccIndex = 14]! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/27/1998 23:32'! isMethodContextHeader: aHeader self inline: true. ^ ((aHeader >> 12) bitAnd: 16r1F) = 14! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 15:51'! newActiveContext: aContext "Note: internalNewActiveContext: should track changes to this method." self storeContextRegisters: activeContext. (aContext < youngStart) ifTrue: [ self beRootIfOld: aContext ]. activeContext _ aContext. self fetchContextRegisters: aContext.! ! !Interpreter methodsFor: 'contexts' stamp: 'di 11/30/1998 12:31'! pop2AndPushIntegerIfOK: integerResult successFlag ifTrue: [(self isIntegerValue: integerResult) ifTrue: [self pop: 2 thenPush: (self integerObjectOf: integerResult)] ifFalse: [successFlag _ false]]! ! !Interpreter methodsFor: 'contexts'! pop: nItems "Note: May be called by translated primitive code." stackPointer _ stackPointer - (nItems*4).! ! !Interpreter methodsFor: 'contexts'! pop: nItems thenPush: oop | sp | self longAt: (sp _ stackPointer - ((nItems - 1) * 4)) put: oop. stackPointer _ sp. ! ! !Interpreter methodsFor: 'contexts'! popInteger | integerPointer | integerPointer _ self popStack. (self isIntegerObject: integerPointer) ifTrue: [^ self integerValueOf: integerPointer] ifFalse: [successFlag _ false. ^ 1 "in case need SOME integer prior to fail"]! ! !Interpreter methodsFor: 'contexts'! popPos32BitInteger "May set successFlag, and return false if not valid" | top | top _ self popStack. ^ self positive32BitValueOf: top! ! !Interpreter methodsFor: 'contexts'! popStack | top | top _ self longAt: stackPointer. stackPointer _ stackPointer - 4. ^ top! ! !Interpreter methodsFor: 'contexts'! push: object | sp | self longAt: (sp _ stackPointer + 4) put: object. stackPointer _ sp.! ! !Interpreter methodsFor: 'contexts'! pushBool: trueOrFalse trueOrFalse ifTrue: [ self push: trueObj ] ifFalse: [ self push: falseObj ].! ! !Interpreter methodsFor: 'contexts'! pushInteger: integerValue self push: (self integerObjectOf: integerValue).! ! !Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 07:41'! sender ^ self fetchPointer: SenderIndex ofObject: localHomeContext! ! !Interpreter methodsFor: 'contexts'! stackIntegerValue: offset | integerPointer | integerPointer _ self longAt: stackPointer - (offset*4). (self isIntegerObject: integerPointer) ifTrue: [ ^self integerValueOf: integerPointer ] ifFalse: [ self primitiveFail. ^0 ]! ! !Interpreter methodsFor: 'contexts'! stackPointerIndex "Return the 0-based index rel to the current context. (This is what stackPointer used to be before conversion to pointer" ^ (stackPointer - activeContext - BaseHeaderSize) >> 2! ! !Interpreter methodsFor: 'contexts'! stackTop ^self longAt: stackPointer! ! !Interpreter methodsFor: 'contexts'! stackValue: offset ^ self longAt: stackPointer - (offset*4)! ! !Interpreter methodsFor: 'contexts' stamp: 'di 12/3/1998 13:39'! storeContextRegisters: activeCntx "Note: internalStoreContextRegisters: should track changes to this method." "InstructionPointer is a pointer variable equal to method oop + ip + BaseHeaderSize -1 for 0-based addressing of fetchByte -1 because it gets incremented BEFORE fetching currentByte" self inline: true. self storeWord: InstructionPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: (instructionPointer - method - (BaseHeaderSize - 2))). self storeWord: StackPointerIndex ofObject: activeCntx withValue: (self integerObjectOf: (self stackPointerIndex - TempFrameStart + 1)). ! ! !Interpreter methodsFor: 'contexts'! storeStackPointerValue: value inContext: contextPointer "Assume: value is an integerValue" self storeWord: StackPointerIndex ofObject: contextPointer withValue: (self integerObjectOf: value).! ! !Interpreter methodsFor: 'contexts' stamp: 'jm 12/7/1998 07:42'! temporary: offset ^ self fetchPointer: offset + TempFrameStart ofObject: localHomeContext! ! !Interpreter methodsFor: 'contexts'! unPop: nItems stackPointer _ stackPointer + (nItems*4)! ! !Interpreter methodsFor: 'object format' stamp: 'ar 3/21/98 02:37'! 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 > 4) or: [fmt = 2]) ifTrue: [^ 0]. "indexable fields only" fmt < 2 ifTrue: [^ wordLength]. "fixed fields only (zero or more)" "fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word" class _ self fetchClassOf: oop. classFormat _ self formatOfClass: class. ^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1 ! ! !Interpreter methodsFor: 'object format'! formatOfClass: classPointer "**should be in-lined**" "Note that, in Smalltalk, the instSpec will be equal to the inst spec part of the base header of an instance (without hdr type) shifted left 1. In this way, apart from the smallInt bit, the bits are just where you want them for the first header word." "Callers expect low 2 bits (header type) to be zero!!" ^ (self fetchPointer: InstanceSpecificationIndex ofObject: classPointer) - 1! ! !Interpreter methodsFor: 'object format' stamp: 'ar 3/23/98 22:52'! nonWeakFieldsOf: oop "Return the number of non-weak fields in oop (i.e. the number of fixed fields). Note: The following is copied from fixedFieldsOf:format:length: since we do know the format of the oop (e.g. format = 4) and thus don't need the length." | class classFormat | self inline: false. "No need to inline - we won't call this often" (self isWeak: oop) ifFalse:[self error:'Called fixedFieldsOfWeak: with a non-weak oop']. "fmt = 3 or 4: mixture of fixed and indexable fields, so must look at class format word" class _ self fetchClassOf: oop. classFormat _ self formatOfClass: class. ^ (classFormat >> 11 bitAnd: 16rC0) + (classFormat >> 2 bitAnd: 16r3F) - 1 ! ! !Interpreter methodsFor: 'message sending' stamp: 'jm 11/15/2003 06:48'! activateNewMethod | newContext methodHeader initialIP tempCount nilOop | methodHeader _ self headerOf: newMethod. newContext _ self allocateOrRecycleContext. initialIP _ ((LiteralStart + (self literalCountOfHeader: methodHeader)) * 4) + 1. tempCount _ (methodHeader >> 19) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." self storePointerUnchecked: SenderIndex ofObject: newContext withValue: activeContext. self storeWord: InstructionPointerIndex ofObject: newContext withValue: (self integerObjectOf: initialIP). self storeWord: StackPointerIndex ofObject: newContext withValue: (self integerObjectOf: tempCount). self storePointerUnchecked: MethodIndex ofObject: newContext withValue: newMethod. "Copy the reciever and arguments..." 0 to: argumentCount do: [:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext withValue: (self stackValue: argumentCount-i)]. "clear remaining temps to nil in case it has been recycled" nilOop _ nilObj. argumentCount+1 to: tempCount do: [:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext withValue: nilOop]. self pop: argumentCount + 1. reclaimableContextCount _ reclaimableContextCount + 1. self newActiveContext: newContext.! ! !Interpreter methodsFor: 'message sending'! argCount ^ argumentCount! ! !Interpreter methodsFor: 'message sending' stamp: 'ikp 12/12/1998 14:03'! createActualMessage | argumentArray message | argumentArray _ self instantiateClass: (self splObj: ClassArray) indexableSize: argumentCount. "remap argumentArray in case GC happens during allocation" self pushRemappableOop: argumentArray. message _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0. argumentArray _ self popRemappableOop. (argumentArray < youngStart) ifTrue: [ self beRootIfOld: argumentArray ]. self storePointer: MessageSelectorIndex ofObject: message withValue: messageSelector. self storePointer: MessageArgumentsIndex ofObject: message withValue: argumentArray. "--- ikp: replaced with #transfer:from:to: for optimiser compatibility self transfer: argumentCount fromIndex: self stackPointerIndex - (argumentCount - 1) ofObject: activeContext toIndex: 0 ofObject: argumentArray. ---" self transfer: argumentCount from: stackPointer - ((argumentCount - 1) * 4) to: argumentArray + BaseHeaderSize. self pop: argumentCount. self push: message. argumentCount _ 1.! ! !Interpreter methodsFor: 'message sending' stamp: 'ikp 1/3/1999 17:29'! executeNewMethod primitiveIndex > 0 ifTrue: [ self primitiveResponse. successFlag ifTrue: [^ nil]]. "if not primitive, or primitive failed, activate the method" self activateNewMethod. "check for possible interrupts at each real send" self quickCheckForInterrupts. ! ! !Interpreter methodsFor: 'message sending' stamp: 'di 12/26/1998 14:40'! findNewMethodInClass: class "Find the compiled method to be run when the current messageSelector is sent to the given class, setting the values of 'newMethod' and 'primitiveIndex'." | ok | self inline: false. ok _ self lookupInMethodCacheSel: messageSelector class: class. ok ifFalse: [ "entry was not found in the cache; look it up the hard way" self lookupMethodInClass: class. self addToMethodCacheSel: messageSelector class: class method: newMethod primIndex: primitiveIndex. ]. ! ! !Interpreter methodsFor: 'message sending' stamp: 'ikp 1/3/1999 17:30'! internalBytecodeActivateNewMethod | tmp newContext tempCount argCount | self inline: true. tmp _ self headerOf: newMethod. freeContexts ~= NilContext ifTrue: [newContext _ freeContexts. freeContexts _ self fetchPointer: 0 ofObject: newContext] ifFalse: [self externalizeIPandSP. newContext _ self allocateOrRecycleContext. self internalizeIPandSP]. tempCount _ (tmp >> 19) bitAnd: 16r3F. "Assume: newContext will be recorded as a root if necessary by the call to newActiveContext: below, so we can use unchecked stores." self storePointerUnchecked: SenderIndex ofObject: newContext withValue: activeContext. self storeWord: InstructionPointerIndex ofObject: newContext withValue: (self integerObjectOf: (((LiteralStart + (self literalCountOfHeader: tmp)) * 4) + 1)). self storeWord: StackPointerIndex ofObject: newContext withValue: (self integerObjectOf: tempCount). self storePointerUnchecked: MethodIndex ofObject: newContext withValue: newMethod. "Copy the reciever and arguments..." argCount _ argumentCount. 0 to: argCount do: [:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext withValue: (self internalStackValue: argCount-i)]. "clear remaining temps to nil in case it has been recycled" tmp _ nilObj. argCount+1 to: tempCount do: [:i | self storePointerUnchecked: ReceiverIndex+i ofObject: newContext withValue: tmp]. self internalPop: argCount + 1. reclaimableContextCount _ reclaimableContextCount + 1. self internalNewActiveContext: newContext. ! ! !Interpreter methodsFor: 'message sending' stamp: 'jm 11/15/2003 06:46'! internalExecuteNewMethod | primIndex | self inline: true. primIndex _ primitiveIndex. primIndex > 0 ifTrue: [(primIndex > 255 and: [primIndex < 520]) ifTrue: ["Internal return instvars" primIndex >= 264 ifTrue: [^ self internalPop: 1 thenPush: (self fetchPointer: primIndex-264 ofObject: self internalStackTop)] ifFalse: ["Internal return constants" primIndex = 256 ifTrue: [^ nil "^ self"]. primIndex = 257 ifTrue: [^ self internalPop: 1 thenPush: trueObj]. primIndex = 258 ifTrue: [^ self internalPop: 1 thenPush: falseObj]. primIndex = 259 ifTrue: [^ self internalPop: 1 thenPush: nilObj]. ^ self internalPop: 1 thenPush: (self integerObjectOf: primIndex-261)]] ifFalse: [self externalizeIPandSP. self primitiveResponse. self internalizeIPandSP. successFlag ifTrue: [^ nil]]]. "if not primitive, or primitive failed, activate the method" self internalBytecodeActivateNewMethod. "check for possible interrupts at each real send" self internalQuickCheckForInterrupts. ! ! !Interpreter methodsFor: 'message sending' stamp: 'di 12/26/1998 14:40'! internalFindNewMethod "Find the compiled method to be run when the current messageSelector is sent to the class 'lkupClass', setting the values of 'newMethod' and 'primitiveIndex'." | ok | self inline: true. self sharedCodeNamed: 'commonLookup' inCase: 131. ok _ self lookupInMethodCacheSel: messageSelector class: lkupClass. ok ifFalse: [ "entry was not found in the cache; look it up the hard way" self externalizeIPandSP. self lookupMethodInClass: lkupClass. self internalizeIPandSP. self addToMethodCacheSel: messageSelector class: lkupClass method: newMethod primIndex: primitiveIndex]. ! ! !Interpreter methodsFor: 'message sending' stamp: 'jm 12/7/1998 09:05'! lookupMethodInClass: class | currentClass dictionary found rclass | self inline: false. currentClass _ class. [currentClass ~= nilObj] whileTrue: [dictionary _ self fetchPointer: MessageDictionaryIndex ofObject: currentClass. found _ self lookupMethodInDictionary: dictionary. found ifTrue: [^ currentClass]. currentClass _ self superclassOf: currentClass]. messageSelector = (self splObj: SelectorDoesNotUnderstand) ifTrue: [self error: 'Recursive not understood error encountered']. self pushRemappableOop: class. self createActualMessage. "may cause GC!!" rclass _ self popRemappableOop. messageSelector _ self splObj: SelectorDoesNotUnderstand. ^ self lookupMethodInClass: rclass! ! !Interpreter methodsFor: 'message sending' stamp: 'di 12/4/1998 15:02'! 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. primitiveIndex > MaxPrimitiveIndex ifTrue: ["If primitiveIndex is out of range, set to zero before putting in cache. This is equiv to primFail, and avoids the need to check on every send." primitiveIndex _ 0]. ^ true]. index _ index + 1. index = length ifTrue: [wrapAround ifTrue: [^false]. wrapAround _ true. index _ SelectorStart]]! ! !Interpreter methodsFor: 'message sending' stamp: 'jm 12/14/1998 10:26'! normalSend "Send a message, starting lookup with the receiver's class." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." | rcvr | self inline: true. self sharedCodeNamed: 'commonSend' inCase: 131. rcvr _ self internalStackValue: argumentCount. lkupClass _ self fetchClassOf: rcvr. self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'message sending'! specialSelector: index ^ self fetchPointer: (index * 2) ofObject: (self splObj: SpecialSelectors)! ! !Interpreter methodsFor: 'message sending'! superclassOf: classPointer ^ self fetchPointer: SuperclassIndex ofObject: classPointer! ! !Interpreter methodsFor: 'message sending' stamp: 'jm 12/14/1998 10:25'! superclassSend "Send a message to self, starting lookup with the superclass of the class containing the currently executing method." "Assume: messageSelector and argumentCount have been set, and that the receiver and arguments have been pushed onto the stack," "Note: This method is inlined into the interpreter dispatch loop." self inline: true. self sharedCodeNamed: 'commonSupersend' inCase: 133. lkupClass _ self superclassOf: (self methodClassOf: method). self internalFindNewMethod. self internalExecuteNewMethod. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'method lookup cache' stamp: 'jm 12/14/1998 14:31'! addToMethodCacheSel: selector class: class method: meth primIndex: primIndex "Add the given entry to the method cache. The policy is as follows: Look for an empty entry anywhere in the reprobe chain. If found, install the new entry there. If not found, then install the new entry at the first probe position and delete the entries in the rest of the reprobe chain. This has two useful purposes: If there is active contention over the first slot, the second or third will likely be free for reentry after ejection. Also, flushing is good when reprobe chains are getting full." | probe hash | self inline: false. hash _ selector bitXor: class. "drop low-order zeros from addresses" 0 to: CacheProbeMax-1 do: [:p | probe _ (hash >> p) bitAnd: MethodCacheMask. (methodCache at: probe + MethodCacheSelector) = 0 ifTrue: ["Found an empty entry -- use it" methodCache at: probe + MethodCacheSelector put: selector. methodCache at: probe + MethodCacheClass put: class. methodCache at: probe + MethodCacheMethod put: meth. methodCache at: probe + MethodCachePrim put: primIndex. ^ nil]]. "OK, we failed to find an entry -- install at the first slot..." probe _ hash bitAnd: MethodCacheMask. "first probe" methodCache at: probe + MethodCacheSelector put: selector. methodCache at: probe + MethodCacheClass put: class. methodCache at: probe + MethodCacheMethod put: meth. methodCache at: probe + MethodCachePrim put: primIndex. "...and zap the following entries" 1 to: CacheProbeMax-1 do: [:p | probe _ (hash >> p) bitAnd: MethodCacheMask. methodCache at: probe + MethodCacheSelector put: 0]. ! ! !Interpreter methodsFor: 'method lookup cache' stamp: 'di 12/12/1998 23:37'! flushMethodCache "Flush the method cache. The method cache is flushed on every programming change and garbage collect." 1 to: MethodCacheSize do: [ :i | methodCache at: i put: 0 ]. 1 to: AtCacheTotalSize do: [ :i | atCache at: i put: 0 ]. ! ! !Interpreter methodsFor: 'method lookup cache' stamp: 'jm 12/14/1998 14:29'! lookupInMethodCacheSel: selector class: class "This method implements a simple method lookup cache. If an entry for the given selector and class is found in the cache, set the values of 'newMethod' and 'primitiveIndex' and return true. Otherwise, return false." "About the re-probe scheme: The hash is the low bits of the XOR of two large addresses, minus their useless lowest two bits. If a probe doesn't get a hit, the hash is shifted right one bit to compute the next probe, introducing a new randomish bit. The cache is probed CacheProbeMax times before giving up." "WARNING: Since the hash computation is based on the object addresses of the class and selector, we must rehash or flush when compacting storage. We've chosen to flush, since that also saves the trouble of updating the addresses of the objects in the cache." | hash probe | self inline: true. hash _ selector bitXor: class. "shift drops two low-order zeros from addresses" probe _ hash bitAnd: MethodCacheMask. "first probe" (((methodCache at: probe + MethodCacheSelector) = selector) and: [(methodCache at: probe + MethodCacheClass) = class]) ifTrue: [newMethod _ methodCache at: probe + MethodCacheMethod. primitiveIndex _ methodCache at: probe + MethodCachePrim. ^ true "found entry in cache; done"]. probe _ (hash >> 1) bitAnd: MethodCacheMask. "second probe" (((methodCache at: probe + MethodCacheSelector) = selector) and: [(methodCache at: probe + MethodCacheClass) = class]) ifTrue: [newMethod _ methodCache at: probe + MethodCacheMethod. primitiveIndex _ methodCache at: probe + MethodCachePrim. ^ true "found entry in cache; done"]. probe _ (hash >> 2) bitAnd: MethodCacheMask. (((methodCache at: probe + MethodCacheSelector) = selector) and: [(methodCache at: probe + MethodCacheClass) = class]) ifTrue: [newMethod _ methodCache at: probe + MethodCacheMethod. primitiveIndex _ methodCache at: probe + MethodCachePrim. ^ true "found entry in cache; done"]. ^ false ! ! !Interpreter methodsFor: 'interpreter shell'! fetchByte "This method uses the preIncrement builtin function which has no Smalltalk equivalent. Thus, it must be overridden in the simulator." ^ self byteAt: localIP preIncrement! ! !Interpreter methodsFor: 'interpreter shell' stamp: 'jm 12/10/1998 16:44'! fetchNextBytecode "This method fetches the next instruction (bytecode). Each bytecode method is responsible for fetching the next bytecode, preferably as early as possible to allow the memory system time to process the request before the next dispatch." currentBytecode _ self fetchByte. ! ! !Interpreter methodsFor: 'interpreter shell' stamp: 'jm 12/10/1998 17:00'! interpret self internalizeIPandSP. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable]. self externalizeIPandSP. ! ! !Interpreter methodsFor: 'interpreter shell'! unknownBytecode "This should never get called; it means that an unimplemented bytecode appears in a CompiledMethod." self error: 'Unknown bytecode'.! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:42'! duplicateTopBytecode self fetchNextBytecode. self internalPush: self internalStackTop. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:46'! experimentalBytecode "Note: This bytecode is not currently generated by the compiler." "This range of six bytecodes can replace the pushTemporaryVariable[0..5] bytecode at the beginning of a sequence of either the form: pushTemp pushTemp | pushConstantOne | pushLiteralConstant <= longJumpIfFalse or the form: pushTemp pushTemp | pushConstantOne | pushLiteralConstant + popIntoTemp (optional) If two values pushed are not small integers, this bytecode acts like the pushTemp bytecode it replaces. However, if they are small integers, then the given arithmetic or comparison operation is performed. The result of that operation is either pushed onto the stack or, if one of the expected bytecodes follows it, then that bytecode is performed immediately. In such cases, the entire four instruction sequence is performed without doing any stack operations." | arg1 byte2 byte3 byte4 arg1Val arg2Val result offset | arg1 _ self temporary: currentBytecode - 138. byte2 _ self byteAt: localIP + 1. "fetch ahead" byte3 _ self byteAt: localIP + 2. "fetch ahead" byte4 _ self byteAt: localIP + 3. "fetch ahead" "check first arg" (self isIntegerObject: arg1) ifTrue: [ arg1Val _ self integerValueOf: arg1. ] ifFalse: [ self fetchNextBytecode. ^ self internalPush: arg1. "abort; first arg is not an integer" ]. "get and check second arg" byte2 < 32 ifTrue: [ arg2Val _ self temporary: (byte2 bitAnd: 16rF). (self isIntegerObject: arg2Val) ifTrue: [ arg2Val _ self integerValueOf: arg2Val. ] ifFalse: [ self fetchNextBytecode. ^ self internalPush: arg1. "abort; second arg is not an integer" ]. ] ifFalse: [ byte2 > 64 ifTrue: [ arg2Val _ 1. ] ifFalse: [ arg2Val _ self literal: (byte2 bitAnd: 16r1F). (self isIntegerObject: arg2Val) ifTrue: [ arg2Val _ self integerValueOf: arg2Val. ] ifFalse: [ self fetchNextBytecode. ^ self internalPush: arg1. "abort; second arg is not an integer" ]. ]. ]. byte3 < 178 ifTrue: [ "do addition, possibly followed by a storeAndPopTemp" result _ arg1Val + arg2Val. (self isIntegerValue: result) ifTrue: [ ((byte4 > 103) and: [byte4 < 112]) ifTrue: [ "next instruction is a storeAndPopTemp" localIP _ localIP + 3. self storePointerUnchecked: (byte4 bitAnd: 7) + TempFrameStart ofObject: localHomeContext withValue: (self integerObjectOf: result). ] ifFalse: [ localIP _ localIP + 2. self internalPush: (self integerObjectOf: result). ]. ] ifFalse: [ self fetchNextBytecode. ^ self internalPush: arg1. "abort; result is not an integer" ]. ] ifFalse: [ "do comparison operation, followed by a longJumpIfFalse" offset _ self byteAt: localIP + 4. arg1Val <= arg2Val ifTrue: [localIP _ localIP + 3 + 1] "jump not taken; skip extra instruction byte" ifFalse: [localIP _ localIP + 3 + 1 + offset]. self fetchNextBytecode. ]. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:46'! extendedPushBytecode | descriptor variableType variableIndex | descriptor _ self fetchByte. self fetchNextBytecode. variableType _ (descriptor >> 6) bitAnd: 16r3. variableIndex _ descriptor bitAnd: 16r3F. variableType=0 ifTrue: [^self pushReceiverVariable: variableIndex]. variableType=1 ifTrue: [^self pushTemporaryVariable: variableIndex]. variableType=2 ifTrue: [^self pushLiteralConstant: variableIndex]. variableType=3 ifTrue: [^self pushLiteralVariable: variableIndex]. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'! extendedStoreAndPopBytecode self extendedStoreBytecode. self internalPop: 1. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'! extendedStoreBytecode | descriptor variableType variableIndex association | self inline: true. descriptor _ self fetchByte. self fetchNextBytecode. variableType _ (descriptor >> 6) bitAnd: 16r3. variableIndex _ descriptor bitAnd: 16r3F. variableType = 0 ifTrue: [^self storePointer: variableIndex ofObject: receiver withValue: self internalStackTop]. variableType = 1 ifTrue: [^self storePointerUnchecked: variableIndex + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop]. variableType = 2 ifTrue: [self error: 'illegal store']. variableType = 3 ifTrue: [association _ self literal: variableIndex. ^self storePointer: ValueIndex ofObject: association withValue: self internalStackTop].! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:47'! popStackBytecode self fetchNextBytecode. self internalPop: 1. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushActiveContextBytecode "Puts reclaimability of this context in question." self fetchNextBytecode. reclaimableContextCount _ 0. self internalPush: activeContext. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantFalseBytecode self fetchNextBytecode. self internalPush: falseObj. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantMinusOneBytecode self fetchNextBytecode. self internalPush: ConstMinusOne. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantNilBytecode self fetchNextBytecode. self internalPush: nilObj. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantOneBytecode self fetchNextBytecode. self internalPush: ConstOne. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantTrueBytecode self fetchNextBytecode. self internalPush: trueObj. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantTwoBytecode self fetchNextBytecode. self internalPush: ConstTwo. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushConstantZeroBytecode self fetchNextBytecode. self internalPush: ConstZero. ! ! !Interpreter methodsFor: 'stack bytecodes'! pushLiteralConstant: literalIndex self internalPush: (self literal: literalIndex).! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:56'! pushLiteralConstantBytecode self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" self pushLiteralConstant: (currentBytecode bitAnd: 16r1F). ! ! !Interpreter methodsFor: 'stack bytecodes'! pushLiteralVariable: literalIndex self internalPush: (self fetchPointer: ValueIndex ofObject: (self literal: literalIndex)).! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:56'! pushLiteralVariableBytecode self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" self pushLiteralVariable: (currentBytecode bitAnd: 16r1F). ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/10/1998 16:48'! pushReceiverBytecode self fetchNextBytecode. self internalPush: receiver. ! ! !Interpreter methodsFor: 'stack bytecodes'! pushReceiverVariable: fieldIndex self internalPush: (self fetchPointer: fieldIndex ofObject: receiver).! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:57'! pushReceiverVariableBytecode self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" self pushReceiverVariable: (currentBytecode bitAnd: 16rF). ! ! !Interpreter methodsFor: 'stack bytecodes'! pushTemporaryVariable: temporaryIndex self internalPush: (self temporary: temporaryIndex).! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:57'! pushTemporaryVariableBytecode self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" self pushTemporaryVariable: (currentBytecode bitAnd: 16rF). ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:58'! storeAndPopReceiverVariableBytecode "Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code." | rcvr top | self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" rcvr _ receiver. top _ self internalStackTop. (rcvr < youngStart) ifTrue: [ self possibleRootStoreInto: rcvr value: top. ]. self storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top. self internalPop: 1. ! ! !Interpreter methodsFor: 'stack bytecodes' stamp: 'jm 12/11/1998 07:59'! storeAndPopTemporaryVariableBytecode self fetchNextBytecode. "this bytecode will be expanded so that refs to currentBytecode below will be constant" self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop. self internalPop: 1. ! ! !Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/10/1998 17:11'! jump: offset localIP _ localIP + offset + 1. currentBytecode _ self byteAt: localIP. ! ! !Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/11/1998 07:24'! jumplfFalseBy: offset | boolean | boolean _ self internalStackTop. boolean = falseObj ifTrue: [ self jump: offset. ] ifFalse: [ boolean = trueObj ifFalse: [ messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. self fetchNextBytecode. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/11/1998 07:24'! jumplfTrueBy: offset | boolean | boolean _ self internalStackTop. boolean = trueObj ifTrue: [ self jump: offset. ] ifFalse: [ boolean = falseObj ifFalse: [ messageSelector _ self splObj: SelectorMustBeBoolean. argumentCount _ 0. ^ self normalSend ]. self fetchNextBytecode. ]. self internalPop: 1. ! ! !Interpreter methodsFor: 'jump bytecodes'! longJumpIfFalse self jumplfFalseBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! ! !Interpreter methodsFor: 'jump bytecodes'! longJumpIfTrue self jumplfTrueBy: ((currentBytecode bitAnd: 3) * 256) + self fetchByte.! ! !Interpreter methodsFor: 'jump bytecodes' stamp: 'jm 12/13/1998 11:20'! longUnconditionalJump | offset | offset _ (((currentBytecode bitAnd: 7) - 4) * 256) + self fetchByte. localIP _ localIP + offset. offset < 0 ifTrue: [ "backward jump means we're in a loop; check for possible interrupts" self internalQuickCheckForInterrupts. ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'jump bytecodes'! shortConditionalJump self jumplfFalseBy: (currentBytecode bitAnd: 7) + 1.! ! !Interpreter methodsFor: 'jump bytecodes'! shortUnconditionalJump self jump: (currentBytecode bitAnd: 7) + 1.! ! !Interpreter methodsFor: 'send bytecodes' stamp: 'jm 12/10/1998 17:20'! doubleExtendedDoAnythingBytecode "Replaces the Blue Book double-extended send [132], in which the first byte was wasted on 8 bits of argument count. Here we use 3 bits for the operation sub-type (opType), and the remaining 5 bits for argument count where needed. The last byte give access to 256 instVars or literals. See also secondExtendedSendBytecode" | byte2 byte3 opType top | byte2 _ self fetchByte. byte3 _ self fetchByte. opType _ byte2 >> 5. opType = 0 ifTrue: [ messageSelector _ self literal: byte3. argumentCount _ byte2 bitAnd: 16r1F. ^ self normalSend ]. opType = 1 ifTrue: [ messageSelector _ self literal: byte3. argumentCount _ byte2 bitAnd: 16r1F. ^ self superclassSend ]. self fetchNextBytecode. opType = 2 ifTrue: [^ self pushReceiverVariable: byte3]. opType = 3 ifTrue: [^ self pushLiteralConstant: byte3]. opType = 4 ifTrue: [^ self pushLiteralVariable: byte3]. opType = 5 ifTrue: [ top _ self internalStackTop. ^ self storePointer: byte3 ofObject: receiver withValue: top ]. opType = 6 ifTrue: [ top _ self internalStackTop. self internalPop: 1. ^ self storePointer: byte3 ofObject: receiver withValue: top ]. opType = 7 ifTrue: [ top _ self internalStackTop. ^ self storePointer: ValueIndex ofObject: (self literal: byte3) withValue: top ].! ! !Interpreter methodsFor: 'send bytecodes'! secondExtendedSendBytecode "This replaces the Blue Book double-extended super-send [134], which is subsumed by the new double-extended do-anything [132]. It offers a 2-byte send of 0-3 args for up to 63 literals, for which the Blue Book opcode set requires a 3-byte instruction." | descriptor | descriptor _ self fetchByte. messageSelector _ self literal: (descriptor bitAnd: 16r3F). argumentCount _ descriptor >> 6. self normalSend. ! ! !Interpreter methodsFor: 'send bytecodes' stamp: 'di 12/3/1998 12:52'! sendLiteralSelectorBytecode "Can use any of the first 16 literals for the selector and pass up to 2 arguments." messageSelector _ self literal: (currentBytecode bitAnd: 16rF). argumentCount _ ((currentBytecode >> 4) bitAnd: 3) - 1. self normalSend. " Note - if you ever want to try inlining these, the following will produce the code to paste into interp.c -- I found it actually slowed things down (cache size effect?). String streamContents: [:s | 208 to: 255 do: [:i | s tab; tab; nextPutAll: 'case ', i printString, ':'; cr. s tab; tab; tab; nextPutAll: 'messageSelector = longAt(((char *) method) + 4 + '; print: ((i bitAnd: 15) + 1) << 2; nextPutAll: ');'; cr. s tab; tab; tab; nextPutAll: 'argumentCount = '; print: (i >> 4 bitAnd: 3) - 1; nextPutAll: ';'; cr. s tab; tab; tab; nextPutAll: 'goto commonSend;'; cr. s tab; tab; tab; nextPutAll: 'break;'; cr; cr]] "! ! !Interpreter methodsFor: 'send bytecodes'! singleExtendedSendBytecode "Can use any of the first 32 literals for the selector and pass up to 7 arguments." | descriptor | descriptor _ self fetchByte. messageSelector _ self literal: (descriptor bitAnd: 16r1F). argumentCount _ descriptor >> 5. self normalSend.! ! !Interpreter methodsFor: 'send bytecodes'! singleExtendedSuperBytecode "Can use any of the first 32 literals for the selector and pass up to 7 arguments." | descriptor | descriptor _ self fetchByte. messageSelector _ self literal: (descriptor bitAnd: 16r1F). argumentCount _ descriptor >> 5. self superclassSend. ! ! !Interpreter methodsFor: 'return bytecodes'! returnFalse | cntx val | cntx _ self sender. val _ falseObj. self returnValue: val to: cntx. ! ! !Interpreter methodsFor: 'return bytecodes'! returnNil | cntx val | cntx _ self sender. val _ nilObj. self returnValue: val to: cntx. ! ! !Interpreter methodsFor: 'return bytecodes'! returnReceiver | cntx val | cntx _ self sender. val _ receiver. self returnValue: val to: cntx.! ! !Interpreter methodsFor: 'return bytecodes'! returnTopFromBlock "Return to the caller of the method containing the block." | cntx val | cntx _ self caller. "Note: caller, not sender!!" val _ self internalStackTop. self returnValue: val to: cntx.! ! !Interpreter methodsFor: 'return bytecodes'! returnTopFromMethod | cntx val | cntx _ self sender. val _ self internalStackTop. self returnValue: val to: cntx.! ! !Interpreter methodsFor: 'return bytecodes'! returnTrue | cntx val | cntx _ self sender. val _ trueObj. self returnValue: val to: cntx. ! ! !Interpreter methodsFor: 'return bytecodes' stamp: 'jm 12/10/1998 17:22'! returnValue: resultObj to: returnContext "Note: Assumed to be inlined into the dispatch loop." | nilOop thisCntx contextOfCaller | self inline: true. self sharedCodeNamed: 'commonReturn' inCase: 120. nilOop _ nilObj. "keep in a register" thisCntx _ activeContext. "make sure we can return to the given context" ((returnContext = nilOop) or: [(self fetchPointer: InstructionPointerIndex ofObject: returnContext) = nilOop]) ifTrue: [ "error: sender's instruction pointer or context is nil; cannot return" self internalPush: activeContext. self internalPush: resultObj. messageSelector _ self splObj: SelectorCannotReturn. argumentCount _ 1. ^ self normalSend ]. [thisCntx = returnContext] whileFalse: [ "climb up stack to returnContext" contextOfCaller _ self fetchPointer: SenderIndex ofObject: thisCntx. "zap exited contexts so any future attempted use will be caught" self storePointerUnchecked: SenderIndex ofObject: thisCntx withValue: nilOop. self storePointerUnchecked: InstructionPointerIndex ofObject: thisCntx withValue: nilOop. reclaimableContextCount > 0 ifTrue: [ "try to recycle this context" reclaimableContextCount _ reclaimableContextCount - 1. self recycleContextIfPossible: thisCntx. ]. thisCntx _ contextOfCaller. ]. activeContext _ thisCntx. (thisCntx < youngStart) ifTrue: [ self beRootIfOld: thisCntx ]. self internalFetchContextRegisters: thisCntx. "updates local IP and SP" self fetchNextBytecode. self internalPush: resultObj. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:28'! bytecodePrimAdd | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [result _ (self integerValueOf: rcvr) + (self integerValueOf: arg). (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatAdd: rcvr toArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 0. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 12/14/1998 15:10'! bytecodePrimAt "BytecodePrimAt will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAt will put it in the cache after validating that message lookup results in a primitive response." | index rcvr result atIx | index _ self internalStackTop. rcvr _ self internalStackValue: 1. successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index]. successFlag ifTrue: [atIx _ rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifTrue: [result _ self commonVariableInternal: rcvr at: (self integerValueOf: index) cacheIndex: atIx. successFlag ifTrue: [self fetchNextBytecode. ^ self internalPop: 2 thenPush: result]]]. messageSelector _ self specialSelector: 16. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'! bytecodePrimAtEnd messageSelector _ self specialSelector: 21. argumentCount _ 0. self normalSend.! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 12/14/1998 15:10'! bytecodePrimAtPut "BytecodePrimAtPut will only succeed if the receiver is in the atCache. Otherwise it will fail so that the more general primitiveAtPut will put it in the cache after validating that message lookup results in a primitive response." | index rcvr atIx value | value _ self internalStackTop. index _ self internalStackValue: 1. rcvr _ self internalStackValue: 2. successFlag _ (self isIntegerObject: rcvr) not and: [self isIntegerObject: index]. successFlag ifTrue: [atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifTrue: [self commonVariable: rcvr at: (self integerValueOf: index) put: value cacheIndex: atIx. successFlag ifTrue: [self fetchNextBytecode. ^ self internalPop: 3 thenPush: value]]]. messageSelector _ self specialSelector: 17. argumentCount _ 2. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'! bytecodePrimBitAnd successFlag _ true. self externalizeIPandSP. self primitiveBitAnd. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 14. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'! bytecodePrimBitOr successFlag _ true. self externalizeIPandSP. self primitiveBitOr. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 15. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:29'! bytecodePrimBitShift successFlag _ true. self externalizeIPandSP. self primitiveBitShift. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 12. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 1/10/1999 23:29'! bytecodePrimBlockCopy | rcvr hdr | rcvr _ self internalStackValue: 1. successFlag _ true. hdr _ self baseHeader: rcvr. self success: (self isContextHeader: hdr). successFlag ifTrue: [self externalizeIPandSP. self primitiveBlockCopy. self internalizeIPandSP]. successFlag ifFalse: [messageSelector _ self specialSelector: 24. argumentCount _ 1. ^ self normalSend]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 1/11/1999 00:09'! bytecodePrimClass | rcvr | rcvr _ self internalStackTop. self internalPop: 1 thenPush: (self fetchClassOf: rcvr). self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:35'! bytecodePrimDiv | quotient | successFlag _ true. quotient _ self doPrimitiveDiv: (self internalStackValue: 1) by: (self internalStackValue: 0). successFlag ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: quotient). ^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 13. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:30'! bytecodePrimDivide | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr _ self integerValueOf: rcvr. arg _ self integerValueOf: arg. ((arg ~= 0) and: [(rcvr \\ arg) = 0]) ifTrue: [result _ rcvr // arg. "generates C / operation" (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatDivide: rcvr byArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 9. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends'! bytecodePrimDo messageSelector _ self specialSelector: 27. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:39'! bytecodePrimEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr = arg]. successFlag _ true. bool _ self primitiveFloatEqual: rcvr toArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 6. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends'! bytecodePrimEquivalent | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. self booleanCheat: rcvr = arg.! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:40'! bytecodePrimGreaterOrEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr >= arg]. successFlag _ true. bool _ self primitiveFloatLess: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 5. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:40'! bytecodePrimGreaterThan | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr > arg]. successFlag _ true. bool _ self primitiveFloatGreater: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 3. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:40'! bytecodePrimLessOrEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr <= arg]. successFlag _ true. bool _ self primitiveFloatGreater: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 4. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:41'! bytecodePrimLessThan | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr < arg]. successFlag _ true. bool _ self primitiveFloatLess: rcvr thanArg: arg. successFlag ifTrue: [^ self booleanCheat: bool]. messageSelector _ self specialSelector: 2. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'! bytecodePrimMakePoint successFlag _ true. self externalizeIPandSP. self primitiveMakePoint. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 11. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'! bytecodePrimMod | mod | successFlag _ true. mod _ self doPrimitiveMod: (self internalStackValue: 1) by: (self internalStackValue: 0). successFlag ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: mod). ^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 10. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:31'! bytecodePrimMultiply | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [rcvr _ self integerValueOf: rcvr. arg _ self integerValueOf: arg. result _ rcvr * arg. ((arg = 0 or: [(result // arg) = rcvr]) and: [self isIntegerValue: result]) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatMultiply: rcvr byArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 8. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends'! bytecodePrimNew messageSelector _ self specialSelector: 28. argumentCount _ 0. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends'! bytecodePrimNewWithArg messageSelector _ self specialSelector: 29. argumentCount _ 1. self normalSend. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 08:58'! bytecodePrimNext messageSelector _ self specialSelector: 19. argumentCount _ 0. self normalSend.! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 6/21/97 10:12'! bytecodePrimNextPut messageSelector _ self specialSelector: 20. argumentCount _ 1. self normalSend.! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 11/27/1998 15:41'! bytecodePrimNotEqual | rcvr arg bool | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [^ self booleanCheat: rcvr ~= arg]. successFlag _ true. bool _ self primitiveFloatEqual: rcvr toArg: arg. successFlag ifTrue: [^ self booleanCheat: bool not]. messageSelector _ self specialSelector: 7. argumentCount _ 1. self normalSend ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:34'! bytecodePrimPointX successFlag _ true. self externalizeIPandSP. self primitivePointX. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 30. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:34'! bytecodePrimPointY successFlag _ true. self externalizeIPandSP. self primitivePointY. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]. messageSelector _ self specialSelector: 31. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'di 12/11/1998 10:22'! bytecodePrimSize messageSelector _ self specialSelector: 18. argumentCount _ 0. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 18:44'! bytecodePrimSubtract | rcvr arg result | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [result _ (self integerValueOf: rcvr) - (self integerValueOf: arg). (self isIntegerValue: result) ifTrue: [self internalPop: 2 thenPush: (self integerObjectOf: result). ^ self fetchNextBytecode "success"]] ifFalse: [successFlag _ true. self externalizeIPandSP. self primitiveFloatSubtract: rcvr fromArg: arg. self internalizeIPandSP. successFlag ifTrue: [^ self fetchNextBytecode "success"]]. messageSelector _ self specialSelector: 1. argumentCount _ 1. self normalSend! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:33'! bytecodePrimValue | block | block _ self internalStackTop. successFlag _ true. argumentCount _ 0. self assertClassOf: block is: (self splObj: ClassBlockContext). successFlag ifTrue: [ self externalizeIPandSP. self primitiveValue. self internalizeIPandSP. ]. successFlag ifFalse: [ messageSelector _ self specialSelector: 25. argumentCount _ 0. ^ self normalSend ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'common selector sends' stamp: 'jm 12/10/1998 17:33'! bytecodePrimValueWithArg | block | block _ self internalStackValue: 1. successFlag _ true. argumentCount _ 1. self assertClassOf: block is: (self splObj: ClassBlockContext). successFlag ifTrue: [ self externalizeIPandSP. self primitiveValue. self internalizeIPandSP. ]. successFlag ifFalse: [ messageSelector _ self specialSelector: 26. argumentCount _ 1. ^ self normalSend ]. self fetchNextBytecode. ! ! !Interpreter methodsFor: 'primitive support'! failed ^successFlag not! ! !Interpreter methodsFor: 'primitive support'! positive32BitIntegerFor: integerValue | newLargeInteger | "Note - integerValue is interpreted as POSITIVE, eg, as the result of Bitmap>at:, or integer>bitAnd:." (integerValue >= 0 and: [self isIntegerValue: integerValue]) ifTrue: [^ self integerObjectOf: integerValue]. newLargeInteger _ self instantiateSmallClass: (self splObj: ClassLargePositiveInteger) sizeInBytes: 8 fill: 0. self storeByte: 3 ofObject: newLargeInteger withValue: ((integerValue >> 24) bitAnd: 16rFF). self storeByte: 2 ofObject: newLargeInteger withValue: ((integerValue >> 16) bitAnd: 16rFF). self storeByte: 1 ofObject: newLargeInteger withValue: ((integerValue >> 8) bitAnd: 16rFF). self storeByte: 0 ofObject: newLargeInteger withValue: (integerValue bitAnd: 16rFF). ^ newLargeInteger! ! !Interpreter methodsFor: 'primitive support'! positive32BitValueOf: oop "Convert the given object into an integer value. The object may be either a positive ST integer or a four-byte LargePositiveInteger." | sz value | (self isIntegerObject: oop) ifTrue: [ value _ self integerValueOf: oop. value < 0 ifTrue: [^ self primitiveFail]. ^ value]. self assertClassOf: oop is: (self splObj: ClassLargePositiveInteger). successFlag ifTrue: [ sz _ self lengthOf: oop. sz = 4 ifFalse: [^ self primitiveFail]]. successFlag ifTrue: [ ^ (self fetchByte: 0 ofObject: oop) + ((self fetchByte: 1 ofObject: oop) << 8) + ((self fetchByte: 2 ofObject: oop) << 16) + ((self fetchByte: 3 ofObject: oop) << 24) ].! ! !Interpreter methodsFor: 'primitive support'! primIndex ^ primitiveIndex! ! !Interpreter methodsFor: 'primitive support'! primitiveFail successFlag _ false.! ! !Interpreter methodsFor: 'primitive support' stamp: 'jm 12/14/1998 09:51'! primitiveResponse "Details: Since primitives can run for a long time, we must check to see if it is time to process a timer interrupt. However, on the Mac, the high-resolution millisecond clock is expensive to poll. Thus, we use a fast, low-resolution (1/60th second) clock to determine if the primitive took enough time to justify polling the high-resolution clock. Seems Byzantine, but Bob Arning showed that the performance of primitive-intensive code decreased substantially if there was another process waiting on a Delay. One other detail: If the primitive fails, we want to postpone the timer interrupt until just after the primitive failure code has been entered. This is accomplished by setting the interrupt check counter to zero, thus triggering a check for interrupts when activating the method containing the primitive." | timerPending startTime | timerPending _ nextWakeupTick ~= 0. timerPending ifTrue: [startTime _ self ioLowResMSecs]. successFlag _ true. self dispatchOn: primitiveIndex in: PrimitiveTable. timerPending ifTrue: [ (self ioLowResMSecs ~= startTime) ifTrue: [ "primitive ran for more than a tick; check for possible timer interrupts" ((self ioMSecs bitAnd: 16r1FFFFFFF) >= nextWakeupTick) ifTrue: [ successFlag ifTrue: ["process the interrupt now" self checkForInterrupts] ifFalse: ["process the interrupt in primtive failure code" interruptCheckCounter _ 0]]]]. ^ successFlag ! ! !Interpreter methodsFor: 'primitive support'! success: successValue successFlag _ successValue & successFlag.! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:38'! checkBooleanResult: result successFlag ifTrue: [self pushBool: result] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives'! compare31or32Bits: obj1 equal: obj2 "May set success to false" "First compare two ST integers..." ((self isIntegerObject: obj1) and: [self isIntegerObject: obj2]) ifTrue: [^ obj1 = obj2]. "Now compare, assuming positive integers, but setting fail if not" ^ (self positive32BitValueOf: obj1) = (self positive32BitValueOf: obj2)! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 11:22'! doPrimitiveDiv: rcvr by: arg "Rounds negative results towards negative infinity, rather than zero." | result posArg posRcvr integerRcvr integerArg | (self areIntegers: rcvr and: arg) ifTrue: [integerRcvr _ self integerValueOf: rcvr. integerArg _ self integerValueOf: arg. self success: integerArg ~= 0] ifFalse: [self primitiveFail]. successFlag ifFalse: [^ 1 "fail"]. integerRcvr > 0 ifTrue: [integerArg > 0 ifTrue: [result _ integerRcvr // integerArg] ifFalse: ["round negative result toward negative infinity" posArg _ 0 - integerArg. result _ 0 - ((integerRcvr + (posArg - 1)) // posArg)]] ifFalse: [posRcvr _ 0 - integerRcvr. integerArg > 0 ifTrue: ["round negative result toward negative infinity" result _ 0 - ((posRcvr + (integerArg - 1)) // integerArg)] ifFalse: [posArg _ 0 - integerArg. result _ posRcvr // posArg]]. self success: (self isIntegerValue: result). ^ result! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 10:02'! doPrimitiveMod: rcvr by: arg | integerResult integerRcvr integerArg | (self areIntegers: rcvr and: arg) ifTrue: [integerRcvr _ self integerValueOf: rcvr. integerArg _ self integerValueOf: arg. self success: integerArg ~= 0] ifFalse: [self primitiveFail]. successFlag ifFalse: [^ 1 "fail"]. integerResult _ integerRcvr \\ integerArg. "ensure that the result has the same sign as the integerArg" integerArg < 0 ifTrue: [integerResult > 0 ifTrue: [integerResult _ integerResult + integerArg]] ifFalse: [integerResult < 0 ifTrue: [integerResult _ integerResult + integerArg]]. self success: (self isIntegerValue: integerResult). ^ integerResult ! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:13'! primitiveAdd self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) + (self stackIntegerValue: 0)! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:02'! primitiveBitAnd | integerReceiver integerArgument | integerArgument _ self popPos32BitInteger. integerReceiver _ self popPos32BitInteger. successFlag ifTrue: [self push: (self positive32BitIntegerFor: (integerReceiver bitAnd: integerArgument))] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:02'! primitiveBitOr | integerReceiver integerArgument | integerArgument _ self popPos32BitInteger. integerReceiver _ self popPos32BitInteger. successFlag ifTrue: [self push: (self positive32BitIntegerFor: (integerReceiver bitOr: integerArgument))] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/29/1998 12:04'! primitiveBitShift | integerReceiver integerArgument shifted | integerArgument _ self popInteger. integerReceiver _ self popPos32BitInteger. successFlag ifTrue: [ integerArgument >= 0 ifTrue: [ "Left shift -- must fail if we lose bits beyond 32" self success: integerArgument <= 31. shifted _ integerReceiver << integerArgument. self success: (shifted >> integerArgument) = integerReceiver. ] ifFalse: [ "Right shift -- OK to lose bits" self success: integerArgument >= -31. shifted _ integerReceiver bitShift: integerArgument. ]. ]. successFlag ifTrue: [self push: (self positive32BitIntegerFor: shifted)] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 13:18'! primitiveBitXor | integerReceiver integerArgument | integerArgument _ self popPos32BitInteger. integerReceiver _ self popPos32BitInteger. successFlag ifTrue: [self push: (self positive32BitIntegerFor: (integerReceiver bitXor: integerArgument))] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 12/27/1998 22:52'! primitiveDiv | quotient | quotient _ self doPrimitiveDiv: (self stackValue: 1) by: (self stackValue: 0). self pop2AndPushIntegerIfOK: quotient! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:25'! primitiveDivide | integerReceiver integerArgument | integerReceiver _ self stackIntegerValue: 1. integerArgument _ self stackIntegerValue: 0. (integerArgument ~= 0 and: [integerReceiver \\ integerArgument = 0]) ifTrue: [self pop2AndPushIntegerIfOK: integerReceiver // integerArgument] ifFalse: [self primitiveFail]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveEqual | integerReceiver integerArgument result | integerArgument _ self popStack. integerReceiver _ self popStack. result _ self compare31or32Bits: integerReceiver equal: integerArgument. self checkBooleanResult: result! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveGreaterOrEqual | integerReceiver integerArgument | integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver >= integerArgument! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveGreaterThan | integerReceiver integerArgument | integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver > integerArgument! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveLessOrEqual | integerReceiver integerArgument | integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver <= integerArgument! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveLessThan | integerReceiver integerArgument | integerArgument _ self popInteger. integerReceiver _ self popInteger. self checkBooleanResult: integerReceiver < integerArgument! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/28/1998 16:43'! primitiveMakePoint | integerReceiver integerArgument | integerArgument _ self popInteger. integerReceiver _ self popInteger. successFlag ifTrue: [self push: (self makePointwithxValue: integerReceiver yValue: integerArgument)] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:36'! primitiveMod | mod | mod _ self doPrimitiveMod: (self stackValue: 1) by: (self stackValue: 0). self pop2AndPushIntegerIfOK: mod! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:27'! primitiveMultiply | integerRcvr integerArg integerResult | integerRcvr _ self stackIntegerValue: 1. integerArg _ self stackIntegerValue: 0. successFlag ifTrue: [integerResult _ integerRcvr * integerArg. "check for C overflow by seeing if computation is reversible" ((integerArg = 0) or: [(integerResult // integerArg) = integerRcvr]) ifTrue: [self pop2AndPushIntegerIfOK: integerResult] ifFalse: [self primitiveFail]]! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/27/1998 15:43'! primitiveNotEqual | integerReceiver integerArgument result | integerArgument _ self popStack. integerReceiver _ self popStack. result _ (self compare31or32Bits: integerReceiver equal: integerArgument) not. self checkBooleanResult: result! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:19'! primitiveQuo "Rounds negative results towards zero." | integerRcvr integerArg integerResult | integerRcvr _ self stackIntegerValue: 1. integerArg _ self stackIntegerValue: 0. self success: integerArg ~= 0. successFlag ifTrue: [ integerRcvr > 0 ifTrue: [ integerArg > 0 ifTrue: [ integerResult _ integerRcvr // integerArg. ] ifFalse: [ integerResult _ 0 - (integerRcvr // (0 - integerArg)). ]. ] ifFalse: [ integerArg > 0 ifTrue: [ integerResult _ 0 - ((0 - integerRcvr) // integerArg). ] ifFalse: [ integerResult _ (0 - integerRcvr) // (0 - integerArg). ]. ]]. self pop2AndPushIntegerIfOK: integerResult! ! !Interpreter methodsFor: 'arithmetic primitives' stamp: 'di 11/30/1998 10:13'! primitiveSubtract self pop2AndPushIntegerIfOK: (self stackIntegerValue: 1) - (self stackIntegerValue: 0)! ! !Interpreter methodsFor: 'float primitives'! popFloat "Note: May be called by translated primitive code." | top result | self returnTypeC: 'double'. self var: #result declareC: 'double result'. top _ self popStack. self assertClassOf: top is: (self splObj: ClassFloat). successFlag ifTrue: [self fetchFloatAt: top + BaseHeaderSize into: result]. ^ result! ! !Interpreter methodsFor: 'float primitives'! primitiveArctan | rcvr | self var: #rcvr declareC: 'double rcvr'. rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: (self cCode: 'atan(rcvr)')] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives'! primitiveAsFloat | arg | arg _ self popInteger. successFlag ifTrue: [ self pushFloat: (self cCode: '((double) arg)') ] ifFalse: [ self unPop: 1 ].! ! !Interpreter methodsFor: 'float primitives'! primitiveExp "Computes E raised to the receiver power." | rcvr | self var: #rcvr declareC: 'double rcvr'. rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: (self cCode: 'exp(rcvr)')] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives' stamp: 'tao 10/20/97 11:33'! 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].! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:45'! primitiveFloatAdd ^ self primitiveFloatAdd: (self stackValue: 1) toArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:10'! primitiveFloatAdd: rcvrOop toArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [ self pop: 2. self push: (self floatObjectOf: rcvr + arg)].! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:45'! primitiveFloatDivide ^ self primitiveFloatDivide: (self stackValue: 1) byArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:30'! primitiveFloatDivide: rcvrOop byArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [ self success: arg ~= 0.0. successFlag ifTrue: [ self pop: 2. self push: (self floatObjectOf: rcvr // arg) "generates C / operation"]].! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:48'! primitiveFloatEqual | bool | bool _ self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:18'! primitiveFloatEqual: rcvrOop toArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr = arg]! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:42'! primitiveFloatGreater: rcvrOop thanArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr > arg]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:40'! primitiveFloatGreaterOrEqual | bool | bool _ self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool not]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:52'! primitiveFloatGreaterThan | bool | bool _ self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:21'! primitiveFloatLess: rcvrOop thanArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [^ rcvr < arg]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:49'! primitiveFloatLessOrEqual | bool | bool _ self primitiveFloatGreater: (self stackValue: 1) thanArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool not]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:51'! primitiveFloatLessThan | bool | bool _ self primitiveFloatLess: (self stackValue: 1) thanArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:46'! primitiveFloatMultiply ^ self primitiveFloatMultiply: (self stackValue: 1) byArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:30'! primitiveFloatMultiply: rcvrOop byArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [ self pop: 2. self push: (self floatObjectOf: rcvr * arg)].! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 14:49'! primitiveFloatNotEqual | bool | bool _ self primitiveFloatEqual: (self stackValue: 1) toArg: self stackTop. successFlag ifTrue: [self pop: 2. self pushBool: bool not]. ! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:46'! primitiveFloatSubtract ^ self primitiveFloatSubtract: (self stackValue: 1) fromArg: self stackTop! ! !Interpreter methodsFor: 'float primitives' stamp: 'di 11/27/1998 11:30'! primitiveFloatSubtract: rcvrOop fromArg: argOop | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [ self pop: 2. self push: (self floatObjectOf: rcvr - arg)].! ! !Interpreter methodsFor: 'float primitives'! primitiveFractionalPart | rcvr frac trunc | self var: #rcvr declareC: 'double rcvr'. self var: #frac declareC: 'double frac'. self var: #trunc declareC: 'double trunc'. rcvr _ self popFloat. successFlag ifTrue: [ self cCode: 'frac = modf(rcvr, &trunc)'. self pushFloat: frac] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives'! primitiveLogN "Natural log." | rcvr | self var: #rcvr declareC: 'double rcvr'. rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: (self cCode: 'log(rcvr)')] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives'! primitiveSine | rcvr | self var: #rcvr declareC: 'double rcvr'. rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: (self cCode: 'sin(rcvr)')] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives'! primitiveSquareRoot | rcvr | self var: #rcvr declareC: 'double rcvr'. rcvr _ self popFloat. self success: rcvr >= 0.0. successFlag ifTrue: [self pushFloat: (self cCode: 'sqrt(rcvr)')] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'float primitives'! primitiveTimesTwoPower | rcvr arg | self var: #rcvr declareC: 'double rcvr'. arg _ self popInteger. rcvr _ self popFloat. successFlag ifTrue: [ self pushFloat: (self cCode: 'ldexp(rcvr, arg)') ] ifFalse: [ self unPop: 2 ].! ! !Interpreter methodsFor: 'float primitives' stamp: '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]! ! !Interpreter methodsFor: 'float primitives'! pushFloat: f | newFloatObj | self var: #f declareC: 'double f'. newFloatObj _ self instantiateSmallClass: (self splObj: ClassFloat) sizeInBytes: 12 fill: 0. self storeFloatAt: newFloatObj + BaseHeaderSize from: f. self push: newFloatObj.! ! !Interpreter methodsFor: 'array and stream primitives'! asciiOfCharacter: characterObj "Returns an integer object" self inline: false. self assertClassOf: characterObj is: (self splObj: ClassCharacter). successFlag ifTrue: [^ self fetchPointer: CharacterValueIndex ofObject: characterObj] ifFalse: [^ ConstZero] "in case some code needs an int"! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'go 11/17/1998 15:55'! 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: SizeMask ]. fmt _ (header >> 8) bitAnd: 16rF. fmt < 8 ifTrue: [ ^ (sz - BaseHeaderSize)] "words" ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3)] "bytes"! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/10/1998 14:53'! characterForAscii: ascii "Arg must lie in range 0-255!!" self inline: true. ^ self fetchPointer: ascii ofObject: (self splObj: CharacterTable)! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 17:04'! commonAt: stringy "This code is called if the receiver responds primitively to at:. If this is so, it will be installed in the atCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | index rcvr atIx result | index _ self positive32BitValueOf: (self stackValue: 0). "Sets successFlag" rcvr _ self stackValue: 1. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The at-cache, since it is specific to the non-super response to #at:. Therefore we must determine that the message is #at: (not, eg, #basicAt:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 16) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ rcvr bitAnd: AtCacheMask. "Index into atCache = 4N, for N = 0 ... 7" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [result _ self commonVariable: rcvr at: index cacheIndex: atIx]. successFlag ifTrue: [^ self pop: 2 thenPush: result]]. "The slow but sure way..." successFlag _ true. result _ self stObject: rcvr at: index. successFlag ifTrue: [stringy ifTrue: [result _ self characterForAscii: (self integerValueOf: result)]. ^ self pop: 2 thenPush: result]! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 17:06'! commonAtPut: stringy "This code is called if the receiver responds primitively to at:Put:. If this is so, it will be installed in the atPutCache so that subsequent calls of at: or next may be handled immediately in bytecode primitive routines." | value index rcvr atIx | value _ self stackValue: 0. index _ self positive32BitValueOf: (self stackValue: 1). "Sets successFlag" rcvr _ self stackValue: 2. successFlag & (self isIntegerObject: rcvr) not ifFalse: [^ self primitiveFail]. "NOTE: The atPut-cache, since it is specific to the non-super response to #at:Put:. Therefore we must determine that the message is #at:Put: (not, eg, #basicAt:Put:), and that the send is not a super-send, before using the at-cache." (messageSelector = (self specialSelector: 17) and: [lkupClass = (self fetchClassOfNonInt: rcvr)]) ifTrue: ["OK -- look in the at-cache" atIx _ (rcvr bitAnd: AtCacheMask) + AtPutBase. "Index into atPutCache" (atCache at: atIx+AtCacheOop) = rcvr ifFalse: ["Rcvr not in cache. Install it..." self install: rcvr inAtCache: atCache at: atIx string: stringy]. successFlag ifTrue: [self commonVariable: rcvr at: index put: value cacheIndex: atIx]. successFlag ifTrue: [^ self pop: 3 thenPush: value]]. "The slow but sure way..." successFlag _ true. stringy ifTrue: [self stObject: rcvr at: index put: (self asciiOfCharacter: value)] ifFalse: [self stObject: rcvr at: index put: value]. successFlag ifTrue: [^ self pop: 3 thenPush: value]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'! commonVariable: rcvr at: index cacheIndex: atIx "This code assumes the reciever has been identified at location atIx in the atCache." | stSize fmt fixedFields result | stSize _ atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [fmt _ atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [fixedFields _ atCache at: atIx+AtCacheFixedFields. ^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr]. fmt < 8 ifTrue: "Bitmap" [result _ self fetchWord: index - 1 ofObject: rcvr. result _ self positive32BitIntegerFor: result. ^ result]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: "String" [^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)] ifFalse: "ByteArray" [^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]]. self primitiveFail! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'! commonVariable: rcvr at: index put: value cacheIndex: atIx "This code assumes the reciever has been identified at location atIx in the atCache." | stSize fmt fixedFields valToPut | self inline: true. stSize _ atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [fmt _ atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [fixedFields _ atCache at: atIx+AtCacheFixedFields. ^ self storePointer: index + fixedFields - 1 ofObject: rcvr withValue: value]. fmt < 8 ifTrue: "Bitmap" [valToPut _ self positive32BitValueOf: value. successFlag ifTrue: [self storeWord: index - 1 ofObject: rcvr withValue: valToPut]. ^ nil]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: [valToPut _ self asciiOfCharacter: value. successFlag ifFalse: [^ nil]] ifFalse: [valToPut _ value]. (self isIntegerObject: valToPut) ifTrue: [^ self storeByte: index - 1 ofObject: rcvr withValue: (self integerValueOf: valToPut)]]. self primitiveFail! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 19:46'! commonVariableInternal: rcvr at: index cacheIndex: atIx "This code assumes the reciever has been identified at location atIx in the atCache." | stSize fmt fixedFields result | self inline: true. stSize _ atCache at: atIx+AtCacheSize. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [fmt _ atCache at: atIx+AtCacheFmt. fmt <= 4 ifTrue: [fixedFields _ atCache at: atIx+AtCacheFixedFields. ^ self fetchPointer: index + fixedFields - 1 ofObject: rcvr]. fmt < 8 ifTrue: "Bitmap" [result _ self fetchWord: index - 1 ofObject: rcvr. self externalizeIPandSP. result _ self positive32BitIntegerFor: result. self internalizeIPandSP. ^ result]. fmt >= 16 "Note fmt >= 16 is an artificial flag for strings" ifTrue: "String" [^ self characterForAscii: (self fetchByte: index - 1 ofObject: rcvr)] ifFalse: "ByteArray" [^ self integerObjectOf: (self fetchByte: index - 1 ofObject: rcvr)]]. self primitiveFail! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/27/1998 23:17'! install: rcvr inAtCache: cache at: atIx string: stringy "Install the oop of this object in the given cache (at or atPut), along with its size, format and fixedSize" | hdr fmt totalLength fixedFields | self var: #cache declareC: 'int *cache'. hdr _ self baseHeader: rcvr. fmt _ (hdr >> 8) bitAnd: 16rF. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: ["Contexts must not be put in the atCache, since their size is not constant" ^ self primitiveFail]. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. cache at: atIx+AtCacheOop put: rcvr. stringy ifTrue: [cache at: atIx+AtCacheFmt put: fmt + 16] "special flag for strings" ifFalse: [cache at: atIx+AtCacheFmt put: fmt]. cache at: atIx+AtCacheFixedFields put: fixedFields. cache at: atIx+AtCacheSize put: totalLength - fixedFields. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 11/29/1998 21:24'! 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 | self inline: true. header _ self baseHeader: oop. ^ self lengthOf: oop baseHeader: header format: ((header >> 8) bitAnd: 16rF)! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'go 11/17/1998 15:55'! 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: SizeMask ]. fmt < 8 ifTrue: [ ^ (sz - BaseHeaderSize) >> 2 ] "words" ifFalse: [ ^ (sz - BaseHeaderSize) - (fmt bitAnd: 3) ] "bytes"! ! !Interpreter methodsFor: 'array and stream primitives'! primitiveAt self commonAt: false.! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/11/1998 10:15'! primitiveAtEnd | stream index limit | stream _ self popStack. successFlag _ ((self isPointers: stream) and: [(self lengthOf: stream) >= (StreamReadLimitIndex+1)]). successFlag ifTrue: [ index _ self fetchInteger: StreamIndexIndex ofObject: stream. limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream]. successFlag ifTrue: [self pushBool: (index >= limit)] ifFalse: [self unPop: 1].! ! !Interpreter methodsFor: 'array and stream primitives'! primitiveAtPut self commonAtPut: false.! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/14/1998 14:58'! primitiveNext "PrimitiveNext will succeed only if the stream's array is in the atCache. Otherwise failure will lead to proper message lookup of at: and subsequent installation in the cache if appropriate." | stream array index limit result atIx | stream _ self stackTop. ((self isPointers: stream) and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)]) ifFalse: [^ self primitiveFail]. array _ self fetchPointer: StreamArrayIndex ofObject: stream. index _ self fetchInteger: StreamIndexIndex ofObject: stream. limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream. atIx _ array bitAnd: AtCacheMask. (index < limit and: [(atCache at: atIx+AtCacheOop) = array]) ifFalse: [^ self primitiveFail]. "OK -- its not at end, and the array is in the cache" index _ index + 1. result _ self commonVariable: array at: index cacheIndex: atIx. "Above may cause GC, so can't use stream, array etc. below it" successFlag ifTrue: [stream _ self stackTop. self storeInteger: StreamIndexIndex ofObject: stream withValue: index. ^ self pop: 1 thenPush: result]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 12/14/1998 14:58'! primitiveNextPut "PrimitiveNextPut will succeed only if the stream's array is in the atPutCache. Otherwise failure will lead to proper message lookup of at:put: and subsequent installation in the cache if appropriate." | value stream index limit array atIx | value _ self stackTop. stream _ self stackValue: 1. ((self isPointers: stream) and: [(self lengthOf: stream) >= (StreamReadLimitIndex + 1)]) ifFalse: [^ self primitiveFail]. array _ self fetchPointer: StreamArrayIndex ofObject: stream. index _ self fetchInteger: StreamIndexIndex ofObject: stream. limit _ self fetchInteger: StreamReadLimitIndex ofObject: stream. atIx _ (array bitAnd: AtCacheMask) + AtPutBase. (index < limit and: [(atCache at: atIx+AtCacheOop) = array]) ifFalse: [^ self primitiveFail]. "OK -- its not at end, and the array is in the cache" index _ index + 1. self commonVariable: array at: index put: value cacheIndex: atIx. successFlag ifTrue: [self storeInteger: StreamIndexIndex ofObject: stream withValue: index. ^ self pop: 2 thenPush: value]. ! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 11/28/1998 15:15'! primitiveSize | rcvr sz | rcvr _ self stackTop. (self isIntegerObject: rcvr) ifTrue: [self primitiveFail] "integers have no indexable fields" ifFalse: [sz _ self stSizeOf: rcvr]. successFlag ifTrue: [self pop: 1 thenPush: (self positive32BitIntegerFor: sz)]! ! !Interpreter methodsFor: 'array and stream primitives'! primitiveStringAt self commonAt: true.! ! !Interpreter methodsFor: 'array and stream primitives'! primitiveStringAtPut self commonAtPut: true.! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ls 8/18/1998 06:24'! primitiveStringReplace " <array> primReplaceFrom: start to: stop with: replacement startingAt: repStart <primitive: 105> " | array start stop repl replStart hdr arrayFmt totalLength arrayInstSize replFmt replInstSize srcIndex | array _ self stackValue: 4. start _ self stackIntegerValue: 3. stop _ self stackIntegerValue: 2. repl _ self stackValue: 1. replStart _ self stackIntegerValue: 0. successFlag ifFalse: [^ self primitiveFail]. (self isIntegerObject: repl) "can happen in LgInt copy" ifTrue: [^ self primitiveFail]. hdr _ self baseHeader: array. arrayFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: array baseHeader: hdr format: arrayFmt. arrayInstSize _ self fixedFieldsOf: array format: arrayFmt length: totalLength. ((start >= 1) and: [(start <= stop) and: [stop + arrayInstSize <= totalLength]]) ifFalse: [^ self primitiveFail]. hdr _ self baseHeader: repl. replFmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: repl baseHeader: hdr format: replFmt. replInstSize _ self fixedFieldsOf: repl format: replFmt length: totalLength. ((replStart >= 1) and: [stop - start + replStart + replInstSize <= totalLength]) ifFalse: [^ self primitiveFail]. "Array formats (without byteSize bits, if bytes array) must be same" arrayFmt < 8 ifTrue: [arrayFmt = replFmt ifFalse: [^ self primitiveFail]] ifFalse: [(arrayFmt bitAnd: 16rC) = (replFmt bitAnd: 16rC) ifFalse: [^ self primitiveFail]]. srcIndex _ replStart + replInstSize - 1. " - 1 for 0-based access" arrayFmt < 4 ifTrue: [ "pointer type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storePointer: i ofObject: array withValue: (self fetchPointer: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ] ifFalse: [ arrayFmt < 8 ifTrue: [ "long-word type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeWord: i ofObject: array withValue: (self fetchWord: srcIndex ofObject: repl). srcIndex _ srcIndex + 1 ] ] ifFalse: [ "byte-type objects" start + arrayInstSize - 1 to: stop + arrayInstSize - 1 do: [:i | self storeByte: i ofObject: array withValue: (self fetchByte: srcIndex ofObject: repl). srcIndex _ srcIndex + 1. ] ]. ]. self pop: 4. "leave rcvr on stack"! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:38'! stObject: array at: index "Return what ST would return for <obj> at: index." | hdr fmt totalLength fixedFields stSize | 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. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: [stSize _ self fetchStackPointerOf: array] ifFalse: [stSize _ totalLength - fixedFields]. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [^ self subscript: array with: (index + fixedFields) format: fmt] ifFalse: [successFlag _ false. ^ 0].! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:39'! stObject: array at: index put: value "Do what ST would return for <obj> at: index put: value." | hdr fmt totalLength fixedFields stSize | 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. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: [stSize _ self fetchStackPointerOf: array] ifFalse: [stSize _ totalLength - fixedFields]. ((self cCoerce: index to: 'unsigned ') >= 1 and: [(self cCoerce: index to: 'unsigned ') <= (self cCoerce: stSize to: 'unsigned ')]) ifTrue: [self subscript: array with: (index + fixedFields) storing: value format: fmt] ifFalse: [successFlag _ false]! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'di 1/11/1999 10:39'! stSizeOf: oop "Return the number of indexable fields in the given object. (i.e., what Smalltalk would return for <obj> size)." "Note: Assume oop is not a SmallInteger!!" | hdr fmt totalLength fixedFields | self inline: true. hdr _ self baseHeader: oop. fmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: oop baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: oop format: fmt length: totalLength. (fmt = 3 and: [self isContextHeader: hdr]) ifTrue: [^ self fetchStackPointerOf: oop] ifFalse: [^ totalLength - fixedFields]! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ar 3/21/98 02:37'! subscript: array with: index format: fmt "Note: This method assumes that the index is within bounds!!" self inline: true. fmt <= 4 ifTrue: [ "pointer type objects" ^ self fetchPointer: index - 1 ofObject: array]. fmt < 8 ifTrue: [ "long-word type objects" ^ self positive32BitIntegerFor: (self fetchWord: index - 1 ofObject: array) ] ifFalse: [ "byte-type objects" ^ self integerObjectOf: (self fetchByte: index - 1 ofObject: array) ].! ! !Interpreter methodsFor: 'array and stream primitives' stamp: 'ar 3/21/98 02:38'! subscript: array with: index storing: oopToStore format: fmt "Note: This method assumes that the index is within bounds!!" | valueToStore | self inline: true. fmt <= 4 ifTrue: [ "pointer type objects" self storePointer: index - 1 ofObject: array withValue: oopToStore. ] ifFalse: [ fmt < 8 ifTrue: [ "long-word type objects" valueToStore _ self positive32BitValueOf: oopToStore. successFlag ifTrue: [self storeWord: index - 1 ofObject: array withValue: valueToStore]. ] ifFalse: [ "byte-type objects" (self isIntegerObject: oopToStore) ifFalse: [successFlag _ false]. valueToStore _ self integerValueOf: oopToStore. ((valueToStore >= 0) and: [valueToStore <= 255]) ifFalse: [successFlag _ false]. successFlag ifTrue: [self storeByte: index - 1 ofObject: array withValue: valueToStore]. ]. ].! ! !Interpreter methodsFor: 'object access primitives' stamp: 'di 1/9/1999 15:30'! primitiveArrayBecome "We must flush the method cache here, to eliminate stale references to mutated classes and/or selectors." | arg rcvr | arg _ self stackTop. rcvr _ self stackValue: 1. self success: (self become: rcvr with: arg twoWay: true). self flushMethodCache. successFlag ifTrue: [ self pop: 1 ].! ! !Interpreter methodsFor: 'object access primitives' stamp: 'di 1/9/1999 15:30'! primitiveArrayBecomeOneWay "We must flush the method cache here, to eliminate stale references to mutated classes and/or selectors." | arg rcvr | arg _ self stackTop. rcvr _ self stackValue: 1. self success: (self become: rcvr with: arg twoWay: false). self flushMethodCache. successFlag ifTrue: [ self pop: 1 ].! ! !Interpreter methodsFor: 'object access primitives'! primitiveAsOop | thisReceiver | thisReceiver _ self popStack. self success: (self isIntegerObject: thisReceiver) not. successFlag ifTrue: [self pushInteger: (self hashBitsOf: thisReceiver)] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'object access primitives'! primitiveClass | instance | instance _ self popStack. self push: (self fetchClassOf: instance)! ! !Interpreter methodsFor: 'object access primitives'! primitiveClone "Return a shallow copy of the receiver." | newCopy | newCopy _ self clone: (self stackTop). self pop: 1 thenPush: newCopy.! ! !Interpreter methodsFor: 'object access primitives'! primitiveEquivalent | thisObject otherObject | otherObject _ self popStack. thisObject _ self popStack. self pushBool: thisObject = otherObject! ! !Interpreter methodsFor: 'object access primitives'! primitiveInstVarAt | index rcvr hdr fmt totalLength fixedFields value | index _ self popInteger. rcvr _ self popStack. successFlag ifTrue: [ hdr _ self baseHeader: rcvr. fmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. ((index >= 1) and: [index <= fixedFields]) ifFalse: [successFlag _ false]]. successFlag ifTrue: [value _ self subscript: rcvr with: index format: fmt]. successFlag ifTrue: [self push: value] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'object access primitives'! primitiveInstVarAtPut | newValue index rcvr hdr fmt totalLength fixedFields | newValue _ self popStack. index _ self popInteger. rcvr _ self popStack. successFlag ifTrue: [ hdr _ self baseHeader: rcvr. fmt _ (hdr >> 8) bitAnd: 16rF. totalLength _ self lengthOf: rcvr baseHeader: hdr format: fmt. fixedFields _ self fixedFieldsOf: rcvr format: fmt length: totalLength. ((index >= 1) and: [index <= fixedFields]) ifFalse: [successFlag _ false]]. successFlag ifTrue: [self subscript: rcvr with: index storing: newValue format: fmt]. successFlag ifTrue: [self push: newValue] ifFalse: [self unPop: 3]! ! !Interpreter methodsFor: 'object access primitives'! primitiveNew "Allocate a new fixed-size instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free." | class spaceOkay | class _ self popStack. spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: 0. self success: spaceOkay. successFlag ifTrue: [ self push: (self instantiateClass: class indexableSize: 0) ] ifFalse: [ self unPop: 1 ].! ! !Interpreter methodsFor: 'object access primitives' stamp: 'di 12/27/1998 17:01'! primitiveNewWithArg "Allocate a new indexable instance. Fail if the allocation would leave less than lowSpaceThreshold bytes free." | size class spaceOkay | size _ self positive32BitValueOf: (self stackValue: 0). class _ self stackValue: 1. self success: size >= 0. successFlag ifTrue: [ spaceOkay _ self sufficientSpaceToInstantiate: class indexableSize: size. self success: spaceOkay. ]. successFlag ifTrue: [ self pop: 2 thenPush: (self instantiateClass: class indexableSize: size) ]! ! !Interpreter methodsFor: 'object access primitives'! primitiveNextInstance | object instance | object _ self popStack. instance _ self instanceAfter: object. instance = nilObj ifTrue: [self unPop: 1. self primitiveFail] ifFalse: [self push: instance]! ! !Interpreter methodsFor: 'object access primitives'! primitiveNextObject "Return the object following the receiver in the heap. Return the SmallInteger zero when there are no more objects." | object instance | object _ self popStack. instance _ self accessibleObjectAfter: object. instance = nil ifTrue: [ self pushInteger: 0 ] ifFalse: [ self push: instance ].! ! !Interpreter methodsFor: 'object access primitives'! primitiveObjectAt "Defined for CompiledMethods only" | thisReceiver index | index _ self popInteger. thisReceiver _ self popStack. self success: index > 0. self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart). successFlag ifTrue: [self push: (self fetchPointer: index - 1 ofObject: thisReceiver)] ifFalse: [self unPop: 2]! ! !Interpreter methodsFor: 'object access primitives'! primitiveObjectAtPut "Defined for CompiledMethods only" | thisReceiver index newValue | newValue _ self popStack. index _ self popInteger. thisReceiver _ self popStack. self success: index > 0. self success: index <= ((self literalCountOf: thisReceiver) + LiteralStart). successFlag ifTrue: [self storePointer: index - 1 ofObject: thisReceiver withValue: newValue. self push: newValue] ifFalse: [self unPop: 3]! ! !Interpreter methodsFor: 'object access primitives'! primitiveObjectPointsTo | rcvr thang lastField | thang _ self popStack. rcvr _ self popStack. (self isIntegerObject: rcvr) ifTrue: [^ self pushBool: false]. lastField _ self lastPointerOf: rcvr. BaseHeaderSize to: lastField by: 4 do: [:i | (self longAt: rcvr + i) = thang ifTrue: [^ self pushBool: true]]. self pushBool: false.! ! !Interpreter methodsFor: 'object access primitives' stamp: 'jm 12/10/1998 18:49'! primitivePointX | rcvr | self inline: false. rcvr _ self popStack. self assertClassOf: rcvr is: (self splObj: ClassPoint). successFlag ifTrue: [self push: (self fetchPointer: XIndex ofObject: rcvr)] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'object access primitives' stamp: 'jm 12/10/1998 18:50'! primitivePointY | rcvr | self inline: false. rcvr _ self popStack. self assertClassOf: rcvr is: (self splObj: ClassPoint). successFlag ifTrue: [self push: (self fetchPointer: YIndex ofObject: rcvr)] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'object access primitives' stamp: 'jm 1/6/98 18:44'! primitiveSomeInstance | class instance | class _ self popStack. instance _ self initialInstanceOf: class. instance = nilObj ifTrue: [self unPop: 1. self primitiveFail] ifFalse: [self push: instance]! ! !Interpreter methodsFor: 'object access primitives'! primitiveSomeObject "Return the first object in the heap." self pop: 1. self push: self firstAccessibleObject.! ! !Interpreter methodsFor: 'object access primitives' stamp: 'di 1/11/1999 13:20'! primitiveStoreStackp "Atomic store into context stackPointer. Also ensures that any newly accessible cells are initialized to nil" | ctxt newStackp stackp | ctxt _ self stackValue: 1. newStackp _ self stackIntegerValue: 0. self success: (newStackp >= 0). self success: (newStackp <= (LargeContextSize-BaseHeaderSize // 4 - CtxtTempFrameStart)). successFlag ifFalse: [^ self primitiveFail]. stackp _ self fetchStackPointerOf: ctxt. newStackp > stackp ifTrue: ["Nil any newly accessible cells" stackp + 1 to: newStackp do: [:i | self storePointer: i+CtxtTempFrameStart-1 ofObject: ctxt withValue: nilObj]]. self storeStackPointerValue: newStackp inContext: ctxt. self pop: 1 ! ! !Interpreter methodsFor: 'object access primitives' stamp: 'di 12/27/1998 16:28'! 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" ((self cCoerce: size to: 'unsigned ') > 0 and: [format < 2]) ifTrue: [ ^ false ]. format < 8 ifTrue: [ "indexable fields are words or pointers" okay _ self sufficientSpaceToAllocate: (2500 + (size * 4)). ] ifFalse: [ "indexable fields are bytes" okay _ self sufficientSpaceToAllocate: (2500 + size). ]. ^ okay! ! !Interpreter methodsFor: 'control primitives' stamp: 'di 1/10/1999 23:29'! primitiveBlockCopy | context methodContext contextSize newContext initialIP | context _ self stackValue: 1. (self isIntegerObject: (self fetchPointer: MethodIndex ofObject: context)) ifTrue: ["context is a block; get the context of its enclosing method" methodContext _ self fetchPointer: HomeIndex ofObject: context] ifFalse: [methodContext _ context]. contextSize _ self sizeBitsOf: methodContext. "in bytes, including header" context _ nil. "context is no longer needed and is not preserved across allocation" "remap methodContext in case GC happens during allocation" self pushRemappableOop: methodContext. newContext _ self instantiateContext: (self splObj: ClassBlockContext) sizeInBytes: contextSize. methodContext _ self popRemappableOop. initialIP _ self integerObjectOf: instructionPointer - method. "Was instructionPointer + 3, but now it's greater by methodOop + 4 (headerSize) and less by 1 due to preIncrement" "Assume: have just allocated a new context; it must be young. Thus, can use uncheck stores. See the comment in fetchContextRegisters." self storeWord: InitialIPIndex ofObject: newContext withValue: initialIP. self storeWord: InstructionPointerIndex ofObject: newContext withValue: initialIP. self storeStackPointerValue: 0 inContext: newContext. self storePointerUnchecked: BlockArgumentCountIndex ofObject: newContext withValue: (self stackValue: 0). self storePointerUnchecked: HomeIndex ofObject: newContext withValue: methodContext. self storePointerUnchecked: SenderIndex ofObject: newContext withValue: nilObj. self pop: 2 thenPush: newContext.! ! !Interpreter methodsFor: 'control primitives' stamp: 'jm 12/14/1998 09:53'! primitiveDoPrimitiveWithArgs | argumentArray arraySize index cntxSize primIdx | argumentArray _ self stackTop. arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize. self assertClassOf: 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. primitiveIndex _ primIdx. argumentCount _ arraySize. index _ 1. [index <= argumentCount] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index _ index + 1]. "Run the primitive (sets successFlag)" self pushRemappableOop: argumentArray. "prim might alloc/gc" lkupClass _ nilObj. self primitiveResponse. argumentArray _ self popRemappableOop. successFlag ifFalse: ["If primitive failed, then restore state for failure code" self pop: arraySize. self pushInteger: primIdx. self push: argumentArray. argumentCount _ 2. "... caller (execNewMeth) will run failure code"]! ! !Interpreter methodsFor: 'control primitives' stamp: 'ikp 12/15/1998 23:12'! primitivePerform | performSelector newReceiver selectorIndex lookupClass | 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. lookupClass _ self fetchClassOf: newReceiver. self findNewMethodInClass: lookupClass. self success: (self argumentCountOf: newMethod) = argumentCount. successFlag ifTrue: [selectorIndex _ self stackPointerIndex - argumentCount. self transfer: argumentCount fromIndex: selectorIndex + 1 ofObject: activeContext toIndex: selectorIndex ofObject: activeContext. self pop: 1. self executeNewMethod. "Recursive xeq affects successFlag" successFlag _ true] ifFalse: [argumentCount _ argumentCount + 1. messageSelector _ performSelector]! ! !Interpreter methodsFor: 'control primitives' stamp: 'ikp 12/15/1998 23:13'! primitivePerformWithArgs | thisReceiver performSelector argumentArray arraySize index cntxSize lookupClass | argumentArray _ self popStack. arraySize _ self fetchWordLengthOf: argumentArray. cntxSize _ self fetchWordLengthOf: activeContext. self success: (self stackPointerIndex + arraySize) < cntxSize. self assertClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifTrue: [performSelector _ messageSelector. messageSelector _ self popStack. thisReceiver _ self stackTop. argumentCount _ arraySize. index _ 1. [index <= argumentCount] whileTrue: [self push: (self fetchPointer: index - 1 ofObject: argumentArray). index _ index + 1]. lookupClass _ self fetchClassOf: thisReceiver. self findNewMethodInClass: lookupClass. self success: (self argumentCountOf: newMethod) = argumentCount. successFlag ifTrue: [self executeNewMethod. "Recursive xeq affects successFlag" successFlag _ true] ifFalse: [self pop: argumentCount. self push: messageSelector. self push: argumentArray. argumentCount _ 2. messageSelector _ performSelector]] ifFalse: [self unPop: 1]! ! !Interpreter methodsFor: 'control primitives'! primitiveValue | blockContext blockArgumentCount initialIP | blockContext _ self stackValue: argumentCount. blockArgumentCount _ self argumentCountOfBlock: blockContext. self success: (argumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj]). successFlag ifTrue: [self transfer: argumentCount fromIndex: self stackPointerIndex - argumentCount + 1 ofObject: activeContext toIndex: TempFrameStart ofObject: blockContext. "Assume: The call to transfer:... makes blockContext a root if necessary, allowing use to use unchecked stored in the following code." self pop: argumentCount + 1. initialIP _ self fetchPointer: InitialIPIndex ofObject: blockContext. self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP. self storeStackPointerValue: argumentCount inContext: blockContext. self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext. self newActiveContext: blockContext]! ! !Interpreter methodsFor: 'control primitives'! primitiveValueWithArgs | argumentArray blockContext blockArgumentCount arrayArgumentCount initialIP | argumentArray _ self popStack. blockContext _ self popStack. blockArgumentCount _ self argumentCountOfBlock: blockContext. self assertClassOf: argumentArray is: (self splObj: ClassArray). successFlag ifTrue: [ arrayArgumentCount _ self fetchWordLengthOf: argumentArray. self success: (arrayArgumentCount = blockArgumentCount and: [(self fetchPointer: CallerIndex ofObject: blockContext) = nilObj])]. successFlag ifTrue: [ self transfer: arrayArgumentCount fromIndex: 0 ofObject: argumentArray toIndex: TempFrameStart ofObject: blockContext. "Assume: The call to transfer:... makes blockContext a root if necessary, allowing use to use unchecked stored in the following code." initialIP _ self fetchPointer: InitialIPIndex ofObject: blockContext. self storePointerUnchecked: InstructionPointerIndex ofObject: blockContext withValue: initialIP. self storeStackPointerValue: arrayArgumentCount inContext: blockContext. self storePointerUnchecked: CallerIndex ofObject: blockContext withValue: activeContext. self newActiveContext: blockContext. ] ifFalse: [self unPop: 2].! ! !Interpreter methodsFor: 'processes'! addLastLink: proc toList: aList "Add the given process to the given linked list and set the backpointer of process to its new list." | lastLink | (self isEmptyList: aList) ifTrue: [ self storePointer: FirstLinkIndex ofObject: aList withValue: proc. ] ifFalse: [ lastLink _ self fetchPointer: LastLinkIndex ofObject: aList. self storePointer: NextLinkIndex ofObject: lastLink withValue: proc. ]. self storePointer: LastLinkIndex ofObject: aList withValue: proc. self storePointer: MyListIndex ofObject: proc withValue: aList.! ! !Interpreter methodsFor: 'processes' stamp: 'ikp 12/19/1998 03:44'! checkForInterrupts "Check for possible interrupts and handle one if necessary." | sema now index | self inline: false. interruptCheckCounter _ 1000. "reset the interrupt check counter" "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 any pending finalizations" pendingFinalizationSignals > 0 ifTrue:[ sema _ self splObj: TheFinalizationSemaphore. (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue:[self synchronousSignal: sema]. pendingFinalizationSignals _ 0. ]. "signal all semaphores in semaphoresToSignal" semaphoresToSignalCount > 0 ifTrue: [ 1 to: semaphoresToSignalCount do: [:i | index _ semaphoresToSignal at: i. sema _ self fetchPointer: index - 1 ofObject: (self splObj: ExternalObjectsArray). "Note: semaphore indices are 1-based" (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [self synchronousSignal: sema]]. semaphoresToSignalCount _ 0]. ! ! !Interpreter methodsFor: 'processes' stamp: 'jm 8/22/1998 09:34'! internalQuickCheckForInterrupts "Internal version of quickCheckForInterrupts for use within jumps." ((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [ self externalizeIPandSP. self checkForInterrupts. self internalizeIPandSP]. ! ! !Interpreter methodsFor: 'processes'! isEmptyList: aLinkedList ^ (self fetchPointer: FirstLinkIndex ofObject: aLinkedList) = nilObj! ! !Interpreter methodsFor: 'processes'! primitiveResume | proc | proc _ self stackTop. "rcvr" "self success: ((self fetchClassOf: proc) = (self splObj: ClassProcess))." successFlag ifTrue: [ self resume: proc ].! ! !Interpreter methodsFor: 'processes'! primitiveSignal | sema | sema _ self stackTop. "rcvr" self assertClassOf: sema is: (self splObj: ClassSemaphore). successFlag ifTrue: [ self synchronousSignal: sema ].! ! !Interpreter methodsFor: 'processes'! primitiveSuspend | activeProc | activeProc _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. self success: self stackTop = activeProc. successFlag ifTrue: [ self pop: 1. self push: nilObj. self transferTo: self wakeHighestPriority. ].! ! !Interpreter methodsFor: 'processes'! primitiveWait | sema excessSignals activeProc | sema _ self stackTop. "rcvr" self assertClassOf: sema is: (self splObj: ClassSemaphore). successFlag ifTrue: [ excessSignals _ self fetchInteger: ExcessSignalsIndex ofObject: sema. excessSignals > 0 ifTrue: [ self storeInteger: ExcessSignalsIndex ofObject: sema withValue: excessSignals - 1. ] ifFalse: [ activeProc _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. self addLastLink: activeProc toList: sema. self transferTo: self wakeHighestPriority. ]. ].! ! !Interpreter methodsFor: 'processes'! putToSleep: aProcess "Save the given process on the scheduler process list for its priority." | priority processLists processList | priority _ self quickFetchInteger: PriorityIndex ofObject: aProcess. processLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. processList _ self fetchPointer: priority - 1 ofObject: processLists. self addLastLink: aProcess toList: processList.! ! !Interpreter methodsFor: 'processes' stamp: 'jm 8/22/1998 09:37'! 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 that trigger interrupts should set interruptCheckCounter to zero to get immediate results." "Note: Requires that instructionPointer and stackPointer be external." ((interruptCheckCounter _ interruptCheckCounter - 1) <= 0) ifTrue: [self checkForInterrupts]. ! ! !Interpreter methodsFor: 'processes'! removeFirstLinkOfList: aList "Remove the first process from the given linked list." | first last next | first _ self fetchPointer: FirstLinkIndex ofObject: aList. last _ self fetchPointer: LastLinkIndex ofObject: aList. first = last ifTrue: [ self storePointer: FirstLinkIndex ofObject: aList withValue: nilObj. self storePointer: LastLinkIndex ofObject: aList withValue: nilObj. ] ifFalse: [ next _ self fetchPointer: NextLinkIndex ofObject: first. self storePointer: FirstLinkIndex ofObject: aList withValue: next. ]. self storePointer: NextLinkIndex ofObject: first withValue: nilObj. ^ first! ! !Interpreter methodsFor: 'processes'! resume: aProcess | activeProc activePriority newPriority | self inline: false. activeProc _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. activePriority _ self quickFetchInteger: PriorityIndex ofObject: activeProc. newPriority _ self quickFetchInteger: PriorityIndex ofObject: aProcess. newPriority > activePriority ifTrue: [ self putToSleep: activeProc. self transferTo: aProcess. ] ifFalse: [ self putToSleep: aProcess. ].! ! !Interpreter methodsFor: 'processes'! schedulerPointer ^ self fetchPointer: ValueIndex ofObject: (self splObj: SchedulerAssociation)! ! !Interpreter methodsFor: 'processes' stamp: 'ar 3/21/98 18:39'! signalFinalization: weakReferenceOop "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." interruptCheckCounter _ 0. pendingFinalizationSignals _ pendingFinalizationSignals + 1.! ! !Interpreter methodsFor: 'processes' stamp: 'jm 8/24/97 22:55'! signalSemaphoreWithIndex: index "If it is not there already, record the given semaphore index in the list of semaphores to be signaled at the next convenient moment. Set the interruptCheckCounter to zero to force a real interrupt check as soon as possible." index <= 0 ifTrue: [^ nil]. "bad index; ignore it" interruptCheckCounter _ 0. 1 to: semaphoresToSignalCount do: [:i | (semaphoresToSignal at: i) = index ifTrue: [^ nil]]. semaphoresToSignalCount < SemaphoresToSignalSize ifTrue: [ semaphoresToSignalCount _ semaphoresToSignalCount + 1. semaphoresToSignal at: semaphoresToSignalCount put: index]. ! ! !Interpreter methodsFor: 'processes'! synchronousSignal: aSemaphore "Signal the given semaphore from within the interpreter." | excessSignals | self inline: false. (self isEmptyList: aSemaphore) ifTrue: [ "no process is waiting on this semaphore" excessSignals _ self fetchInteger: ExcessSignalsIndex ofObject: aSemaphore. self storeInteger: ExcessSignalsIndex ofObject: aSemaphore withValue: excessSignals + 1. ] ifFalse: [ self resume: (self removeFirstLinkOfList: aSemaphore). ].! ! !Interpreter methodsFor: 'processes' stamp: 'jm 11/15/2003 06:38'! transferTo: aProc "Record a process to be awoken on the next interpreter cycle." | sched oldProc newProc | newProc _ aProc. sched _ self schedulerPointer. oldProc _ self fetchPointer: ActiveProcessIndex ofObject: sched. self storePointer: SuspendedContextIndex ofObject: oldProc withValue: activeContext. self storePointer: ActiveProcessIndex ofObject: sched withValue: newProc. self newActiveContext: (self fetchPointer: SuspendedContextIndex ofObject: newProc). reclaimableContextCount _ 0. ! ! !Interpreter methodsFor: 'processes'! wakeHighestPriority "Return the highest priority process that is ready to run." "Note: It is a fatal VM error if there is no runnable process." | schedLists p processList | schedLists _ self fetchPointer: ProcessListsIndex ofObject: self schedulerPointer. p _ self fetchWordLengthOf: schedLists. p _ p - 1. "index of last indexable field" processList _ self fetchPointer: p ofObject: schedLists. [self isEmptyList: processList] whileTrue: [ p _ p - 1. p < 0 ifTrue: [ self error: 'scheduler could not find a runnable process' ]. processList _ self fetchPointer: p ofObject: schedLists. ]. ^ self removeFirstLinkOfList: processList! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 12/29/2003 22:18'! fullDisplayUpdate "Repaint the entire smalltalk screen, ignoring the affected rectangle. Used when the Smalltalk window is brought to the front or uncovered." | displayObj dispBits w h dispBitsIndex d | displayObj _ self splObj: TheDisplay. ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]) ifTrue: [ dispBits _ self fetchPointer: 0 ofObject: displayObj. w _ self fetchInteger: 1 ofObject: displayObj. h _ self fetchInteger: 2 ofObject: displayObj. d _ self fetchInteger: 3 ofObject: displayObj. dispBitsIndex _ dispBits + BaseHeaderSize. "index in memory byte array" self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, 0, w, 0, h)']. ! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 1/3/2004 12:38'! primitiveBeCursor "Set the cursor to the given shape. The Mac only supports 16x16 pixel cursors. Cursor offsets are handled by Smalltalk." | cursorObj maskBitsIndex maskObj bitsObj extentX extentY depth offsetObj offsetX offsetY cursorBitsIndex | argumentCount = 0 ifTrue: [ cursorObj _ self stackTop. maskBitsIndex _ nil]. argumentCount = 1 ifTrue: [ cursorObj _ self stackValue: 1. maskObj _ self stackTop]. self success: (argumentCount < 2). 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. depth _ self fetchInteger: 3 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 and: [depth = 1]]). 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]. argumentCount = 1 ifTrue: [ self success: ((self isPointers: maskObj) and: [(self lengthOf: maskObj) >= 5]). successFlag ifTrue: [ bitsObj _ self fetchPointer: 0 ofObject: maskObj. extentX _ self fetchInteger: 1 ofObject: maskObj. extentY _ self fetchInteger: 2 ofObject: maskObj. depth _ self fetchInteger: 3 ofObject: maskObj]. successFlag ifTrue: [ self success: ((extentX = 16) and: [extentY = 16 and: [depth = 1]]). self success: ((self isWords: bitsObj) and: [(self lengthOf: bitsObj) = 16]). maskBitsIndex _ bitsObj + BaseHeaderSize]]. successFlag ifTrue: [ argumentCount = 0 ifTrue: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, null, offsetX, offsetY)'] ifFalse: [self cCode: 'ioSetCursorWithMask(cursorBitsIndex, maskBitsIndex, offsetX, offsetY)']. self pop: argumentCount]. ! ! !Interpreter methodsFor: 'I/O primitives'! primitiveBeep self ioBeep.! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'di 6/29/1998 22:58'! primitiveCopyBits "Invoke the copyBits primitive. If the destination is the display, then copy it to the screen." | rcvr | rcvr _ self stackValue: argumentCount. self success: (self loadBitBltFrom: rcvr). successFlag ifTrue: [ self copyBits. self showDisplayBits. ].! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 20:08'! 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" ! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'di 1/10/1999 12:54'! 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]. successFlag ifTrue: [self pop: 2].! ! !Interpreter methodsFor: 'I/O primitives'! primitiveInterruptSemaphore "Register the user interrupt semaphore. If the argument is not a Semaphore, unregister the current interrupt semaphore." | arg | arg _ self popStack. ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [ self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: arg. ] ifFalse: [ self storePointer: TheInterruptSemaphore ofObject: specialObjectsOop withValue: nilObj. ].! ! !Interpreter methodsFor: 'I/O primitives'! primitiveKbdNext "Return the next keycode and remove it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>." | keystrokeWord | self pop: 1. keystrokeWord _ self ioGetKeystroke. keystrokeWord >= 0 ifTrue: [self pushInteger: keystrokeWord] ifFalse: [self push: nilObj].! ! !Interpreter methodsFor: 'I/O primitives'! primitiveKbdPeek "Return the next keycode and without removing it from the input buffer. The low byte is the 8-bit ISO character. The next four bits are the Smalltalk modifier bits <cmd><option><ctrl><shift>." | keystrokeWord | self pop: 1. keystrokeWord _ self ioPeekKeystroke. keystrokeWord >= 0 ifTrue: [self pushInteger: keystrokeWord] ifFalse: [self push: nilObj].! ! !Interpreter methodsFor: 'I/O primitives'! primitiveMouseButtons "Return the mouse button state. The low three bits encode the state of the <red><yellow><blue> mouse buttons. The next four bits encode the Smalltalk modifier bits <cmd><option><ctrl><shift>." | buttonWord | self pop: 1. buttonWord _ self ioGetButtonState. self pushInteger: buttonWord.! ! !Interpreter methodsFor: 'I/O primitives'! primitiveMousePoint "Return a Point indicating current position of the mouse. Note that mouse coordinates may be negative if the mouse moves above or to the left of the top-left corner of the Smalltalk window." | pointWord x y | self pop: 1. pointWord _ self ioMousePoint. x _ self signExtend16: ((pointWord >> 16) bitAnd: 16rFFFF). y _ self signExtend16: (pointWord bitAnd: 16rFFFF). self push: (self makePointwithxValue: x yValue: y).! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 11/16/2003 21:41'! primitivePutChar "Write one character to stdout." | ch | ch _ self stackIntegerValue: 0. successFlag ifFalse: [^ self primitiveFail]. self ioPutChar: ch. self pop: 2. ! ! !Interpreter methodsFor: 'I/O primitives'! primitiveScreenSize "Return a point indicating the current size of the Smalltalk window." | pointWord | self pop: 1. pointWord _ self ioScreenSize. self push: (self makePointwithxValue: ((pointWord >>16) bitAnd: 16rFFFF) yValue: (pointWord bitAnd: 16rFFFF)).! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/17/1998 07:08'! primitiveSetFullScreen "On platforms that support it, set full-screen mode to the value of the boolean argument." | argOop | argOop _ self stackTop. argOop = trueObj ifTrue: [self ioSetFullScreen: true] ifFalse: [ argOop = falseObj ifTrue: [self ioSetFullScreen: false] ifFalse: [self primitiveFail]]. successFlag ifTrue: [self pop: 1]. ! ! !Interpreter methodsFor: 'I/O primitives'! primitiveSetInterruptKey "Set the user interrupt keycode. The keycode is an integer whose encoding is described in the comment for primitiveKbdNext." | keycode | keycode _ self popInteger. successFlag ifTrue: [ interruptKeycode _ keycode ] ifFalse: [ self unPop: 1 ].! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 12/29/2003 22:18'! primitiveShowDisplayRect "Force the given rectangular section of the Display to be copied to the screen." | bottom top right left displayObj dispBits w h d dispBitsPtr | bottom _ self stackIntegerValue: 0. top _ self stackIntegerValue: 1. right _ self stackIntegerValue: 2. left _ self stackIntegerValue: 3. displayObj _ self splObj: TheDisplay. self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]). successFlag ifTrue: [ dispBits _ self fetchPointer: 0 ofObject: displayObj. w _ self fetchInteger: 1 ofObject: displayObj. h _ self fetchInteger: 2 ofObject: displayObj. d _ self fetchInteger: 3 ofObject: displayObj]. left < 0 ifTrue: [left _ 0]. right > w ifTrue: [right _ w]. top < 0 ifTrue: [top _ 0]. bottom > h ifTrue: [bottom _ h]. self success: ((left <= right) and: [top <= bottom]). successFlag ifTrue: [ dispBitsPtr _ dispBits + BaseHeaderSize. self cCode: 'ioShowDisplay(dispBitsPtr, w, h, d, left, right, top, bottom)']. successFlag ifTrue: [self pop: 4]. "pop left, right, top, bottom; leave rcvr on stack" ! ! !Interpreter methodsFor: 'I/O primitives'! primitiveWarpBits "Invoke the warpBits primitive. If the destination is the display, then copy it to the screen." | rcvr | rcvr _ self stackValue: self argCount. self success: (self loadBitBltFrom: rcvr). successFlag ifTrue: [ self warpBits. self showDisplayBits. ].! ! !Interpreter methodsFor: 'I/O primitives' stamp: 'jm 5/16/1998 22:58'! showDisplayBits "Repaint the portion of the Smalltalk screen bounded by the affected rectangle. Used to synchronize the screen after a Bitblt to the Smalltalk Display object." | displayObj dispBits w h affectedRectL affectedRectR affectedRectT affectedRectB dispBitsIndex d | deferDisplayUpdates ifTrue: [^ nil]. displayObj _ self splObj: TheDisplay. self targetForm = displayObj ifFalse: [^ nil]. self success: ((self isPointers: displayObj) and: [(self lengthOf: displayObj) >= 4]). successFlag ifTrue: [ dispBits _ self fetchPointer: 0 ofObject: displayObj. w _ self fetchInteger: 1 ofObject: displayObj. h _ self fetchInteger: 2 ofObject: displayObj. d _ self fetchInteger: 3 ofObject: displayObj. ]. successFlag ifTrue: [ affectedRectL _ self affectedLeft. affectedRectR _ self affectedRight. affectedRectT _ self affectedTop. affectedRectB _ self affectedBottom. dispBitsIndex _ dispBits + BaseHeaderSize. "index in memory byte array" self cCode: 'ioShowDisplay(dispBitsIndex, w, h, d, affectedRectL, affectedRectR, affectedRectT, affectedRectB)'. ].! ! !Interpreter methodsFor: 'file primitives'! fileRecordSize "Return the size of a Smalltalk file record in bytes." ^ self cCode: 'sizeof(SQFile)'.! ! !Interpreter methodsFor: 'file primitives'! fileValueOf: objectPointer "Return a pointer to the first byte of of the file record within the given Smalltalk object, or nil if objectPointer is not a file record." | fileIndex | self returnTypeC: 'SQFile *'. self success: ((self isBytes: objectPointer) and: [(self lengthOf: objectPointer) = self fileRecordSize]). successFlag ifTrue: [ fileIndex _ objectPointer + BaseHeaderSize. ^ self cCode: '(SQFile *) fileIndex' ] ifFalse: [ ^ nil ].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileAtEnd | file atEnd | self var: 'file' declareC: 'SQFile *file'. file _ self fileValueOf: self stackTop. successFlag ifTrue: [ atEnd _ self sqFileAtEnd: file ]. successFlag ifTrue: [ self pop: 2. "rcvr, file" self pushBool: atEnd. ].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileClose | file | self var: 'file' declareC: 'SQFile *file'. file _ self fileValueOf: self stackTop. successFlag ifTrue: [ self sqFileClose: file ]. successFlag ifTrue: [ self pop: 1 "pop file; leave rcvr on stack" ].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileDelete | namePointer nameIndex nameSize | namePointer _ self stackTop. self success: (self isBytes: namePointer). successFlag ifTrue: [ nameIndex _ namePointer + BaseHeaderSize. nameSize _ self lengthOf: namePointer. ]. successFlag ifTrue: [ self sqFileDeleteName: nameIndex Size: nameSize. ]. successFlag ifTrue: [ self pop: 1. "pop name, leave rcvr on stack" ]. ! ! !Interpreter methodsFor: 'file primitives' stamp: 'di 12/15/1998 21:55'! primitiveFileGetPosition | file position | self var: 'file' declareC: 'SQFile *file'. file _ self fileValueOf: (self stackTop). successFlag ifTrue: [position _ self sqFileGetPosition: file]. successFlag ifTrue: [self pop: 2 thenPush: (self positive32BitIntegerFor: position)].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileOpen | writeFlag namePointer filePointer file nameIndex nameSize | self var: 'file' declareC: 'SQFile *file'. writeFlag _ self booleanValueOf: (self stackTop). namePointer _ self stackValue: 1. self success: (self isBytes: namePointer). successFlag ifTrue: [ filePointer _ self instantiateClass: (self splObj: ClassByteArray) indexableSize: self fileRecordSize. file _ self fileValueOf: filePointer. nameIndex _ namePointer + BaseHeaderSize. nameSize _ self lengthOf: namePointer. ]. successFlag ifTrue: [ self cCode: 'sqFileOpen(file, nameIndex, nameSize, writeFlag)'. ]. successFlag ifTrue: [ self pop: 3. "rcvr, name, writeFlag" self push: filePointer. ].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileRead | count startIndex array file byteSize arrayIndex bytesRead | self var: 'file' declareC: 'SQFile *file'. count _ self stackIntegerValue: 0. startIndex _ self stackIntegerValue: 1. array _ self stackValue: 2. file _ self fileValueOf: (self stackValue: 3). "buffer can be any indexable words or bytes object except CompiledMethod" self success: (self isWordsOrBytes: array). (self isWords: array) ifTrue: [ byteSize _ 4 ] ifFalse: [ byteSize _ 1 ]. self success: ( (startIndex >= 1) and: [(startIndex + count - 1) <= (self lengthOf: array)]). successFlag ifTrue: [ arrayIndex _ array + BaseHeaderSize. "Note: adjust startIndex for zero-origin indexing" bytesRead _ self sqFile: file Read: (count * byteSize) Into: arrayIndex At: ((startIndex - 1) * byteSize). ]. successFlag ifTrue: [ self pop: 5. "pop rcvr, file, array, startIndex, count" self pushInteger: bytesRead // byteSize. "push # of elements read" ].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileRename | oldNamePointer newNamePointer oldNameIndex oldNameSize newNameIndex newNameSize | newNamePointer _ self stackTop. oldNamePointer _ self stackValue: 1. self success: (self isBytes: newNamePointer). self success: (self isBytes: oldNamePointer). successFlag ifTrue: [ newNameIndex _ newNamePointer + BaseHeaderSize. newNameSize _ self lengthOf: newNamePointer. oldNameIndex _ oldNamePointer + BaseHeaderSize. oldNameSize _ self lengthOf: oldNamePointer. ]. successFlag ifTrue: [ self sqFileRenameOld: oldNameIndex Size: oldNameSize New: newNameIndex Size: newNameSize. ]. successFlag ifTrue: [ self pop: 2. "pop new and old names, leave rcvr on stack" ].! ! !Interpreter methodsFor: 'file primitives' stamp: 'di 12/15/1998 21:58'! primitiveFileSetPosition | newPosition file | self var: 'file' declareC: 'SQFile *file'. newPosition _ self positive32BitValueOf: (self stackValue: 0). file _ self fileValueOf: (self stackValue: 1). successFlag ifTrue: [ self sqFile: file SetPosition: newPosition ]. successFlag ifTrue: [ self pop: 2 "pop position, file; leave rcvr on stack" ].! ! !Interpreter methodsFor: 'file primitives' stamp: 'di 12/15/1998 21:56'! primitiveFileSize | file size | self var: 'file' declareC: 'SQFile *file'. file _ self fileValueOf: (self stackTop). successFlag ifTrue: [size _ self sqFileSize: file]. successFlag ifTrue: [self pop: 2 thenPush: (self positive32BitIntegerFor: size)].! ! !Interpreter methodsFor: 'file primitives'! primitiveFileWrite | count startIndex array file byteSize arrayIndex bytesWritten | self var: 'file' declareC: 'SQFile *file'. count _ self stackIntegerValue: 0. startIndex _ self stackIntegerValue: 1. array _ self stackValue: 2. file _ self fileValueOf: (self stackValue: 3). "buffer can be any indexable words or bytes object except CompiledMethod" self success: (self isWordsOrBytes: array). (self isWords: array) ifTrue: [ byteSize _ 4 ] ifFalse: [ byteSize _ 1 ]. self success: ( (startIndex >= 1) and: [(startIndex + count - 1) <= (self lengthOf: array)]). successFlag ifTrue: [ arrayIndex _ array + BaseHeaderSize. "Note: adjust startIndex for zero-origin indexing" bytesWritten _ self sqFile: file Write: (count * byteSize) From: arrayIndex At: ((startIndex - 1) * byteSize). ]. successFlag ifTrue: [ self pop: 5. "pop rcvr, file, array, startIndex, count" self pushInteger: bytesWritten // byteSize. "push # of elements written" ].! ! !Interpreter methodsFor: 'memory space primitives'! primitiveBytesLeft "Reports bytes available at this moment. For more meaningful results, calls to this primitive should be preceeded by a full or incremental garbage collection." self pop: 1. self pushInteger: (self sizeOfFree: freeBlock).! ! !Interpreter methodsFor: 'memory space primitives'! primitiveFullGC "Do a quick, incremental garbage collection and return the number of bytes available." self pop: 1. self incrementalGC. "maximimize space for forwarding table" self fullGC. self pushInteger: (self sizeOfFree: freeBlock).! ! !Interpreter methodsFor: 'memory space primitives'! primitiveIncrementalGC "Do a quick, incremental garbage collection and return the number of bytes immediately available. (Note: more space may be made available by doing a full garbage collection." self pop: 1. self incrementalGC. self pushInteger: (self sizeOfFree: freeBlock).! ! !Interpreter methodsFor: 'memory space primitives'! primitiveLowSpaceSemaphore "Register the low-space semaphore. If the argument is not a Semaphore, unregister the current low-space Semaphore." | arg | arg _ self popStack. ((self fetchClassOf: arg) = (self splObj: ClassSemaphore)) ifTrue: [ self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: arg. ] ifFalse: [ self storePointer: TheLowSpaceSemaphore ofObject: specialObjectsOop withValue: nilObj. ].! ! !Interpreter methodsFor: 'memory space primitives'! primitiveSignalAtBytesLeft "Set the low-water mark for free space. When the free space falls below this level, the new and new: primitives fail and system attempts to allocate space (e.g., to create a method context) cause the low-space semaphore (if one is registered) to be signalled." | bytes | bytes _ self popInteger. successFlag ifTrue: [ lowSpaceThreshold _ bytes ] ifFalse: [ lowSpaceThreshold _ 0. self unPop: 1. ].! ! !Interpreter methodsFor: 'other primitives' stamp: 'di 6/7/97 09:59'! primitiveConstantFill "Fill the receiver, which must be an indexable bytes or words objects, with the given integer value." | fillValue rcvr rcvrIsBytes end i | fillValue _ self positive32BitValueOf: self stackTop. rcvr _ self stackValue: 1. self success: (self isWordsOrBytes: rcvr). rcvrIsBytes _ self isBytes: rcvr. rcvrIsBytes ifTrue: [ self success: ((fillValue >= 0) and: [fillValue <= 255]). ]. successFlag ifTrue: [ end _ rcvr + (self sizeBitsOf: rcvr). i _ rcvr + BaseHeaderSize. rcvrIsBytes ifTrue: [ [i < end] whileTrue: [ self byteAt: i put: fillValue. i _ i + 1. ]. ] ifFalse: [ [i < end] whileTrue: [ self longAt: i put: fillValue. i _ i + 4. ]. ]. self pop: 1. "pop fillValue; leave rcvr on stack" ]. ! ! !Interpreter methodsFor: 'other primitives' stamp: 'jm 12/30/2003 20:06'! primitiveExitToDebugger self error: 'Exit to debugger at user request'. self printCallStackFrom: activeContext. ! ! !Interpreter methodsFor: 'other primitives'! primitiveFlushCache "Clear the method lookup cache. This must be done after every programming change." self flushMethodCache.! ! !Interpreter methodsFor: 'other primitives' stamp: 'jm 11/15/2003 06:43'! primitiveFlushCacheByMethod "The receiver is a compiledMethod. Clear all entries in the method lookup cache that refer to this method, presumably because it has been redefined, overridden or removed." | probe oldMethod | oldMethod _ self stackTop. probe _ 0. 1 to: MethodCacheEntries do: [:i | (methodCache at: probe + MethodCacheMethod) = oldMethod ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]. probe _ probe + MethodCacheEntrySize]. ! ! !Interpreter methodsFor: 'other primitives' stamp: 'jm 12/14/1998 14:32'! primitiveFlushCacheSelective "The receiver is a message selector. Clear all entries in the method lookup cache with this selector, presumably because an associated method has been redefined." | selector probe | selector _ self stackTop. probe _ 0. 1 to: MethodCacheEntries do: [:i | (methodCache at: probe + MethodCacheSelector) = selector ifTrue: [methodCache at: probe + MethodCacheSelector put: 0]. probe _ probe + MethodCacheEntrySize]! ! !Interpreter methodsFor: 'other primitives' stamp: 'jm 9/14/97 10:53'! primitiveMillisecondClock "Return the value of the millisecond clock as an integer. Note that the millisecond clock wraps around periodically. On some platforms it can wrap daily. The range is limited to SmallInteger maxVal / 2 to allow delays of up to that length without overflowing a SmallInteger." self pop: 1. "pop rcvr" self push: (self integerObjectOf: (self ioMSecs bitAnd: 16r1FFFFFFF)). ! ! !Interpreter methodsFor: 'other primitives'! primitiveQuit self ioExit. ! ! !Interpreter methodsFor: 'other primitives'! primitiveSecondsClock "Return the number of seconds since January 1, 1901 as an integer." self pop: 1. "pop rcvr" self push: (self positive32BitIntegerFor: self ioSeconds).! ! !Interpreter methodsFor: 'other primitives'! primitiveShortAt "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Return the contents of the given index. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | index _ self stackIntegerValue: 0. rcvr _ self stackValue: 1. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). value _ self cCode: '*((short int *) addr)'. self pop: 2. "pop rcvr, index" self pushInteger: value. "push element value" ].! ! !Interpreter methodsFor: 'other primitives'! primitiveShortAtPut "Treat the receiver, which can be indexible by either bytes or words, as an array of signed 16-bit values. Set the contents of the given index to the given value. Note that the index specifies the i-th 16-bit entry, not the i-th byte or word." | index rcvr sz addr value | value _ self stackIntegerValue: 0. index _ self stackIntegerValue: 1. rcvr _ self stackValue: 2. self success: ((self isIntegerObject: rcvr) not and: [self isWordsOrBytes: rcvr]). successFlag ifFalse: [ ^ nil ]. sz _ ((self sizeBitsOf: rcvr) - BaseHeaderSize) // 2. "number of 16-bit fields" self success: ((index >= 1) and: [index <= sz]). self success: ((value >= -32768) and: [value <= 32767]). successFlag ifTrue: [ addr _ rcvr + BaseHeaderSize + (2 * (index - 1)). self cCode: '*((short int *) addr) = value'. self pop: 2. "pop index and value; leave rcvr on stack" ].! ! !Interpreter methodsFor: 'other primitives'! primitiveSignalAtMilliseconds "Cause the time semaphore, if one has been registered, to be signalled when the millisecond clock is greater than or equal to the given tick value. A tick value of zero turns off timer interrupts." | tick sema | tick _ self popInteger. sema _ self popStack. successFlag ifTrue: [ (self fetchClassOf: sema) = (self splObj: ClassSemaphore) ifTrue: [ self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: sema. nextWakeupTick _ tick. ] ifFalse: [ self storePointer: TheTimerSemaphore ofObject: specialObjectsOop withValue: nilObj. nextWakeupTick _ 0. ]. ] ifFalse: [ self unPop: 2. "sema, tick" ].! ! !Interpreter methodsFor: 'other primitives'! primitiveSpecialObjectsOop "Return the oop of the SpecialObjectsArray." self pop: 1. self push: specialObjectsOop.! ! !Interpreter methodsFor: 'other primitives' stamp: 'jm 2/3/98 13:04'! primitiveVMParameter "Behaviour depends on argument count: 0 args: return an Array of VM parameter values; 1 arg: return the indicated VM parameter; 2 args: set the VM indicated parameter. VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM 21 root table size (read-only) 22 root table overflows since startup (read-only) Note: Thanks to Ian Piumarta for this primitive." | mem paramsArraySize result arg index | mem _ self cCoerce: memory to: 'int'. argumentCount = 0 ifTrue: [ paramsArraySize _ 22. result _ self instantiateClass: (self splObj: ClassArray) indexableSize: paramsArraySize. 0 to: paramsArraySize - 1 do: [:i | self storeWord: i ofObject: result withValue: (self integerObjectOf: 0)]. self storeWord: 0 ofObject: result withValue: (self integerObjectOf: youngStart - mem). self storeWord: 1 ofObject: result withValue: (self integerObjectOf: freeBlock - mem). self storeWord: 2 ofObject: result withValue: (self integerObjectOf: endOfMemory - mem). self storeWord: 3 ofObject: result withValue: (self integerObjectOf: allocationCount). self storeWord: 4 ofObject: result withValue: (self integerObjectOf: allocationsBetweenGCs). self storeWord: 5 ofObject: result withValue: (self integerObjectOf: tenuringThreshold). self storeWord: 6 ofObject: result withValue: (self integerObjectOf: statFullGCs). self storeWord: 7 ofObject: result withValue: (self integerObjectOf: statFullGCMSecs). self storeWord: 8 ofObject: result withValue: (self integerObjectOf: statIncrGCs). self storeWord: 9 ofObject: result withValue: (self integerObjectOf: statIncrGCMSecs). self storeWord: 10 ofObject: result withValue: (self integerObjectOf: statTenures). self storeWord: 20 ofObject: result withValue: (self integerObjectOf: rootTableCount). self storeWord: 21 ofObject: result withValue: (self integerObjectOf: statRootTableOverflows). self pop: 1 thenPush: result. ^nil]. arg _ self stackTop. (self isIntegerObject: arg) ifFalse: [^self primitiveFail]. arg _ self integerValueOf: arg. argumentCount = 1 ifTrue: [ "read VM parameter" (arg < 1 or: [arg > 22]) ifTrue: [^self primitiveFail]. arg = 1 ifTrue: [result _ youngStart - mem]. arg = 2 ifTrue: [result _ freeBlock - mem]. arg = 3 ifTrue: [result _ endOfMemory - mem]. arg = 4 ifTrue: [result _ allocationCount]. arg = 5 ifTrue: [result _ allocationsBetweenGCs]. arg = 6 ifTrue: [result _ tenuringThreshold]. arg = 7 ifTrue: [result _ statFullGCs]. arg = 8 ifTrue: [result _ statFullGCMSecs]. arg = 9 ifTrue: [result _ statIncrGCs]. arg = 10 ifTrue: [result _ statIncrGCMSecs]. arg = 11 ifTrue: [result _ statTenures]. ((arg >= 12) and: [arg <= 20]) ifTrue: [result _ 0]. arg = 21 ifTrue: [result _ rootTableCount]. arg = 22 ifTrue: [result _ statRootTableOverflows]. self pop: 2 thenPush: (self integerObjectOf: result). ^nil]. "write a VM parameter" argumentCount = 2 ifFalse: [^self primitiveFail]. index _ self stackValue: 1. (self isIntegerObject: index) ifFalse: [^self primitiveFail]. index _ self integerValueOf: index. index <= 0 ifTrue: [^self primitiveFail]. successFlag _ false. index = 5 ifTrue: [ result _ allocationsBetweenGCs. allocationsBetweenGCs _ arg. successFlag _ true]. index = 6 ifTrue: [ result _ tenuringThreshold. tenuringThreshold _ arg. successFlag _ true]. successFlag ifTrue: [ self pop: 3 thenPush: (self integerObjectOf: result). "return old value" ^ nil]. self primitiveFail. "attempting to write a read-only parameter" ! ! !Interpreter methodsFor: 'debug support'! allAccessibleObjectsOkay "Ensure that all accessible objects in the heap are okay." | oop | oop _ self firstAccessibleObject. [oop = nil] whileFalse: [ self okayFields: oop. oop _ self accessibleObjectAfter: oop. ].! ! !Interpreter methodsFor: 'debug support'! findClassOfMethod: meth forReceiver: rcvr | currClass classDict classDictSize methodArray i done | currClass _ self fetchClassOf: rcvr. done _ false. [done] whileFalse: [ classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass. classDictSize _ self fetchWordLengthOf: classDict. methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict. i _ 0. [i < (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^currClass ]. i _ i + 1. ]. currClass _ self fetchPointer: SuperclassIndex ofObject: currClass. done _ currClass = nilObj. ]. ^self fetchClassOf: rcvr "method not found in superclass chain"! ! !Interpreter methodsFor: 'debug support'! findSelectorOfMethod: meth forReceiver: rcvr | currClass done classDict classDictSize methodArray i | currClass _ self fetchClassOf: rcvr. done _ false. [done] whileFalse: [ classDict _ self fetchPointer: MessageDictionaryIndex ofObject: currClass. classDictSize _ self fetchWordLengthOf: classDict. methodArray _ self fetchPointer: MethodArrayIndex ofObject: classDict. i _ 0. [i <= (classDictSize - SelectorStart)] whileTrue: [ meth = (self fetchPointer: i ofObject: methodArray) ifTrue: [ ^(self fetchPointer: i + SelectorStart ofObject: classDict) ]. i _ i + 1. ]. currClass _ self fetchPointer: SuperclassIndex ofObject: currClass. done _ currClass = nilObj. ]. ^self splObj: SelectorDoesNotUnderstand "method not found in superclass chain"! ! !Interpreter methodsFor: 'debug support'! okayActiveProcessStack | cntxt | cntxt _ activeContext. [cntxt = nilObj] whileFalse: [ self okayFields: cntxt. cntxt _ (self fetchPointer: SenderIndex ofObject: cntxt). ].! ! !Interpreter methodsFor: 'debug support'! okayFields: oop "If this is a pointers object, check that its fields are all okay oops." | i fieldOop | (oop = nil or: [oop = 0]) ifTrue: [ ^true ]. (self isIntegerObject: oop) ifTrue: [ ^true ]. self okayOop: oop. self oopHasOkayClass: oop. (self isPointers: oop) ifFalse: [ ^true ]. i _ (self lengthOf: oop) - 1. [i >= 0] whileTrue: [ fieldOop _ self fetchPointer: i ofObject: oop. (self isIntegerObject: fieldOop) ifFalse: [ self okayOop: fieldOop. self oopHasOkayClass: fieldOop. ]. i _ i - 1. ].! ! !Interpreter methodsFor: 'debug support' stamp: 'ikp 1/14/1999 14:14'! okayInterpreterObjects | oopOrZero oop | self okayFields: nilObj. self okayFields: falseObj. self okayFields: trueObj. self okayFields: specialObjectsOop. self okayFields: activeContext. self okayFields: method. self okayFields: receiver. self okayFields: theHomeContext. self okayFields: messageSelector. self okayFields: newMethod. 0 to: MethodCacheEntries - 1 by: MethodCacheEntrySize do: [ :i | oopOrZero _ methodCache at: i + MethodCacheSelector. oopOrZero = 0 ifFalse: [ self okayFields: (methodCache at: i + MethodCacheSelector). self okayFields: (methodCache at: i + MethodCacheClass). self okayFields: (methodCache at: i + MethodCacheMethod). ]. ]. 1 to: remapBufferCount do: [ :i | oop _ remapBuffer at: i. (self isIntegerObject: oop) ifFalse: [ self okayFields: oop. ]. ]. self okayActiveProcessStack.! ! !Interpreter methodsFor: 'debug support' stamp: 'ar 3/21/98 02:37'! okayOop: oop "Verify that the given oop is legitimate. Check address, header, and size but not class." | sz type fmt | "address and size checks" (self isIntegerObject: oop) ifTrue: [ ^true ]. ((0 < oop) & (oop < endOfMemory)) ifFalse: [ self error: 'oop is not a valid address' ]. ((oop \\ 4) = 0) ifFalse: [ self error: 'oop is not a word-aligned address' ]. sz _ self sizeBitsOf: oop. (oop + sz) < endOfMemory ifFalse: [ self error: 'oop size would make it extend beyond the end of memory' ]. "header type checks" type _ self headerType: oop. type = HeaderTypeFree ifTrue: [ self error: 'oop is a free chunk, not an object' ]. type = HeaderTypeShort ifTrue: [ (((self baseHeader: oop) >> 12) bitAnd: 16r1F) = 0 ifTrue: [ self error: 'cannot have zero compact class field in a short header' ]. ]. type = HeaderTypeClass ifTrue: [ ((oop >= 4) and: [(self headerType: oop - 4) = type]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. type = HeaderTypeSizeAndClass ifTrue: [ ((oop >= 8) and: [(self headerType: oop - 8) = type and: [(self headerType: oop - 4) = type]]) ifFalse: [ self error: 'class header word has wrong type' ]. ]. "format check" fmt _ self formatOf: oop. ((fmt = 5) | (fmt = 7)) ifTrue: [ self error: 'oop has an unknown format type' ]. "mark and root bit checks" ((self longAt: oop) bitAnd: 16r20000000) = 0 ifFalse: [ self error: 'unused header bit 30 is set; should be zero' ]. "xxx ((self longAt: oop) bitAnd: MarkBit) = 0 ifFalse: [ self error: 'mark bit should not be set except during GC' ]. xxx" (((self longAt: oop) bitAnd: RootBit) = 1 and: [oop >= youngStart]) ifTrue: [ self error: 'root bit is set in a young object' ]. ^true! ! !Interpreter methodsFor: 'debug support'! oopHasOkayClass: oop "Attempt to verify that the given oop has a reasonable behavior. The class must be a valid, non-integer oop and must not be nilObj. It must be a pointers object with three or more fields. Finally, the instance specification field of the behavior must match that of the instance." | oopClass formatMask behaviorFormatBits oopFormatBits | self okayOop: oop. oopClass _ self fetchClassOf: oop. (self isIntegerObject: oopClass) ifTrue: [ self error: 'a SmallInteger is not a valid class or behavior' ]. self okayOop: oopClass. ((self isPointers: oopClass) and: [(self lengthOf: oopClass) >= 3]) ifFalse: [ self error: 'a class (behavior) must be a pointers object of size >= 3' ]. (self isBytes: oop) ifTrue: [ formatMask _ 16rC00 ] "ignore extra bytes size bits" ifFalse: [ formatMask _ 16rF00 ]. behaviorFormatBits _ (self formatOfClass: oopClass) bitAnd: formatMask. oopFormatBits _ (self baseHeader: oop) bitAnd: formatMask. behaviorFormatBits = oopFormatBits ifFalse: [ self error: 'object and its class (behavior) formats differ' ]. ^true! ! !Interpreter methodsFor: 'debug support' stamp: 'jm 12/30/2003 09:26'! print: s "For testing in Smalltalk, this method should be overridden in a subclass." | i ch | self var: #s declareC: 'char *s'. self inline: false. i _ 0. [(ch _ s at: i) = 0] whileFalse: [ self ioPutChar: ch. i _ i + 1]. ! ! !Interpreter methodsFor: 'debug support' stamp: 'jm 11/30/2003 14:33'! printCallStack self printCallStackFrom: activeContext. ! ! !Interpreter methodsFor: 'debug support' stamp: 'jm 12/30/2003 09:23'! printCallStackFrom: aContext | ctxt home methodClass methodSel | ctxt _ aContext. [ctxt = nilObj] whileFalse: [ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext) ifTrue: [ home _ self fetchPointer: HomeIndex ofObject: ctxt ] ifFalse: [ home _ ctxt ]. methodClass _ self findClassOfMethod: (self fetchPointer: MethodIndex ofObject: home) forReceiver: (self fetchPointer: ReceiverIndex ofObject: home). methodSel _ self findSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home) forReceiver: (self fetchPointer: ReceiverIndex ofObject: home). ctxt = home ifFalse: [ self print: '[] in ' ]. self printNameOfClass: methodClass count: 5. self print: '>'. self printStringOf: methodSel. self ioPutChar: 13. ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)].! ! !Interpreter methodsFor: 'debug support'! printNameOfClass: classOop count: cnt "Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object." cnt <= 0 ifTrue: [ ^ self print: 'bad class' ]. (self sizeBitsOf: classOop) = 16r20 ifTrue: [ self printNameOfClass: (self fetchPointer: 6 "thisClass" ofObject: classOop) count: cnt - 1. self print: ' class'. ] ifFalse: [ self printStringOf: (self fetchPointer: 6 "name" ofObject: classOop). ].! ! !Interpreter methodsFor: 'debug support' stamp: 'jm 12/30/2003 20:08'! printStringOf: oop | fmt cnt i | fmt _ self formatOf: oop. fmt < 8 ifTrue: [^ nil]. cnt _ 100 min: (self lengthOf: oop). i _ 0. [i < cnt] whileTrue: [ self ioPutChar: (self fetchByte: i ofObject: oop). i _ i + 1]. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 9/23/97 15:22'! byteSwapByteObjects "Byte-swap the words of all bytes objects in the image, including Strings, ByteArrays, and CompiledMethods. This returns these objects to their original byte ordering after blindly byte-swapping the entire image. For compiled methods, byte-swap only their bytecodes part." | oop fmt wordAddr methodHeader | oop _ self firstObject. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifFalse: [ fmt _ self formatOf: oop. fmt >= 8 ifTrue: [ "oop contains bytes" wordAddr _ oop + BaseHeaderSize. fmt >= 12 ifTrue: [ "compiled method; start after methodHeader and literals" methodHeader _ self longAt: oop + BaseHeaderSize. wordAddr _ wordAddr + 4 + (((methodHeader >> 10) bitAnd: 16rFF) * 4). ]. self reverseBytesFrom: wordAddr to: oop + (self sizeBitsOf: oop). ]. ]. oop _ self objectAfter: oop. ]. ! ! !Interpreter methodsFor: 'image save/restore'! byteSwapped: w "Return the given integer with its bytes in the reverse order." ^ ((w bitShift: -24) bitAnd: 16rFF) + ((w bitShift: -8) bitAnd: 16rFF00) + ((w bitShift: 8) bitAnd: 16rFF0000) + ((w bitShift: 24) bitAnd: 16rFF000000) ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'jm 1/3/2004 13:29'! checkImageVersionFrom: f "Read and verify the image file version number and return true if the the given image file needs to be byte-swapped. As a side effect, position the file stream just after the version number of the image header. This code prints a warning and does a hard-exit if it cannot find a valid version number." "This code is based on C code by Ian Piumarta." | version | "check the version number" self inline: false. self sqImageFile: f Seek: 0. version _ self getLongFromFile: f swap: false. (self readableFormat: version) ifTrue: [^ false]. "try with bytes reversed" self sqImageFile: f Seek: 0. version _ self getLongFromFile: f swap: true. (self readableFormat: version) ifTrue: [^ true]. "try skipping the first 512 bytes (prepended by certain Mac file transfer utilities)" self sqImageFile: f Seek: 512. version _ self getLongFromFile: f swap: false. (self readableFormat: version) ifTrue: [^ false]. "try skipping the first 512 bytes with bytes reversed" self sqImageFile: f Seek: 512. version _ self getLongFromFile: f swap: true. (self readableFormat: version) ifTrue: [^ true]. "hard failure; abort" self print: 'Incompatible image version.'. self ioPutChar: 13. self ioExit. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 12/27/1998 23:16'! cleanUpContexts "Sweep memory, nilling out all fields of contexts above the stack pointer." | oop header fmt sz | oop _ self firstObject. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifFalse: [ header _ self longAt: oop. fmt _ (header >> 8) bitAnd: 16rF. (fmt = 3 and: [self isContextHeader: header]) ifTrue: [sz _ self sizeBitsOf: oop. (self lastPointerOf: oop) + 4 to: sz - BaseHeaderSize by: 4 do: [:i | self longAt: oop+i put: nilObj]]]. oop _ self objectAfter: oop. ]. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'jm 1/3/2004 11:35'! getLongFromFile: f swap: swapFlag "Return the next 4-byte word of the given file, byte-swapped according to the given flag." | w | self cCode: 'sqImageFileRead(&w, sizeof(char), 4, f)'. swapFlag ifTrue: [^ self byteSwapped: w] ifFalse: [^ w]. ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 12/18/1998 12:24'! imageFormatVersion "Return a magic constant that changes when the image format changes. Since the image reading code uses this to detect byte ordering, one must avoid version numbers that are invariant under byte reversal." ^ 6502! ! !Interpreter methodsFor: 'image save/restore' stamp: 'jm 1/3/2004 11:33'! readImageFromFile: f HeapSize: desiredHeapSize "Read an image from the given file stream, allocating the given amount of memory to its object heap. Fail if the image has an unknown format or requires more than the given amount of memory." "Details: This method detects when the image was stored on a machine with the opposite byte ordering from this machine and swaps the bytes automatically. Furthermore, it allows the header information to start 512 bytes into the file, since some file transfer programs for the Macintosh apparently prepend a Mac-specific header of this size. Note that this same 512 bytes of prefix area could also be used to store an exec command on Unix systems, allowing one to launch Smalltalk by invoking the image name as a command." "This code is based on C code by Ian Piumarta and Smalltalk code by Tim Rowledge. Many thanks to both of you!!!!" | swapBytes headerStart headerSize dataSize oldBaseAddr minimumMemory memStart bytesRead bytesToShift | swapBytes _ self checkImageVersionFrom: f. headerStart _ (self sqImageFilePosition: f) - 4. "record header start position" headerSize _ self getLongFromFile: f swap: swapBytes. dataSize _ self getLongFromFile: f swap: swapBytes. oldBaseAddr _ self getLongFromFile: f swap: swapBytes. specialObjectsOop _ self getLongFromFile: f swap: swapBytes. lastHash _ self getLongFromFile: f swap: swapBytes. savedWindowSize _ self getLongFromFile: f swap: swapBytes. fullScreenFlag _ self getLongFromFile: f swap: swapBytes. lastHash = 0 ifTrue: [ "lastHash wasn't stored (e.g. by the cloner); use 999 as the seed" lastHash _ 999]. "compare memory requirements with availability". minimumMemory _ dataSize + 80000. "need at least 80K of breathing room" desiredHeapSize < minimumMemory ifTrue: [self error: 'Insufficient memory for this image']. "allocate a contiguous block of memory for the Squeak heap" memory _ self cCode: '(unsigned char *) sqAllocateMemory(minimumMemory, desiredHeapSize)'. memory = nil ifTrue: [self error: 'Failed to allocate memory for the heap']. memStart _ self startOfMemory. memoryLimit _ (memStart + desiredHeapSize) - 24. "decrease memoryLimit a tad for safety" endOfMemory _ memStart + dataSize. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "read in the image in bulk, then swap the bytes if necessary" bytesRead _ self cCode: 'sqImageFileRead(memory, sizeof(unsigned char), dataSize, f)'. bytesRead ~= dataSize ifTrue: [self error: 'Read failed or premature end of image file']. swapBytes ifTrue: [self reverseBytesInImage]. "compute difference between old and new memory base addresses" bytesToShift _ memStart - oldBaseAddr. self initializeInterpreter: bytesToShift. "adjusts all oops to new location" ^ dataSize ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 12/18/1998 12:25'! readableFormat: imageVersion "Anwer true if images of the given format are readable by this interpreter. Allows a virtual machine to accept selected older image formats." ^ (imageVersion = self imageFormatVersion) or: [imageVersion = 6504] ! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 9/23/97 15:20'! reverseBytesFrom: startAddr to: stopAddr "Byte-swap the given range of memory (not inclusive!!)." | addr | addr _ startAddr. [addr < stopAddr] whileTrue: [self longAt: addr put: (self byteSwapped: (self longAt: addr)). addr _ addr + 4].! ! !Interpreter methodsFor: 'image save/restore' stamp: 'di 10/2/97 00:31'! reverseBytesInImage "Byte-swap all words in memory after reading in the entire image file with bulk read. Contributed by Tim Rowledge." "First, byte-swap every word in the image. This fixes objects headers." self reverseBytesFrom: self startOfMemory to: endOfMemory. "Second, return the bytes of bytes-type objects to their orginal order." self byteSwapByteObjects.! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitiveLoadInstVar | thisReceiver | thisReceiver _ self popStack. self push: (self fetchPointer: primitiveIndex-264 ofObject: thisReceiver)! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushFalse self popStack. self push: falseObj! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushMinusOne self popStack. self push: ConstMinusOne! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushNil self popStack. self push: nilObj! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushOne self popStack. self push: ConstOne! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushSelf " no-op, really... thisReceiver _ self popStack. self push: thisReceiver "! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushTrue self popStack. self push: trueObj! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushTwo self popStack. self push: ConstTwo! ! !Interpreter methodsFor: 'quick primitives' stamp: 'jm 9/18/97 21:06'! primitivePushZero self popStack. self push: ConstZero! ! !Interpreter class methodsFor: 'initialization' stamp: 'jm 12/20/2003 19:08'! initialize "Interpreter initialize" super initialize. "initialize ObjectMemory constants" self initializeAssociationIndex. self initializeBytecodeTable. self initializeCaches. self initializeCharacterIndex. self initializeClassIndices. self initializeContextIndices. self initializeDirectoryLookupResultCodes. self initializeMessageIndices. self initializeMethodIndices. self initializePointIndices. self initializePrimitiveTable. self initializeSchedulerIndices. self initializeSmallIntegers. self initializeStreamIndices. SemaphoresToSignalSize _ 5. ! ! !Interpreter class methodsFor: 'initialization'! initializeAssociationIndex ValueIndex _ 1! ! !Interpreter class methodsFor: 'initialization'! initializeBytecodeTable "Interpreter initializeBytecodeTable" "Note: This table will be used to generate a C switch statement." BytecodeTable _ Array new: 256. self table: BytecodeTable from: #( ( 0 15 pushReceiverVariableBytecode) ( 16 31 pushTemporaryVariableBytecode) ( 32 63 pushLiteralConstantBytecode) ( 64 95 pushLiteralVariableBytecode) ( 96 103 storeAndPopReceiverVariableBytecode) (104 111 storeAndPopTemporaryVariableBytecode) (112 pushReceiverBytecode) (113 pushConstantTrueBytecode) (114 pushConstantFalseBytecode) (115 pushConstantNilBytecode) (116 pushConstantMinusOneBytecode) (117 pushConstantZeroBytecode) (118 pushConstantOneBytecode) (119 pushConstantTwoBytecode) (120 returnReceiver) (121 returnTrue) (122 returnFalse) (123 returnNil) (124 returnTopFromMethod) (125 returnTopFromBlock) (126 unknownBytecode) (127 unknownBytecode) (128 extendedPushBytecode) (129 extendedStoreBytecode) (130 extendedStoreAndPopBytecode) (131 singleExtendedSendBytecode) (132 doubleExtendedDoAnythingBytecode) (133 singleExtendedSuperBytecode) (134 secondExtendedSendBytecode) (135 popStackBytecode) (136 duplicateTopBytecode) (137 pushActiveContextBytecode) (138 143 experimentalBytecode) (144 151 shortUnconditionalJump) (152 159 shortConditionalJump) (160 167 longUnconditionalJump) (168 171 longJumpIfTrue) (172 175 longJumpIfFalse) "176-191 were sendArithmeticSelectorBytecode" (176 bytecodePrimAdd) (177 bytecodePrimSubtract) (178 bytecodePrimLessThan) (179 bytecodePrimGreaterThan) (180 bytecodePrimLessOrEqual) (181 bytecodePrimGreaterOrEqual) (182 bytecodePrimEqual) (183 bytecodePrimNotEqual) (184 bytecodePrimMultiply) (185 bytecodePrimDivide) (186 bytecodePrimMod) (187 bytecodePrimMakePoint) (188 bytecodePrimBitShift) (189 bytecodePrimDiv) (190 bytecodePrimBitAnd) (191 bytecodePrimBitOr) "192-207 were sendCommonSelectorBytecode" (192 bytecodePrimAt) (193 bytecodePrimAtPut) (194 bytecodePrimSize) (195 bytecodePrimNext) (196 bytecodePrimNextPut) (197 bytecodePrimAtEnd) (198 bytecodePrimEquivalent) (199 bytecodePrimClass) (200 bytecodePrimBlockCopy) (201 bytecodePrimValue) (202 bytecodePrimValueWithArg) (203 bytecodePrimDo) (204 bytecodePrimNew) (205 bytecodePrimNewWithArg) (206 bytecodePrimPointX) (207 bytecodePrimPointY) (208 255 sendLiteralSelectorBytecode) ).! ! !Interpreter class methodsFor: 'initialization' stamp: 'jm 12/20/2003 19:16'! initializeCaches "Decreased method cache size for MicroSqueak." | atCacheEntrySize | MethodCacheEntries _ 256. "was 512 for Squeak" MethodCacheSelector _ 1. MethodCacheClass _ 2. MethodCacheMethod _ 3. MethodCachePrim _ 4. MethodCacheEntrySize _ 4. "Must be power of two for masking scheme." MethodCacheMask _ (MethodCacheEntries - 1) * MethodCacheEntrySize. MethodCacheSize _ MethodCacheEntries * MethodCacheEntrySize. CacheProbeMax _ 3. AtCacheEntries _ 8. "Must be power of two" AtCacheOop _ 1. AtCacheSize _ 2. AtCacheFmt _ 3. AtCacheFixedFields _ 4. atCacheEntrySize _ 4. "Must be power of two for masking scheme." AtCacheMask _ (AtCacheEntries-1) * atCacheEntrySize. AtPutBase _ AtCacheEntries * atCacheEntrySize. AtCacheTotalSize _ AtCacheEntries * atCacheEntrySize * 2. ! ! !Interpreter class methodsFor: 'initialization'! initializeCharacterIndex CharacterValueIndex _ 0! ! !Interpreter class methodsFor: 'initialization'! initializeClassIndices "Class Class" SuperclassIndex _ 0. MessageDictionaryIndex _ 1. InstanceSpecificationIndex _ 2. "Fields of a message dictionary" MethodArrayIndex _ 1. SelectorStart _ 2! ! !Interpreter class methodsFor: 'initialization'! initializeContextIndices "Class MethodContext" SenderIndex _ 0. InstructionPointerIndex _ 1. StackPointerIndex _ 2. MethodIndex _ 3. ReceiverIndex _ 5. TempFrameStart _ 6. "Class BlockContext" CallerIndex _ 0. BlockArgumentCountIndex _ 3. InitialIPIndex _ 4. HomeIndex _ 5! ! !Interpreter class methodsFor: 'initialization'! initializeDirectoryLookupResultCodes DirEntryFound _ 0. DirNoMoreEntries _ 1. DirBadPath _ 2.! ! !Interpreter class methodsFor: 'initialization'! initializeMessageIndices MessageSelectorIndex _ 0. MessageArgumentsIndex _ 1. MessageSize _ 2! ! !Interpreter class methodsFor: 'initialization'! initializeMethodIndices "Class CompiledMethod" HeaderIndex _ 0. LiteralStart _ 1! ! !Interpreter class methodsFor: 'initialization'! initializePointIndices XIndex _ 0. YIndex _ 1! ! !Interpreter class methodsFor: 'initialization' stamp: 'jm 12/30/2003 22:00'! initializePrimitiveTable "This table generates a C switch statement for primitive dispatching." "NOTE: The real limit here is 2047, but our C compiler currently barfs over 700" MaxPrimitiveIndex _ 520. PrimitiveTable _ Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "32-bit logic is aliased to Integer prims above" (20 39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveNext) (66 primitiveNextPut) (67 primitiveAtEnd) "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveFail) "Blue Book: primitiveCursorLocPut" (92 primitiveFail) "Blue Book: primitiveCursorLink" (93 primitiveFail) (94 primitiveFail) "Blue Book: primitiveSampleInterval" (95 primitiveFail) (96 primitiveCopyBits) (97 primitiveFail) "was primitiveSnapshot" (98 primitiveFail) "Blue Book: primitiveTimeWordsInto" (99 primitiveFail) "Blue Book: primitiveTickWordsInto" (100 primitiveFail) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveFail) "was primitiveBeDisplay" (103 primitiveFail) "was primitiveScanCharacters" (104 primitiveDrawLoop) (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveFail) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveFail) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-149)" (120 primitiveFail) (121 primitiveFail) "was primitiveImageName" (122 primitiveFail) "Blue Book: primitiveImageVolume" (123 primitiveFail) (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveFail) "was primitiveClipboardText" (142 primitiveFail) "was primitiveVMPath" (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) (146 primitiveFail) (147 primitiveWarpBits) (148 primitiveClone) (149 primitiveFail) "was primitiveGetAttribute" "File Primitives (150-169)" (150 primitiveFileAtEnd) (151 primitiveFileClose) (152 primitiveFileGetPosition) (153 primitiveFileOpen) (154 primitiveFileRead) (155 primitiveFileSetPosition) (156 primitiveFileDelete) (157 primitiveFileSize) (158 primitiveFileWrite) (159 primitiveFileRename) (160 primitiveFail) "was primitiveDirectoryCreate" (161 primitiveFail) "was primitiveDirectoryDelimitor" (162 primitiveFail) "was primitiveDirectoryLookup" (163 168 primitiveFail) (169 primitiveFail) "was primitiveDirectorySetMacTypeAndCreator" "Sound Primitives (170-199)" (170 199 primitiveFail) "Networking Primitives (200-229)" (200 229 primitiveFail) "Other Primitives (230-249)" (230 primitiveFail) (231 primitiveFail) "was primitiveForceDisplayUpdate" (232 primitiveFail) (233 primitiveSetFullScreen) (234 primBitmapdecompressfromByteArrayat) (235 primStringcomparewithcollated) (236 primitiveFail) (237 primBitmapcompresstoByteArray) (238 242 primitiveFail) (243 primStringtranslatefromtotable) (244 primStringfindFirstInStringinSetstartingAt) (245 primStringindexOfAsciiinStringstartingAt) (246 primStringfindSubstringinstartingAtmatchTable) (247 primitiveFail) (248 primitiveFail) (249 primitivePutChar) (250 253 primitiveFail) (254 primitiveVMParameter) (255 primitiveFail) "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "Unassigned Primitives" (520 primitiveFail)). ! ! !Interpreter class methodsFor: 'initialization' stamp: 'jm 11/16/2003 19:41'! initializePrimitiveTable23 "Primitive table from Squeak 2.3 VM, for reference." MaxPrimitiveIndex _ 700. PrimitiveTable _ Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "32-bit logic is aliased to Integer prims above" (20 39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveNext) (66 primitiveNextPut) (67 primitiveAtEnd) "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveFail) "Blue Book: primitiveCursorLocPut" (92 primitiveFail) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveFail) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveCopyBits) (97 primitiveSnapshot) (98 primitiveFail) "Blue Book: primitiveTimeWordsInto" (99 primitiveFail) "Blue Book: primitiveTickWordsInto" (100 primitiveFail) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveDrawLoop) (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveFail) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveFail) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveFail) (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) (146 primitiveReadJoystick) (147 primitiveWarpBits) (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169)" (150 primitiveFileAtEnd) (151 primitiveFileClose) (152 primitiveFileGetPosition) (153 primitiveFileOpen) (154 primitiveFileRead) (155 primitiveFileSetPosition) (156 primitiveFileDelete) (157 primitiveFileSize) (158 primitiveFileWrite) (159 primitiveFileRename) (160 primitiveDirectoryCreate) (161 primitiveDirectoryDelimitor) (162 primitiveDirectoryLookup) (163 168 primitiveFail) (169 primitiveDirectorySetMacTypeAndCreator) "Sound Primitives (170-199)" (170 primitiveSoundStart) (171 primitiveSoundStartWithSemaphore) (172 primitiveSoundStop) (173 primitiveSoundAvailableSpace) (174 primitiveSoundPlaySamples) (175 primitiveSoundPlaySilence) "obsolete; will be removed in the future" (176 primWaveTableSoundmixSampleCountintostartingAtpan) (177 primFMSoundmixSampleCountintostartingAtpan) (178 primPluckedSoundmixSampleCountintostartingAtpan) (179 primSampledSoundmixSampleCountintostartingAtpan) (180 primFMSoundmixSampleCountintostartingAtleftVolrightVol) (181 primPluckedSoundmixSampleCountintostartingAtleftVolrightVol) (182 primSampledSoundmixSampleCountintostartingAtleftVolrightVol) (183 primReverbSoundapplyReverbTostartingAtcount) (184 primLoopedSampledSoundmixSampleCountintostartingAtleftVolrightVol) (185 188 primitiveFail) (189 primitiveSoundInsertSamples) (190 primitiveSoundStartRecording) (191 primitiveSoundStopRecording) (192 primitiveSoundGetRecordingSampleRate) (193 primitiveSoundRecordSamples) (194 primitiveSoundSetRecordLevel) (195 199 primitiveFail) "Networking Primitives (200-229)" (200 primitiveInitializeNetwork) (201 primitiveResolverStartNameLookup) (202 primitiveResolverNameLookupResult) (203 primitiveResolverStartAddressLookup) (204 primitiveResolverAddressLookupResult) (205 primitiveResolverAbortLookup) (206 primitiveResolverLocalAddress) (207 primitiveResolverStatus) (208 primitiveResolverError) (209 primitiveSocketCreate) (210 primitiveSocketDestroy) (211 primitiveSocketConnectionStatus) (212 primitiveSocketError) (213 primitiveSocketLocalAddress) (214 primitiveSocketLocalPort) (215 primitiveSocketRemoteAddress) (216 primitiveSocketRemotePort) (217 primitiveSocketConnectToPort) (218 primitiveSocketListenOnPort) (219 primitiveSocketCloseConnection) (220 primitiveSocketAbortConnection) (221 primitiveSocketReceiveDataBufCount) (222 primitiveSocketReceiveDataAvailable) (223 primitiveSocketSendDataBufCount) (224 primitiveSocketSendDone) (225 229 primitiveFail) "Other Primitives (230-249)" (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primBitmapdecompressfromByteArrayat) (235 primStringcomparewithcollated) (236 primSampledSoundconvert8bitSignedFromto16Bit) (237 primBitmapcompresstoByteArray) (238 primitiveSerialPortOpen) (239 primitiveSerialPortClose) (240 primitiveSerialPortWrite) (241 primitiveSerialPortRead) (242 primitiveFail) (243 primStringtranslatefromtotable) (244 primStringfindFirstInStringinSetstartingAt) (245 primStringindexOfAsciiinStringstartingAt) (246 primStringfindSubstringinstartingAtmatchTable) (247 249 primitiveFail) "VM Implementor Primitives (250-255)" (250 clearProfile) (251 dumpProfile) (252 startProfiling) (253 stopProfiling) (254 primitiveVMParameter) (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release." "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "MIDI Primitives (520-539)" (520 primitiveFail) (521 primitiveMIDIClosePort) (522 primitiveMIDIGetClock) (523 primitiveMIDIGetPortCount) (524 primitiveMIDIGetPortDirectionality) (525 primitiveMIDIGetPortName) (526 primitiveMIDIOpenPort) (527 primitiveMIDIParameterGetOrSet) (528 primitiveMIDIRead) (529 primitiveMIDIWrite) (530 539 primitiveFail) "reserved for extended MIDI primitives" "Experimental Asynchrous File Primitives" (540 primitiveAsyncFileClose) (541 primitiveAsyncFileOpen) (542 primitiveAsyncFileReadResult) (543 primitiveAsyncFileReadStart) (544 primitiveAsyncFileWriteResult) (545 primitiveAsyncFileWriteStart) "Unassigned Primitives" (546 700 primitiveFail)). ! ! !Interpreter class methodsFor: 'initialization' stamp: 'jm 11/16/2003 19:41'! initializePrimitiveTable28 "Primitive table from Squeak 2.8 VM, for reference." MaxPrimitiveIndex _ 700. PrimitiveTable _ Array new: MaxPrimitiveIndex + 1. self table: PrimitiveTable from: #( "Integer Primitives (0-19)" (0 primitiveFail) (1 primitiveAdd) (2 primitiveSubtract) (3 primitiveLessThan) (4 primitiveGreaterThan) (5 primitiveLessOrEqual) (6 primitiveGreaterOrEqual) (7 primitiveEqual) (8 primitiveNotEqual) (9 primitiveMultiply) (10 primitiveDivide) (11 primitiveMod) (12 primitiveDiv) (13 primitiveQuo) (14 primitiveBitAnd) (15 primitiveBitOr) (16 primitiveBitXor) (17 primitiveBitShift) (18 primitiveMakePoint) (19 primitiveFail) "Guard primitive for simulation -- *must* fail" "LargeInteger Primitives (20-39)" "32-bit logic is aliased to Integer prims above" (20 39 primitiveFail) "Float Primitives (40-59)" (40 primitiveAsFloat) (41 primitiveFloatAdd) (42 primitiveFloatSubtract) (43 primitiveFloatLessThan) (44 primitiveFloatGreaterThan) (45 primitiveFloatLessOrEqual) (46 primitiveFloatGreaterOrEqual) (47 primitiveFloatEqual) (48 primitiveFloatNotEqual) (49 primitiveFloatMultiply) (50 primitiveFloatDivide) (51 primitiveTruncated) (52 primitiveFractionalPart) (53 primitiveExponent) (54 primitiveTimesTwoPower) (55 primitiveSquareRoot) (56 primitiveSine) (57 primitiveArctan) (58 primitiveLogN) (59 primitiveExp) "Subscript and Stream Primitives (60-67)" (60 primitiveAt) (61 primitiveAtPut) (62 primitiveSize) (63 primitiveStringAt) (64 primitiveStringAtPut) (65 primitiveNext) (66 primitiveNextPut) (67 primitiveAtEnd) "StorageManagement Primitives (68-79)" (68 primitiveObjectAt) (69 primitiveObjectAtPut) (70 primitiveNew) (71 primitiveNewWithArg) (72 primitiveArrayBecomeOneWay) "Blue Book: primitiveBecome" (73 primitiveInstVarAt) (74 primitiveInstVarAtPut) (75 primitiveAsOop) (76 primitiveStoreStackp) "Blue Book: primitiveAsObject" (77 primitiveSomeInstance) (78 primitiveNextInstance) (79 primitiveNewMethod) "Control Primitives (80-89)" (80 primitiveBlockCopy) (81 primitiveValue) (82 primitiveValueWithArgs) (83 primitivePerform) (84 primitivePerformWithArgs) (85 primitiveSignal) (86 primitiveWait) (87 primitiveResume) (88 primitiveSuspend) (89 primitiveFlushCache) "Input/Output Primitives (90-109)" (90 primitiveMousePoint) (91 primitiveTestDisplayDepth) "Blue Book: primitiveCursorLocPut" (92 primitiveSetDisplayMode) "Blue Book: primitiveCursorLink" (93 primitiveInputSemaphore) (94 primitiveFail) "Blue Book: primitiveSampleInterval" (95 primitiveInputWord) (96 primitiveObsoleteIndexedPrimitive) "primitiveCopyBits" (97 primitiveSnapshot) (98 primitiveStoreImageSegment) (99 primitiveLoadImageSegment) (100 primitivePerformInSuperclass) "Blue Book: primitiveSignalAtTick" (101 primitiveBeCursor) (102 primitiveBeDisplay) (103 primitiveScanCharacters) (104 primitiveObsoleteIndexedPrimitive) "primitiveDrawLoop" (105 primitiveStringReplace) (106 primitiveScreenSize) (107 primitiveMouseButtons) (108 primitiveKbdNext) (109 primitiveKbdPeek) "System Primitives (110-119)" (110 primitiveEquivalent) (111 primitiveClass) (112 primitiveBytesLeft) (113 primitiveQuit) (114 primitiveExitToDebugger) (115 primitiveFail) "Blue Book: primitiveOopsLeft" (116 primitiveFlushCacheByMethod) (117 primitiveExternalCall) (118 primitiveDoPrimitiveWithArgs) (119 primitiveFlushCacheSelective) "Squeak 2.2 and earlier use 119. Squeak 2.3 and later use 116. Both are supported for backward compatibility." "Miscellaneous Primitives (120-127)" (120 primitiveCalloutToFFI) (121 primitiveImageName) (122 primitiveNoop) "Blue Book: primitiveImageVolume" (123 primitiveFail) (124 primitiveLowSpaceSemaphore) (125 primitiveSignalAtBytesLeft) "Squeak Primitives Start Here" "Squeak Miscellaneous Primitives (128-149)" (126 primitiveDeferDisplayUpdates) (127 primitiveShowDisplayRect) (128 primitiveArrayBecome) (129 primitiveSpecialObjectsOop) (130 primitiveFullGC) (131 primitiveIncrementalGC) (132 primitiveObjectPointsTo) (133 primitiveSetInterruptKey) (134 primitiveInterruptSemaphore) (135 primitiveMillisecondClock) (136 primitiveSignalAtMilliseconds) (137 primitiveSecondsClock) (138 primitiveSomeObject) (139 primitiveNextObject) (140 primitiveBeep) (141 primitiveClipboardText) (142 primitiveVMPath) (143 primitiveShortAt) (144 primitiveShortAtPut) (145 primitiveConstantFill) (146 primitiveObsoleteIndexedPrimitive) "primitiveReadJoystick" (147 primitiveObsoleteIndexedPrimitive) "primitiveWarpBits" (148 primitiveClone) (149 primitiveGetAttribute) "File Primitives (150-169)" (150 163 primitiveObsoleteIndexedPrimitive) (164 168 primitiveFail) (169 primitiveObsoleteIndexedPrimitive) "Sound Primitives (170-199)" (170 175 primitiveObsoleteIndexedPrimitive) (176 primWaveTableSoundmixSampleCountintostartingAtpan) (177 primFMSoundmixSampleCountintostartingAtpan) (178 primPluckedSoundmixSampleCountintostartingAtpan) (179 primSampledSoundmixSampleCountintostartingAtpan) (180 primFMSoundmixSampleCountintostartingAtleftVolrightVol) (181 primPluckedSoundmixSampleCountintostartingAtleftVolrightVol) (182 oldprimSampledSoundmixSampleCountintostartingAtleftVolrightVol) (183 primReverbSoundapplyReverbTostartingAtcount) (184 primLoopedSampledSoundmixSampleCountintostartingAtleftVolrightVol) (185 primSampledSoundmixSampleCountintostartingAtleftVolrightVol) (186 188 primitiveFail) (189 194 primitiveObsoleteIndexedPrimitive) (195 199 primitiveFail) "Networking Primitives (200-229)" (200 225 primitiveObsoleteIndexedPrimitive) (226 229 primitiveFail) "Other Primitives (230-249)" (230 primitiveRelinquishProcessor) (231 primitiveForceDisplayUpdate) (232 primitiveFormPrint) (233 primitiveSetFullScreen) (234 primBitmapdecompressfromByteArrayat) (235 primStringcomparewithcollated) (236 primSampledSoundconvert8bitSignedFromto16Bit) (237 primBitmapcompresstoByteArray) (238 241 primitiveObsoleteIndexedPrimitive) (242 primitiveFail) (243 primStringtranslatefromtotable) (244 primStringfindFirstInStringinSetstartingAt) (245 primStringindexOfAsciiinStringstartingAt) (246 primStringfindSubstringinstartingAtmatchTable) (247 249 primitiveFail) "VM Implementor Primitives (250-255)" (250 clearProfile) (251 dumpProfile) (252 startProfiling) (253 stopProfiling) (254 primitiveVMParameter) (255 primitiveInstVarsPutFromStack) "Never used except in Disney tests. Remove after 2.3 release." "Quick Push Const Methods" (256 primitivePushSelf) (257 primitivePushTrue) (258 primitivePushFalse) (259 primitivePushNil) (260 primitivePushMinusOne) (261 primitivePushZero) (262 primitivePushOne) (263 primitivePushTwo) "Quick Push Const Methods" (264 519 primitiveLoadInstVar) "MIDI Primitives (520-539)" (520 529 primitiveObsoleteIndexedPrimitive) (530 539 primitiveFail) "reserved for extended MIDI primitives" "Experimental Asynchrous File Primitives" (540 545 primitiveObsoleteIndexedPrimitive) (546 547 primitiveFail) "Pen Tablet Primitives" (548 primitiveObsoleteIndexedPrimitive) (549 primitiveObsoleteIndexedPrimitive) "Sound Codec Primitives" (550 primADPCMCodecprivateDecodeMono) (551 primADPCMCodecprivateDecodeStereo) (552 primADPCMCodecprivateEncodeMono) (553 primADPCMCodecprivateEncodeStereo) (554 569 primitiveFail) "reserved for additional codec primitives" "External primitive support primitives" (570 primitiveFlushExternalPrimitives) (571 primitiveUnloadModule) (572 primitiveListBuiltinModule) (573 primitiveListExternalModule) (574 primitiveFail) "reserved for addl. external support prims" "Unassigned Primitives" (575 700 primitiveFail)). ! ! !Interpreter class methodsFor: 'initialization'! initializeSchedulerIndices "Class ProcessorScheduler" ProcessListsIndex _ 0. ActiveProcessIndex _ 1. "Class LinkedList" FirstLinkIndex _ 0. LastLinkIndex _ 1. "Class Semaphore" ExcessSignalsIndex _ 2. "Class Link" NextLinkIndex _ 0. "Class Process" SuspendedContextIndex _ 1. PriorityIndex _ 2. MyListIndex _ 3! ! !Interpreter class methodsFor: 'initialization'! initializeSmallIntegers "SmallIntegers" ConstMinusOne _ Interpreter new integerObjectOf: -1. ConstZero _ Interpreter new integerObjectOf: 0. ConstOne _ Interpreter new integerObjectOf: 1. ConstTwo _ Interpreter new integerObjectOf: 2! ! !Interpreter class methodsFor: 'initialization'! initializeStreamIndices StreamArrayIndex _ 0. StreamIndexIndex _ 1. StreamReadLimitIndex _ 2. StreamWriteLimitIndex _ 3.! ! !Interpreter class methodsFor: 'initialization'! table: anArray from: specArray "SpecArray is an array of either (index selector) or (index1 index2 selector)." | contiguous | contiguous _ 0. specArray do: [ :spec | (spec at: 1) = contiguous ifFalse: [ self error: 'Non-contiguous table entry' ]. spec size = 2 ifTrue: [ anArray at: ((spec at: 1) + 1) put: (spec at: 2). contiguous _ contiguous + 1. ] ifFalse: [ (spec at: 1) to: (spec at: 2) do: [ :i | anArray at: (i + 1) put: (spec at: 3) ]. contiguous _ contiguous + ((spec at: 2) - (spec at: 1)) + 1. ]. ].! ! !Interpreter class methodsFor: 'constants'! primitiveTable ^ PrimitiveTable! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 1/3/2004 12:01'! declareCVarsIn: aCCodeGenerator aCCodeGenerator var: 'methodCache' declareC: 'int methodCache[', (MethodCacheSize + 1) printString, ']'. aCCodeGenerator var: 'atCache' declareC: 'int atCache[', (AtCacheTotalSize + 1) printString, ']'. aCCodeGenerator var: 'localIP' declareC: 'char * localIP'. aCCodeGenerator var: 'localSP' declareC: 'char * localSP'. aCCodeGenerator var: 'semaphoresToSignal' declareC: 'int semaphoresToSignal[', (SemaphoresToSignalSize + 1) printString, ']'. ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 1/3/2004 13:50'! displayPrims ^ #( primitiveCopyBits primitiveDrawLoop primitiveScanCharacters primitiveWarpBits primBitmapdecompressfromByteArrayat primBitmapcompresstoByteArray primitiveDeferDisplayUpdates primitiveScreenSize primitiveSetFullScreen primitiveShowDisplayRect primitiveBeCursor primitiveMouseButtons primitiveMousePoint showDisplayBits fullDisplayUpdate ) ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 1/3/2004 14:26'! filePrims ^ #( primitiveFileAtEnd primitiveFileClose primitiveFileGetPosition primitiveFileOpen primitiveFileRead primitiveFileSetPosition primitiveFileDelete primitiveFileSize primitiveFileWrite primitiveFileRename ) ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 1/3/2004 13:42'! floatPrims ^ #( primitiveArctan primitiveExp primitiveExponent primitiveFractionalPart primitiveLogN primitiveSine primitiveSquareRoot primitiveTimesTwoPower primitiveTruncated primitiveAsFloat primitiveFloatAdd primitiveFloatDivide primitiveFloatMultiply primitiveFloatSubtract primitiveFloatEqual primitiveFloatNotEqual primitiveFloatGreaterOrEqual primitiveFloatGreaterThan primitiveFloatLessOrEqual primitiveFloatLessThan) ! ! !Interpreter class methodsFor: 'translation'! patchInterp: fileName "Interpreter patchInterp: 'Squeak VM PPC'" "This will patch out the unneccesary range check (a compare and branch) in the inner interpreter dispatch loop." "NOTE: You must edit in the Interpeter file name, and the number of instructions (delta) to count back to find the compare and branch that we want to get rid of." | delta f code len remnant i | delta _ 6. f _ FileStream fileNamed: fileName. f binary. code _ Bitmap new: (len _ f size) // 4. f nextInto: code. remnant _ f next: len - (code size * 4). i _ 0. ["Look for a BCTR instruction" (i _ code indexOf: 16r4E800420 startingAt: i + 1 ifAbsent: [0]) > 0] whileTrue: [ "Look for a CMPLWI FF, 6 instrs back" ((code at: i - delta) bitAnd: 16rFFE0FFFF) = 16r280000FF ifTrue: [ "Copy dispatch instrs back over the compare" SelectionMenu notify: 'Patching at ', i hex. 0 to: delta - 2 do: [ :j | code at: (i - delta) + j put: (code at: (i - delta) + j + 2). ]. ]. ]. f position: 0; nextPutAll: code; nextPutAll: remnant. f close. ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 12/20/2003 19:06'! removePrimitives: primList codeGenerator: cg "Remove the given primitives from both my primitive table and the given code generator's method list." | i | primList do: [:pName | i _ PrimitiveTable indexOf: pName asSymbol ifAbsent: [nil]. i notNil ifTrue: [PrimitiveTable at: i put: #primitiveFail]. cg removeMethodNamed: pName]. ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 11/15/2003 05:38'! translate: fileName doInlining: inlineFlag "Time millisecondsToRun: [ Interpreter translate: 'interp.c' doInlining: true. Smalltalk beep]" | cg | BitBltSimulation initialize. Interpreter initialize. ObjectMemory initialize. cg _ CCodeGenerator new initialize. cg addClass: BitBltSimulation. cg addClass: Interpreter. cg addClass: ObjectMemory. BitBltSimulation declareCVarsIn: cg. Interpreter declareCVarsIn: cg. ObjectMemory declareCVarsIn: cg. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 1/3/2004 14:26'! translateNoBB: fileName doInlining: inlineFlag "Time millisecondsToRun: [ Interpreter translateNoBB: 'interpNoBB.c' doInlining: true. Smalltalk beep]" | cg | Interpreter initialize. ObjectMemory initialize. cg _ CCodeGenerator new initialize. cg addClass: BitBltStub. cg addClass: Interpreter. cg addClass: ObjectMemory. self removePrimitives: self floatPrims codeGenerator: cg. self removePrimitives: self displayPrims codeGenerator: cg. self removePrimitives: self filePrims codeGenerator: cg. #(signalSemaphoreWithIndex: checkedByteAt: primIndex checkedLongAt:put: aFinalizationComment byteLengthOf: fetchIntegerOrTruncFloat:ofObject: aComment allAccessibleObjectsOkay checkedLongAt: failed checkedByteAt:put: okayInterpreterObjects argCount nilObject) do: [:sel | cg removeMethodNamed: sel]. Interpreter declareCVarsIn: cg. ObjectMemory declareCVarsIn: cg. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! !Interpreter class methodsFor: 'translation' stamp: 'jm 9/17/2006 11:12'! translateObjMemOnly: fileName doInlining: inlineFlag "Time millisecondsToRun: [ Interpreter translateObjMemOnly: 'objMem.c' doInlining: true. Smalltalk beep]" | cg | Interpreter initialize. ObjectMemory initialize. cg _ CCodeGenerator new initialize. cg addClass: ObjectMemory. ObjectMemory declareCVarsIn: cg. #(signalSemaphoreWithIndex: checkedByteAt: primIndex checkedLongAt:put: aFinalizationComment byteLengthOf: fetchIntegerOrTruncFloat:ofObject: aComment allAccessibleObjectsOkay checkedLongAt: failed checkedByteAt:put: okayInterpreterObjects argCount nilObject) do: [:sel | cg removeMethodNamed: sel]. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! InterpreterSimulator comment: 'This class defines basic memory access and primitive simulation so that the Interpreter can run simulated in the Squeak environment. It also defines a number of handy object viewing methods to facilitate pawing around in the object memory. To see the thing actually run, you could (after backing up this image and changes), execute (InterpreterSimulator new openOn: Smalltalk imageName) test and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be. We usually do this with a small and simple benchmark image.'! !InterpreterSimulator methodsFor: 'initialization' stamp: 'di 11/23/1998 16:46'! close "close any files that ST may have opened" filesOpen do: [:f | f close]! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'di 12/12/1998 22:21'! initialize "Initialize the InterpreterSimulator when running the interpreter inside Smalltalk. The primary responsibility of this method is to allocate Smalltalk Arrays for variables that will be declared as statically-allocated global arrays in the translated code." "initialize class variables" ObjectMemory initialize. Interpreter initialize. methodCache _ Array new: MethodCacheSize. atCache _ Array new: AtCacheTotalSize. rootTable _ Array new: RootTableSize. remapBuffer _ Array new: RemapBufferSize. semaphoresToSignal _ Array new: SemaphoresToSignalSize. "initialize InterpreterSimulator variables used for debugging" byteCount _ 0. sendCount _ 0. traceOn _ true. myBitBlt _ BitBltSimulator new setInterpreter: self. displayForm _ nil. "displayForm is created in response to primitiveBeDisplay" filesOpen _ OrderedCollection new. ! ! !InterpreterSimulator methodsFor: 'initialization'! nextLongFrom: aStream "Read a 32-bit quantity from the given (binary) stream." | bytes | bytes _ aStream nextInto: (ByteArray new: 4). ^ Integer byte1: (bytes at: 4) byte2: (bytes at: 3) byte3: (bytes at: 2) byte4: (bytes at: 1)! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'di 9/23/97 15:51'! nextLongFrom: aStream swap: swapFlag swapFlag ifTrue: [^ self byteSwapped: (self nextLongFrom: aStream)] ifFalse: [^ self nextLongFrom: aStream]! ! !InterpreterSimulator methodsFor: 'initialization'! openOn: fileName "(InterpreterSimulator new openOn: 'clonex.image') test" self openOn: fileName extraMemory: 500000.! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'jm 12/6/1998 17:59'! openOn: fileName extraMemory: extraBytes "InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000" | f version headerSize count oldBaseAddr bytesToShift swapBytes | "open image file and read the header" f _ FileStream oldFileNamed: fileName. imageName _ f fullName. f binary; readOnly. version _ self nextLongFrom: f. "current version: 16r1966 (=6502)" (self readableFormat: version) ifTrue: [swapBytes _ false] ifFalse: [(version _ self byteSwapped: version) = self imageFormatVersion ifTrue: [swapBytes _ true] ifFalse: [self error: 'incomaptible image format']]. headerSize _ self nextLongFrom: f swap: swapBytes. endOfMemory _ self nextLongFrom: f swap: swapBytes. "first unused location in heap" oldBaseAddr _ self nextLongFrom: f swap: swapBytes. "object memory base address of image" specialObjectsOop _ self nextLongFrom: f swap: swapBytes. lastHash _ self nextLongFrom: f swap: swapBytes. "Should be loaded from, and saved to the image header" savedWindowSize _ self nextLongFrom: f swap: swapBytes. lastHash = 0 ifTrue: [lastHash _ 999]. "allocate interpreter memory" memoryLimit _ endOfMemory + extraBytes. "read in the image in bulk, then swap the bytes if necessary" f position: headerSize. memory _ Bitmap new: memoryLimit // 4. count _ f readInto: memory startingAt: 1 count: endOfMemory // 4. count ~= (endOfMemory // 4) ifTrue: [self halt]. f close. swapBytes ifTrue: [Utilities informUser: 'Swapping bytes of foreign image...' during: [self reverseBytesInImage]]. self initialize. bytesToShift _ 0 - oldBaseAddr. "adjust pointers for zero base address" endOfMemory _ endOfMemory. Utilities informUser: 'Relocating object pointers...' during: [self initializeInterpreter: bytesToShift]. ! ! !InterpreterSimulator methodsFor: 'initialization' stamp: 'di 10/2/97 00:32'! reverseBytesFrom: begin to: end "Byte-swap the given range of memory (not inclusive!!)." | wordAddr | wordAddr _ begin. memory swapBytesFrom: wordAddr // 4 + 1 to: end // 4! ! !InterpreterSimulator methodsFor: 'initialization'! startOfMemory "Return the start of object memory." ^ 0! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:06'! findNewMethodInClass: class " | cName | traceOn ifTrue: [cName _ (self sizeBitsOf: class) = 16r20 ifTrue: ['class ' , (self nameOfClass: (self fetchPointer: 6 ofObject: class))] ifFalse: [(self nameOfClass: class)]. self cr; print: cName , '>>' , (self stringOf: messageSelector)]. " (self stringOf: messageSelector) = 'doesNotUnderstand:' ifTrue: [self halt]. sendCount _ sendCount + 1. " (sendCount > 1000 and: [sendCount\\10 = 0]) ifTrue: [Transcript print: sendCount; space. self validate]. " " (sendCount > 100150) ifTrue: [self qvalidate. messageQueue == nil ifTrue: [messageQueue _ OrderedCollection new]. messageQueue addLast: (self stringOf: messageSelector)]. " super findNewMethodInClass: class.! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 11/30/2003 16:15'! jhmFindContexts "This depends on BlockContexts and MethodContexts being compact classes with indices of 13 and 14." | oop result hdr cc | result _ OrderedCollection new. oop _ self firstObject. [oop < endOfMemory] whileTrue: [ self validate: oop. hdr _ self longAt: oop. cc _ (hdr >> 12) bitAnd: 31. ((hdr bitAnd: 3) = 3 and: [(cc = 13) | (cc = 14)]) ifTrue: [result add: oop]. oop _ self objectAfter: oop]. ^ result asArray ! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 11/30/2003 16:16'! jhmFindOopsWithCC: ccIndex "Answer all the oops with the given compact class index." | oop result hdr cc | result _ OrderedCollection new. oop _ self firstObject. [oop < endOfMemory] whileTrue: [ self validate: oop. hdr _ self longAt: oop. cc _ (hdr >> 12) bitAnd: 31. ((hdr bitAnd: 3) = 3 and: [cc = ccIndex]) ifTrue: [result add: oop]. oop _ self objectAfter: oop]. ^ result asArray ! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 11/29/2003 10:37'! jhmValidate | oop prev allOops | allOops _ OrderedCollection new: 2000. oop _ self firstObject. [oop < endOfMemory] whileTrue: [ allOops addLast: oop. self validate: oop. prev _ oop. "look here if debugging prev obj overlapping this one" oop _ self objectAfter: oop. ]. "allOops collect: [:o | self dumpHeaderOf: o]" "dump headers" "allOops collect: [:o | (self longAt: o) bitAnd: 3]" "header type" "allOops collect: [:o | ((self longAt: o) >> 12) bitAnd: 31]" "cc field" "allOops collect: [:o | (self longAt: o) bitAnd: 252]" "size field" " 'scan for next header of type 1' | hdr | ((0 to: 1000 by: 4) select: [:a | hdr _ self longAt: prev + a. (((hdr >> 12) bitAnd: 31) = 1) and: [((hdr bitAnd: 3) ~= 0) or: [(hdr bitAnd: 255) = 0]]]) collect: [:a | a -> (self dumpHeaderOf: prev + a)]"! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 10/1/97 23:36'! objectBefore: addr | oop prev | oop _ self firstObject. [oop < endOfMemory] whileTrue: [ prev _ oop. "look here if debugging prev obj overlapping this one" oop _ self objectAfter: oop. oop >= addr ifTrue: [^ prev] ]! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:18'! profile: nBytecodes "(InterpreterSimulator new openOn: 'clonex.image') profile: 60000" Transcript clear. byteCount _ 0. MessageTally spyOn: [ self internalizeIPandSP. self fetchNextBytecode. [byteCount < nBytecodes] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ]. self close! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/28/1998 15:35'! profileSends: nBytecodes "(InterpreterSimulator new openOn: 'clonex.image') profileSends: 5000" byteCount _ 0. MessageTally tallySendsTo: self inBlock: [ self internalizeIPandSP. self fetchNextBytecode. [byteCount < nBytecodes] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1. byteCount \\ 100 = 0 ifTrue: [byteCount printString , ' ' displayAt: 0@0]]. self externalizeIPandSP. ] showTree: true. self close! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/22/1998 23:24'! stackDepth | ctxt n | ctxt _ activeContext. n _ 0. [(ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj] whileFalse: [n _ n+1]. ^ n! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 2/13/98 10:40'! stats | oop fieldAddr fieldOop last stats v d | stats _ Bag new. oop _ self firstObject. 'Scanning the image...' displayProgressAt: Sensor cursorPoint from: oop to: endOfMemory during: [:bar | [oop < endOfMemory] whileTrue: [(self isFreeObject: oop) ifFalse: [stats add: #objects. fieldAddr _ oop + (self lastPointerOf: oop). [fieldAddr > oop] whileTrue: [fieldOop _ self longAt: fieldAddr. (self isIntegerObject: fieldOop) ifTrue: [v _ self integerValueOf: fieldOop. (v between: -16000 and: 16000) ifTrue: [stats add: #ints32k] ifFalse: [stats add: #intsOther]] ifFalse: [fieldOop = nilObj ifTrue: [stats add: #nil] ifFalse: [d _ fieldOop - oop. (d between: -16000 and: 16000) ifTrue: [stats add: #oops32k] ifFalse: [stats add: #oopsOther]]]. fieldAddr _ fieldAddr - 4]]. bar value: oop. last _ oop. last _ last. oop _ self objectAfter: oop]]. ^ stats sortedElements! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 11/30/2003 16:30'! stringFromOop: oop "Get the string from the given oop." | fmt | self assert: [(self isIntegerObject: oop) not]. fmt _ self formatOf: oop. self assert: [(fmt >= 8) and: [fmt <= 11]]. ^ self stringOf: oop ! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 12/11/1998 17:17'! test Transcript clear. byteCount _ 0. self internalizeIPandSP. self fetchNextBytecode. [true] whileTrue: [self dispatchOn: currentBytecode in: BytecodeTable. byteCount _ byteCount + 1]. self externalizeIPandSP. ! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'di 1/9/1999 15:31'! testBecome "Become some young things. AA testBecome " | array list1 list2 p1 p2 p3 p4 | array _ self splObj: ClassArray. list1 _ self instantiateClass: array indexableSize: 2. list2 _ self instantiateClass: array indexableSize: 2. p1 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0. self push: p1. self storePointer: 0 ofObject: list1 withValue: p1. p2 _ self instantiateClass: (self splObj: ClassPoint) indexableSize: 0. self push: p2. self storePointer: 1 ofObject: list1 withValue: p2. p3 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0. self push: p3. self storePointer: 0 ofObject: list2 withValue: p3. p4 _ self instantiateClass: (self splObj: ClassMessage) indexableSize: 0. self push: p4. self storePointer: 1 ofObject: list2 withValue: p4. (self become: list1 with: list2 twoWay: true) ifFalse: [self error: 'failed']. self popStack = p2 ifFalse: [self halt]. self popStack = p1 ifFalse: [self halt]. self popStack = p4 ifFalse: [self halt]. self popStack = p3 ifFalse: [self halt]. (self fetchPointer: 0 ofObject: list1) = p3 ifFalse: [self halt]. (self fetchPointer: 1 ofObject: list1) = p4 ifFalse: [self halt]. (self fetchPointer: 0 ofObject: list2) = p1 ifFalse: [self halt]. (self fetchPointer: 1 ofObject: list2) = p2 ifFalse: [self halt].! ! !InterpreterSimulator methodsFor: 'testing'! validOop: oop "halt if invalid active object" (oop bitAnd: 1) = 1 ifTrue: [^ self]. (oop bitAnd: 3) = 0 ifFalse: [self halt]. oop >= endOfMemory ifTrue: [self halt]. "could test if within the first large freeblock" (self longAt: oop) = 4 ifTrue: [self halt]. (self headerType: oop) = 2 ifTrue: [self halt]. "free object"! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 9/24/97 22:52'! validate | oop prev | Transcript show: 'Validating...'. oop _ self firstObject. [oop < endOfMemory] whileTrue: [ self validate: oop. prev _ oop. "look here if debugging prev obj overlapping this one" oop _ self objectAfter: oop. ]. Transcript show: 'done.'; cr! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'jm 9/24/97 22:52'! validate: oop | header type cc sz fmt nextChunk | header _ self longAt: oop. type _ header bitAnd: 3. type = 2 ifFalse: [type = (self rightType: header) ifFalse: [self halt]]. sz _ (header >> 2) bitAnd: 16r3F. (self isFreeObject: oop) ifTrue: [ nextChunk _ oop + (self sizeOfFree: oop) ] ifFalse: [ nextChunk _ oop + (self sizeBitsOf: oop) ]. nextChunk > endOfMemory ifTrue: [oop = endOfMemory ifFalse: [self halt]]. (self headerType: nextChunk) = 0 ifTrue: [ (self headerType: (nextChunk + 8)) = 0 ifFalse: [self halt]]. (self headerType: nextChunk) = 1 ifTrue: [ (self headerType: (nextChunk + 4)) = 1 ifFalse: [self halt]]. type = 2 ifTrue: ["free block" ^ self]. fmt _ (header >> 8) bitAnd: 16rF. cc _ (header >> 12) bitAnd: 31. cc > 15 ifTrue: [self halt]. type = 0 ifTrue: ["three-word header" ((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt]. ((self longAt: oop-8) bitAnd: 3) = type ifFalse: [self halt]. ((self longAt: oop-4) = type) ifTrue: [self halt]. "Class word is 0" sz = 0 ifFalse: [self halt]]. type = 1 ifTrue: ["two-word header" ((self longAt: oop-4) bitAnd: 3) = type ifFalse: [self halt]. cc > 0 ifTrue: [sz = 1 ifFalse: [self halt]]. sz = 0 ifTrue: [self halt]]. type = 3 ifTrue: ["one-word header" cc = 0 ifTrue: [self halt]]. fmt = 4 ifTrue: [self halt]. fmt = 5 ifTrue: [self halt]. fmt = 7 ifTrue: [self halt]. fmt >= 12 ifTrue: ["CompiledMethod -- check for integer header" (self isIntegerObject: (self longAt: oop + 4)) ifFalse: [self halt]].! ! !InterpreterSimulator methodsFor: 'testing'! validateActiveContext self validateOopsIn: activeContext. "debug -- test if messed up"! ! !InterpreterSimulator methodsFor: 'testing' stamp: 'go 11/18/1998 10:51'! validateOopsIn: object | fieldPtr limit former header | "for each oop in me see if it is legal" fieldPtr _ object + BaseHeaderSize. "first field" limit _ object + (self lastPointerOf: object). "a good field" [fieldPtr > limit] whileFalse: [ former _ self longAt: fieldPtr. self validOop: former. fieldPtr _ fieldPtr + 4]. "class" header _ self baseHeader: object. (header bitAnd: CompactClassMask) = 0 ifTrue: [ former _ (self classHeader: object) bitAnd: AllButTypeMask. self validOop: former].! ! !InterpreterSimulator methodsFor: 'debug printing'! print: s traceOn ifTrue: [ Transcript show: s ]! ! !InterpreterSimulator methodsFor: 'debug printing'! printNum: anInteger traceOn ifTrue: [ Transcript show: anInteger printString ].! ! !InterpreterSimulator methodsFor: 'debug support'! charsOfLong: long ^ (4 to: 1 by: -1) collect: [:i | ((long digitAt: i) between: 14 and: 126) ifTrue: [(long digitAt: i) asCharacter] ifFalse: [$?]]! ! !InterpreterSimulator methodsFor: 'debug support'! classAndSelectorOfMethod: meth forReceiver: rcvr | mClass dict length methodArray | mClass _ self fetchClassOf: rcvr. [dict _ self fetchPointer: MessageDictionaryIndex ofObject: mClass. length _ self fetchWordLengthOf: dict. methodArray _ self fetchPointer: MethodArrayIndex ofObject: dict. 0 to: length-SelectorStart-1 do: [:index | meth = (self fetchPointer: index ofObject: methodArray) ifTrue: [^ Array with: mClass with: (self fetchPointer: index + SelectorStart ofObject: dict)]]. mClass _ self fetchPointer: SuperclassIndex ofObject: mClass. mClass = nilObj] whileFalse: []. ^ Array with: (self fetchClassOf: rcvr) with: (self splObj: SelectorDoesNotUnderstand)! ! !InterpreterSimulator methodsFor: 'debug support'! compactClassAt: ccIndex "Index must be between 1 and compactClassArray size. (A zero compact class index in the base header indicate that the class is in the class header word.)" | classArray | classArray _ self fetchPointer: CompactClasses ofObject: specialObjectsOop. ^ self fetchPointer: (ccIndex - 1) ofObject: classArray! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 12/17/2003 23:19'! contextStack "Answer all contexts in the sender chain of the active process." | result this | result _ OrderedCollection new. this _ activeContext. [this ~= nilObj] whileTrue: [ result addFirst: this. this _ self fetchPointer: SenderIndex ofObject: this]. ^ result asArray ! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 11/23/1998 22:44'! dumpHeader: hdr | cc | ^ String streamContents: [:strm | cc _ (hdr bitAnd: CompactClassMask) >> 12. strm nextPutAll: '<cc=', cc hex. cc > 0 ifTrue: [strm nextPutAll: ':' , (self nameOfClass: (self compactClassAt: cc))]. strm nextPutAll: '>'. strm nextPutAll: '<ft=', ((hdr bitShift: -8) bitAnd: 16rF) hex , '>'. strm nextPutAll: '<sz=', (hdr bitAnd: SizeMask) hex , '>'. strm nextPutAll: '<hdr=', (#(big class gcMark short) at: (hdr bitAnd: 3) +1) , '>'] ! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 11/29/2003 10:12'! dumpHeaderOf: oop | hdr cc | hdr _ self longAt: oop. ^ String streamContents: [:strm | cc _ (hdr bitAnd: CompactClassMask) >> 12. strm nextPutAll: '<cc ', cc printString. "xxx cc > 0 ifTrue: [strm nextPutAll: ':', (self nameOfClass: (self compactClassAt: cc))]. xxx" strm nextPutAll: ' fmt ', ((hdr bitShift: -8) bitAnd: 16rF) printString. strm nextPutAll: ' sz ', (hdr bitAnd: SizeMask) printString. strm nextPutAll: ' [', (#(big class gcMark short) at: (hdr bitAnd: 3) + 1), ']>'] ! ! !InterpreterSimulator methodsFor: 'debug support'! dumpMethodHeader: hdr ^ String streamContents: [:strm | strm nextPutAll: '<nArgs=', ((hdr >> 25) bitAnd: 16r1F) printString , '>'. strm nextPutAll: '<nTemps=', ((hdr >> 19) bitAnd: 16r3F) printString , '>'. strm nextPutAll: '<lgCtxt=', ((hdr >> 18) bitAnd: 16r1) printString , '>'. strm nextPutAll: '<nLits=', ((hdr >> 10) bitAnd: 16rFF) printString , '>'. strm nextPutAll: '<prim=', ((hdr >> 1) bitAnd: 16r1FF) printString , '>'. ]! ! !InterpreterSimulator methodsFor: 'debug support'! headerStart: oop ^ (self extraHeaderBytes: oop) negated! ! !InterpreterSimulator methodsFor: 'debug support'! hexDump100: oop | byteSize val | ^ String streamContents: [:strm | byteSize _ 256. (self headerStart: oop) to: byteSize by: 4 do: [:a | val _ self longAt: oop+a. strm cr; nextPutAll: (oop+a) hex8; space; space; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. strm nextPutAll: (self charsOfLong: val). strm space; space; nextPutAll: (oop+a) printString]]! ! !InterpreterSimulator methodsFor: 'debug support'! hexDump: oop | byteSize val | (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop]. ^ String streamContents: [:strm | byteSize _ 256 min: (self sizeBitsOf: oop)-4. (self headerStart: oop) to: byteSize by: 4 do: [:a | val _ self longAt: oop+a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space; nextPutAll: val hex8; space; space. a=0 ifTrue: [strm nextPutAll: (self dumpHeader: val)] ifFalse: [strm nextPutAll: (self charsOfLong: val)]]]! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 11/30/2003 13:49'! longPrint: oop | lastPtr val lastLong hdrType prevVal | (self isIntegerObject: oop) ifTrue: [^ self shortPrint: oop]. ^ String streamContents: [:strm | lastPtr _ (self lastPointerOf: oop) min: 30. hdrType _ self headerType: oop. hdrType = 2 ifTrue: [lastPtr _ 0]. prevVal _ 0. (self headerStart: oop) to: lastPtr by: 4 do: [:a | val _ self longAt: oop + a. "(a > 0 and: [(val = prevVal) & (a ~= lastPtr)])" false ifTrue: [ prevVal = (self longAt: (oop + a) - 8) ifFalse: [strm cr; nextPutAll: ' ...etc...']] ifFalse: [ strm cr; nextPutAll: a printString; space; space; tab; nextPutAll: val hex8; space; space. a=-8 ifTrue: [strm nextPutAll: 'size = ' , (val - hdrType) hex]. a=-4 ifTrue: [strm nextPutAll: '<' , (self nameOfClass: (val - hdrType)) , '>']. a=0 ifTrue: [strm cr; tab; nextPutAll: (self dumpHeader: val)]. a>0 ifTrue: [strm nextPutAll: (self shortPrint: val)]. a=4 ifTrue: [(self fetchClassOf: oop) = (self splObj: ClassCompiledMethod) ifTrue: [strm cr; tab; nextPutAll: (self dumpMethodHeader: val)]]]. prevVal _ val]. lastLong _ 256 min: (self sizeBitsOf: oop) - 4. hdrType = 2 ifTrue: [ "free" strm cr; nextPutAll: (oop + (self longAt: oop) - 2) hex; space; space; nextPutAll: (oop + (self longAt: oop) - 2) printString. ^ self]. (self formatOf: oop) = 3 ifTrue: [ strm cr; tab; nextPutAll: '/ next 3 fields are above SP... /'. lastPtr+4 to: lastPtr + 12 by: 4 do: [:a | val _ self longAt: oop + a. strm cr; nextPutAll: a printString; space; space; tab; nextPutAll: val hex8; space; space. strm nextPutAll: (self shortPrint: val)]] ifFalse: [ lastPtr+4 to: lastLong by: 4 do: [:a | val _ self longAt: oop + a. strm cr; nextPutAll: (a<16 ifTrue: [' ', a hex] ifFalse: [a hex]); space; space; space. strm nextPutAll: val hex8; space; space; nextPutAll: (self charsOfLong: val)]]]. ! ! !InterpreterSimulator methodsFor: 'debug support'! nameOfClass: classOop (self sizeBitsOf: classOop) = 16r20 ifTrue: [^ (self nameOfClass: (self fetchPointer: 6 "thisClass" ofObject: classOop)) , ' class']. ^ self stringOf: (self fetchPointer: 6 "name" ofObject: classOop)! ! !InterpreterSimulator methodsFor: 'debug support'! printStack | ctxt classAndSel home | ctxt _ activeContext. ^ String streamContents: [:strm | [home _ (self fetchClassOf: ctxt) = (self splObj: ClassBlockContext) ifTrue: [self fetchPointer: HomeIndex ofObject: ctxt] ifFalse: [ctxt]. classAndSel _ self classAndSelectorOfMethod: (self fetchPointer: MethodIndex ofObject: home) forReceiver: (self fetchPointer: ReceiverIndex ofObject: home). strm cr; nextPutAll: ctxt hex8. ctxt = home ifFalse: [strm nextPutAll: ' [] in']. strm space; nextPutAll: (self nameOfClass: classAndSel first). strm nextPutAll: '>>'; nextPutAll: (self shortPrint: classAndSel last). (ctxt _ (self fetchPointer: SenderIndex ofObject: ctxt)) = nilObj] whileFalse: []. ]! ! !InterpreterSimulator methodsFor: 'debug support' stamp: 'jm 12/17/2003 23:20'! printStack: n | contexts | contexts _ self contextStack. self printCallStackFrom: (contexts at: (n min: contexts size)). ! ! !InterpreterSimulator methodsFor: 'debug support'! shortPrint: oop | name classOop | (self isIntegerObject: oop) ifTrue: [^ '=' , (self integerValueOf: oop) printString , ' (' , (self integerValueOf: oop) hex , ')']. classOop _ self fetchClassOf: oop. (self sizeBitsOf: classOop) =16r20 ifTrue: [^ 'class ' , (self nameOfClass: oop)]. name _ self nameOfClass: classOop. name size = 0 ifTrue: [name _ '??']. name = 'String' ifTrue: [^ (self stringOf: oop) printString]. name = 'Symbol' ifTrue: [^ '#' , (self stringOf: oop)]. name = 'Character' ifTrue: [^ '=' , (Character value: (self integerValueOf: (self fetchPointer: 0 ofObject: oop))) printString]. name = 'UndefinedObject' ifTrue: [^ 'nil']. name = 'False' ifTrue: [^ 'false']. name = 'True' ifTrue: [^ 'true']. name = 'Float' ifTrue: [^ '=' , (self floatValueOf: oop) printString]. name = 'Association' ifTrue: [^ '(' , (self shortPrint: (self longAt: oop + BaseHeaderSize)) , ' -> ' , (self longAt: oop + BaseHeaderSize + 4) hex8 , ')']. ('AEIOU' includes: name first) ifTrue: [^ 'an ' , name] ifFalse: [^ 'a ' , name]! ! !InterpreterSimulator methodsFor: 'debug support'! stringOf: oop | size long nLongs chars | ^ String streamContents: [:strm | size _ 100 min: (self stSizeOf: oop). nLongs _ size-1//4+1. 1 to: nLongs do: [:i | long _ self longAt: oop + BaseHeaderSize + (i-1*4). chars _ self charsOfLong: long. strm nextPutAll: (i=nLongs ifTrue: [chars copyFrom: 1 to: size-1\\4+1] ifFalse: [chars])]]! ! !InterpreterSimulator methodsFor: 'interpreter shell'! dispatchOn: anInteger in: selectorArray "Simulate a case statement via selector table lookup. The given integer must be between 0 and selectorArray size-1, inclusive. For speed, no range test is done, since it is done by the at: operation." "assert: (anInteger >= 0) | (anInteger < selectorArray size)" " Transcript cr; show: anInteger hex , ' ' , (selectorArray at: (anInteger + 1)). Sensor waitButton. Sensor yellowButtonPressed ifTrue: [self halt]. " self perform: (selectorArray at: (anInteger + 1)).! ! !InterpreterSimulator methodsFor: 'interpreter shell'! fetchByte ^ self byteAt: (localIP _ localIP + 1).! ! !InterpreterSimulator methodsFor: 'interpreter shell'! fetchIntegerOrTruncFloat: fieldIndex ofObject: objectPointer "Overridden to support the simulator." | intOrFloat | intOrFloat _ self fetchPointer: fieldIndex ofObject: objectPointer. (self isIntegerObject: intOrFloat) ifTrue: [^ self integerValueOf: intOrFloat]. self assertClassOf: intOrFloat is: (self splObj: ClassFloat). successFlag ifTrue: [^ (self floatValueOf: intOrFloat) truncated]. ! ! !InterpreterSimulator methodsFor: 'interpreter shell'! isIntegerValue: valueWord ^ valueWord >= 16r-40000000 and: [valueWord <= 16r3FFFFFFF]! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'jm 11/29/2003 11:00'! ioBeep self beep. ! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 12/1/1998 00:09'! ioLowResMSecs ^ Time millisecondClockValue! ! !InterpreterSimulator methodsFor: 'I/O primitives'! ioProcessEvents! ! !InterpreterSimulator methodsFor: 'I/O primitives'! primitiveBeCursor "Take note of the current cursor" | cursorObj bitsObj offsetObj ourCursor | cursorObj _ self stackTop. self success: ((self isPointers: cursorObj) and: [(self lengthOf: cursorObj) >= 4]). successFlag ifTrue: [bitsObj _ self fetchPointer: 0 ofObject: cursorObj. offsetObj _ self fetchPointer: 4 ofObject: cursorObj. ourCursor _ Cursor extent: (self fetchInteger: 1 ofObject: cursorObj)@(self fetchInteger: 2 ofObject: cursorObj) fromArray: ((1 to: 16) collect: [:i | ((self fetchWord: i-1 ofObject: bitsObj) >> 16) bitAnd: 16rFFFF]) offset: (self fetchInteger: 0 ofObject: offsetObj)@(self fetchInteger: 1 ofObject: offsetObj)]. successFlag ifTrue: [ourCursor show] ifFalse: [self primitiveFail].! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'! primitiveKbdNext self pop: 1. Sensor keyboardPressed ifTrue: [self pushInteger: Sensor primKbdNext] ifFalse: [self push: nilObj]! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'! primitiveKbdPeek self pop: 1. Sensor keyboardPressed ifTrue: [self pushInteger: Sensor primKbdPeek] ifFalse: [self push: nilObj]! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 12:54'! primitiveMouseButtons | buttons | self pop: 1. buttons _ Sensor primMouseButtons. self pushInteger: buttons! ! !InterpreterSimulator methodsFor: 'I/O primitives'! primitiveMousePoint | relPt | self pop: 1. displayForm == nil ifTrue: [self push: (self makePointwithxValue: 99 yValue: 66)] ifFalse: [relPt _ Sensor cursorPoint - (Display extent - displayForm extent - (10@10)). self push: (self makePointwithxValue: relPt x yValue: relPt y)]! ! !InterpreterSimulator methodsFor: 'I/O primitives'! primitiveScreenSize "Dummied for now" self pop: 1. self push: (self makePointwithxValue: 640 yValue: 480).! ! !InterpreterSimulator methodsFor: 'I/O primitives' stamp: 'di 9/23/97 15:26'! showDisplayBits | displayObj destBits raster destDepth pixPerWord simDisp realDisp top bottom rect | displayObj _ self splObj: TheDisplay. self targetForm = displayObj ifFalse: [^ self]. destBits _ self fetchPointer: 0 ofObject: displayObj. destDepth _ self fetchInteger: 3 ofObject: displayObj. pixPerWord _ 32 // destDepth. raster _ displayForm width + (pixPerWord - 1) // pixPerWord. simDisp _ Form new hackBits: memory. realDisp _ Form new hackBits: displayForm bits. top _ myBitBlt affectedTop. bottom _ myBitBlt affectedBottom. realDisp copy: (0 @ (top * raster) extent: 4 @ (bottom - top * raster)) from: 0 @ (destBits + 4 // 4 + (top * raster)) in: simDisp rule: Form over. rect _ 0 @ top corner: displayForm width @ bottom. Display copy: (rect translateBy: self displayLocation) from: rect topLeft in: displayForm rule: Form over! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! copyBits ^ myBitBlt copyBits! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! displayLocation ^ Display extent - displayForm extent - (10@10)! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! drawLoopX: xDelta Y: yDelta ^ myBitBlt drawLoopX: xDelta Y: yDelta! ! !InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'di 12/29/97 20:09'! initBBOpTable ^ myBitBlt initBBOpTable! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! ioMSecs "Return the value of the millisecond clock." ^ Time millisecondClockValue! ! !InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'! ioMicroMSecs "Return the value of the microsecond clock (dummied here)." ^ 0! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! ioProcessEventsEveryMSecs: mSecs "Noop during simulation."! ! !InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 11/29/2003 22:06'! ioScreenSize "Return the screen extent packed into 32 bits." displayForm ifNil: [^ (32 << 16) + 32]. ^ (displayForm width << 16) + displayForm height ! ! !InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 9/24/97 22:52'! ioSeconds "Return the value of the second clock." ^ Time primSecondsClock! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! loadBitBltFrom: bbObj ^ myBitBlt loadBitBltFrom: bbObj! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! loadScannerFrom: bbObj start: start stop: stop string: string rightX: rightX stopArray: stopArray displayFlag: displayFlag ^ myBitBlt loadScannerFrom: bbObj start: start stop: stop string: string rightX: rightX stopArray: stopArray displayFlag: displayFlag! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! scanCharacters ^ myBitBlt scanCharacters! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! stopReason ^ myBitBlt stopReason! ! !InterpreterSimulator methodsFor: 'I/O primitives support'! targetForm ^ myBitBlt targetForm! ! !InterpreterSimulator methodsFor: 'I/O primitives support' stamp: 'jm 11/29/2003 22:08'! writeImageFile: imageBytes | f headerStart headerSize | "local constants" headerStart _ 0. "change to 512 to leave room for a Unix exec string" headerSize _ 64. "header size in bytes; do not change!!" f _ (FileStream newFileNamed: imageName) binary. f = nil ifTrue: [ "could not open the image file for writing" self success: false. ^ nil]. "position file to start of header" f position: headerStart. "write the image header" f int32: (self imageFormatVersion). f int32: headerSize. f int32: imageBytes. f int32: (self startOfMemory). f int32: specialObjectsOop. f int32: lastHash. f int32: (self ioScreenSize). f int32: ((fullScreenFlag = true) ifTrue: [1] ifFalse: [0]). 1 to: 8 do: [:i | f int32: 0]. "fill remaining header words with zeros" "position file after the header" f position: headerStart + headerSize. "write the image data" f nextPutAll: (memory copyFrom: 1 to: (imageBytes + 3) // 4). f close. "set Mac file type and creator; this is a noop on other platforms" FileDirectory default setMacFileNamed: f name type: 'STim' creator: 'FAST'. ! ! !InterpreterSimulator methodsFor: 'file primitives'! asciiDirectoryDelimiter ^ FileDirectory pathNameDelimiter asciiValue! ! !InterpreterSimulator methodsFor: 'file primitives'! fileValueOf: integerPointer "Convert the (integer) fileID to the actual fileStream it uses" self success: (self isIntegerObject: integerPointer). successFlag ifTrue: [^ filesOpen at: (self integerValueOf: integerPointer)] ifFalse: [^ nil]! ! !InterpreterSimulator methodsFor: 'file primitives' stamp: 'di 1/12/1999 15:38'! primitiveFileDelete | namePointer | namePointer _ self stackTop. self success: (self isBytes: namePointer). self success: (StandardFileStream isAFileNamed: (self stringOf: namePointer)). successFlag ifTrue: [FileDirectory deleteFilePath: (self stringOf: namePointer)]. successFlag ifTrue: [self pop: 1]. "pop fileName; leave rcvr on stack" ! ! !InterpreterSimulator methodsFor: 'file primitives' stamp: 'jm 12/5/97 15:09'! primitiveFileOpen | namePointer writeFlag fileName | writeFlag _ self booleanValueOf: self stackTop. namePointer _ self stackValue: 1. self success: (self isBytes: namePointer). successFlag ifTrue: [fileName _ self stringOf: namePointer. filesOpen addLast: (writeFlag ifTrue: [(FileStream fileNamed: fileName) binary] ifFalse: [(StandardFileStream isAFileNamed: fileName) ifTrue: [(FileStream oldFileNamed: fileName) readOnly; binary] ifFalse: [^ self primitiveFail]]). self pop: 3. "rcvr, name, write" self pushInteger: filesOpen size]! ! !InterpreterSimulator methodsFor: 'file primitives' stamp: 'jm 12/5/97 15:10'! primitiveFileRename | oldNamePointer newNamePointer f | oldNamePointer _ self stackTop. newNamePointer _ self stackValue: 1. self success: (self isBytes: oldNamePointer). self success: (self isBytes: newNamePointer). self success: (StandardFileStream isAFileNamed: (self stringOf: oldNamePointer)). self success: (StandardFileStream isAFileNamed: (self stringOf: newNamePointer)) not. successFlag ifTrue: [ f _ FileStream oldFileNamed: (self stringOf: oldNamePointer). f rename: (self stringOf: newNamePointer). f close. ]. successFlag ifTrue: [ self pop: 2. "oldName, newName; leave rcvr on stack" ].! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFile: file Read: count Into: byteArrayIndex At: startIndex startIndex to: (startIndex + count - 1) do: [ :i | file atEnd ifTrue: [ ^ i - startIndex ]. self byteAt: byteArrayIndex + i put: file next. ]. ^ count! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFile: file SetPosition: newPosition file position: newPosition.! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFile: file Write: count From: byteArrayIndex At: startIndex startIndex to: (startIndex + count - 1) do: [ :i | file nextPut: (self byteAt: byteArrayIndex + i). ]. ^ count! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFileAtEnd: file ^ file atEnd! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFileClose: file file close.! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFileGetPosition: file ^ file position! ! !InterpreterSimulator methodsFor: 'file primitives'! sqFileSize: file ^ file size! ! !InterpreterSimulator methodsFor: 'file primitives'! vmPathGet: stringBase Length: stringSize | pathName stringOop | pathName _ Smalltalk vmPath. stringOop _ stringBase - BaseHeaderSize. "Due to C call in Interp" 1 to: stringSize do: [:i | self storeByte: i-1 ofObject: stringOop withValue: (pathName at: i) asciiValue]. ! ! !InterpreterSimulator methodsFor: 'file primitives'! vmPathSize ^ Smalltalk vmPath size! ! !InterpreterSimulator methodsFor: 'float primitives'! floatObjectOf: float | result sign exponent mantissa mantSize long0 long1 | true ifTrue: [ "No conversion needed in Apple ST" long0 _ float at: 1. long1 _ float at: 2. ] ifFalse: ["Following code useful when porting to different formats" ((float at: 1) = 0 and: [(float at: 2) = 0]) ifTrue: [long0 _ 0. long1 _ 0] ifFalse: ["Read from the PPS 32-bit format" sign _ ((float at: 1) bitAnd: 16r8000) bitShift: -15. "1-bit sign" exponent _ (((float at: 1) bitShift: -7) bitAnd: 16rFF) - 16r80. "8-bit expt" mantissa _ (((float at: 1) bitAnd: 16r7F) bitShift: 16) + (float at: 2). "23 bit mantissa" mantSize _ 23. "Convert to first 32 bits of 64-bit IEEE format" long0 _ (sign bitShift: 31) "1-bit sign" + (exponent + 16r400 bitShift: 20) "11-bit expt" + ((mantissa bitShift: 20 - mantSize) bitAnd: 16rFFFFF). "20 bit mantissa" ]. ]. "end of porting code" result _ self instantiateClass: (self splObj: ClassFloat) indexableSize: 2. self storeWord: 0 ofObject: result withValue: long0. self storeWord: 1 ofObject: result withValue: long1. ^ result! ! !InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 11/8/1998 10:46'! floatValueOf: objectPointer | float len long0 long1 | (self isIntegerObject: objectPointer) ifTrue: [^ (self integerValueOf: objectPointer) asFloat]. (self fetchClassOf: objectPointer) = (self splObj: ClassFloat) ifFalse: [self success: false. ^0.0]. len _ self fetchWordLengthOf: objectPointer. len = 2 ifFalse: [self success: false. ^0.0]. "Make up a Float from the bits" long0 _ self fetchWord: 0 ofObject: objectPointer. long1 _ self fetchWord: 1 ofObject: objectPointer. float _ Float new: 2. "No conversion needed for Squeak" float at: 1 put: long0. float at: 2 put: long1. ^ float! ! !InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 11/8/1998 10:47'! loadFloatOrIntFrom: floatOrInt "If floatOrInt is an integer, then convert it to a C double float and return it. If it is a Float, then load its value and return it. Otherwise fail -- ie return with successFlag set to false." (self isIntegerObject: floatOrInt) ifTrue: [^ (self integerValueOf: floatOrInt) asFloat]. self assertClassOf: floatOrInt is: (self splObj: ClassFloat). successFlag ifTrue: [^ self floatValueOf: floatOrInt]! ! !InterpreterSimulator methodsFor: 'float primitives'! popFloat ^ self floatValueOf: (self popStack)! ! !InterpreterSimulator methodsFor: 'float primitives' stamp: 'jm 9/24/97 22:52'! popFloatOnly | number | (self isIntegerObject: (number _ self popStack)) ifTrue: [ self success: false. ^0.0. ]. ^ self floatValueOf: number! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveArctan "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: rcvr arcTan] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveAsFloat "Use host Smalltalk's native function." | arg | arg _ self popInteger. successFlag ifTrue: [self pushFloat: arg asFloat] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveExp "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: rcvr exp] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveExponent "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushInteger: rcvr exponent] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives' stamp: 'di 11/27/1998 12:14'! primitiveFloatDivide: rcvrOop byArg: argOop "NOTE: This method had to be overridden due to the use of // in super" | rcvr arg | self var: #rcvr declareC: 'double rcvr'. self var: #arg declareC: 'double arg'. rcvr _ self loadFloatOrIntFrom: rcvrOop. arg _ self loadFloatOrIntFrom: argOop. successFlag ifTrue: [ self success: arg ~= 0.0. successFlag ifTrue: [ self pop: 2. self push: (self floatObjectOf: rcvr / arg) " / overrides // "]].! ! !InterpreterSimulator methodsFor: 'float primitives' stamp: 'jm 9/24/97 22:52'! primitiveFractionalPart "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloatOnly. successFlag ifTrue: [self pushFloat: rcvr fractionPart] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveLogN "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: rcvr ln] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveSine "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: rcvr sin] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveSquareRoot "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushFloat: rcvr sqrt] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveTimesTwoPower "Use Smalltalk's native function (tho could just fail)" | rcvr arg | arg _ self popInteger. rcvr _ self popFloat. successFlag ifTrue: [ self pushFloat: (rcvr timesTwoPower: arg) ] ifFalse: [ self unPop: 2 ].! ! !InterpreterSimulator methodsFor: 'float primitives'! primitiveTruncated "Use host Smalltalk's native function." | rcvr | rcvr _ self popFloat. successFlag ifTrue: [self pushInteger: rcvr truncated] ifFalse: [self unPop: 1].! ! !InterpreterSimulator methodsFor: 'float primitives'! pushFloat: f self push: (self floatObjectOf: f).! ! !InterpreterSimulator methodsFor: 'memory access'! byteAt: byteAddress | lowBits | lowBits _ byteAddress bitAnd: 3. ^((self longAt: byteAddress - lowBits) bitShift: (lowBits - 3) * 8) bitAnd: 16rFF! ! !InterpreterSimulator methodsFor: 'memory access'! byteAt: byteAddress put: byte | longWord shift lowBits | lowBits _ byteAddress bitAnd: 3. longWord _ self longAt: byteAddress - lowBits. shift _ (3 - lowBits) * 8. longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self longAt: byteAddress put: longWord! ! !InterpreterSimulator methodsFor: 'memory access'! longAt: byteAddress "Note: Adjusted for Smalltalk's 1-based array indexing." ^memory at: (byteAddress // 4) + 1! ! !InterpreterSimulator methodsFor: 'memory access'! longAt: byteAddress put: a32BitValue "Note: Adjusted for Smalltalk's 1-based array indexing." ^memory at: (byteAddress // 4) + 1 put: a32BitValue! ! !InterpreterSimulator methodsFor: 'arithmetic'! bytecodePrimGreaterOrEqual "Must be overridden from Interpreter because simulator doesn't have 32-bit signed ints to work with" | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [ ^ self booleanCheat: (self integerValueOf: rcvr) >= (self integerValueOf: arg)]. ^ super bytecodePrimGreaterOrEqual! ! !InterpreterSimulator methodsFor: 'arithmetic'! bytecodePrimGreaterThan "Must be overridden from Interpreter because simulator doesn't have 32-bit signed ints to work with" | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [ ^ self booleanCheat: (self integerValueOf: rcvr) > (self integerValueOf: arg)]. ^ super bytecodePrimGreaterThan! ! !InterpreterSimulator methodsFor: 'arithmetic'! bytecodePrimLessOrEqual "Must be overridden from Interpreter because simulator doesn't have 32-bit signed ints to work with" | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [ ^ self booleanCheat: (self integerValueOf: rcvr) <= (self integerValueOf: arg)]. ^ super bytecodePrimLessOrEqual! ! !InterpreterSimulator methodsFor: 'arithmetic'! bytecodePrimLessThan "Must be overridden from Interpreter because simulator doesn't have 32-bit signed ints to work with" | rcvr arg | rcvr _ self internalStackValue: 1. arg _ self internalStackValue: 0. (self areIntegers: rcvr and: arg) ifTrue: [ ^ self booleanCheat: (self integerValueOf: rcvr) < (self integerValueOf: arg)]. ^ super bytecodePrimLessThan! ! !InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'! primBitmapcompresstoByteArray ^ self primitiveFail! ! !InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 11/23/1998 22:41'! primBitmapdecompressfromByteArrayat | indexInt index baOop bmOop baSize bmSize ba bm | indexInt _ self stackTop. (self isIntegerValue: indexInt) ifFalse: [^ self primitiveFail]. index _ self integerValueOf: indexInt. baOop _ self stackValue: 1. bmOop _ self stackValue: 2. baSize _ self stSizeOf: baOop. bmSize _ self stSizeOf: bmOop. ba _ ByteArray new: baSize. bm _ Bitmap new: bmSize. "Copy the byteArray into ba" 1 to: baSize do: [:i | ba at: i put: (self fetchByte: i-1 ofObject: baOop)]. "Decompress ba into bm" bm decompress: bm fromByteArray: ba at: index. "Then copy bm into the Bitmap" 1 to: bmSize do: [:i | self storeWord: i-1 ofObject: bmOop withValue: (bm at: i)]. self pop: 3! ! !InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 6/29/1998 22:17'! primStringcomparewithcollated ^ self primitiveFail! ! !InterpreterSimulator methodsFor: 'other primitives' stamp: 'ikp 12/15/1998 23:30'! primStringfindSubstringinstartingAtmatchTable ^self primitiveFail! ! !InterpreterSimulator methodsFor: 'other primitives' stamp: 'di 11/8/1998 13:04'! primStringindexOfAsciiinStringstartingAt ^ self primitiveFail! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:32'! pushLiteralConstantBytecode "Interpreter version has fetchNextBytecode out of order" self pushLiteralConstant: (currentBytecode bitAnd: 16r1F). self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'! pushLiteralVariableBytecode "Interpreter version has fetchNextBytecode out of order" self pushLiteralVariable: (currentBytecode bitAnd: 16r1F). self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:34'! pushReceiverVariableBytecode "Interpreter version has fetchNextBytecode out of order" self pushReceiverVariable: (currentBytecode bitAnd: 16rF). self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:35'! pushTemporaryVariableBytecode "Interpreter version has fetchNextBytecode out of order" self pushTemporaryVariable: (currentBytecode bitAnd: 16rF). self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/12/1998 08:30'! storeAndPopReceiverVariableBytecode "Note: This code uses storePointerUnchecked:ofObject:withValue: and does the store check explicitely in order to help the translator produce better code." "Interpreter version has fetchNextBytecode out of order" | rcvr top | rcvr _ receiver. top _ self internalStackTop. (rcvr < youngStart) ifTrue: [ self possibleRootStoreInto: rcvr value: top. ]. self storePointerUnchecked: (currentBytecode bitAnd: 7) ofObject: rcvr withValue: top. self internalPop: 1. self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'bytecode routines' stamp: 'di 12/11/1998 17:32'! storeAndPopTemporaryVariableBytecode "Interpreter version has fetchNextBytecode out of order" self storePointerUnchecked: (currentBytecode bitAnd: 7) + TempFrameStart ofObject: localHomeContext withValue: self internalStackTop. self internalPop: 1. self fetchNextBytecode. ! ! !InterpreterSimulator methodsFor: 'old Interpreter code' stamp: 'jm 12/30/2003 22:00'! primitiveSnapshot | activeProc dataSize rcvr | "save the state of the current process and save it on the scheduler queue" self storeContextRegisters: activeContext. activeProc _ self fetchPointer: ActiveProcessIndex ofObject: self schedulerPointer. self storePointer: SuspendedContextIndex ofObject: activeProc withValue: activeContext. "compact memory and compute the size of the memory actually in use" self cleanUpContexts. self incrementalGC. "maximimize space for forwarding table" self fullGC. dataSize _ freeBlock - (self startOfMemory). "Assume: all objects are below the start of the free block" successFlag ifTrue: [ rcvr _ self popStack. "pop rcvr" self push: trueObj. self writeImageFile: dataSize. self pop: 1. "pop true" ]. successFlag ifTrue: [ self push: falseObj ] ifFalse: [ self push: rcvr ]. ! ! !InterpreterSimulator methodsFor: 'old Interpreter code' stamp: 'jm 12/30/2003 22:02'! putLong: n toFile: f "Append the given 4-byte long word to the given file in this platforms 'natural' byte order. (Bytes will be swapped, if necessary, when the image is read on a different platform.) Set successFlag to false if the write fails." | wordsWritten | self var: #f declareC: 'sqImageFile f'. wordsWritten _ self cCode: 'sqImageFileWrite(&n, sizeof(int), 1, f)'. self success: wordsWritten = 1. ! ! !InterpreterSimulator methodsFor: 'old Interpreter code' stamp: 'jm 12/30/2003 22:00'! writeImageFileREAL: imageBytes "This is the the version of this method from Interpreter. It was removed from Interpreter and installed here in case we want to reinstate it later." | headerStart headerSize f bytesWritten | self var: #f declareC: 'sqImageFile f'. "local constants" headerStart _ 0. "change to 512 to leave room for a Unix exec string" headerSize _ 64. "header size in bytes; do not change!!" f _ self cCode: 'sqImageFileOpen(imageName, "wb")'. f = nil ifTrue: [ "could not open the image file for writing" self success: false. ^ nil]. self cCode: '/* Note: on Unix systems one could put an exec command here, padded to 512 bytes */'. "position file to start of header" self sqImageFile: f Seek: headerStart. self putLong: (self imageFormatVersion) toFile: f. self putLong: headerSize toFile: f. self putLong: imageBytes toFile: f. self putLong: (self startOfMemory) toFile: f. self putLong: specialObjectsOop toFile: f. self putLong: lastHash toFile: f. self putLong: (self ioScreenSize) toFile: f. self putLong: fullScreenFlag toFile: f. 1 to: 8 do: [:i | self putLong: 0 toFile: f]. "fill remaining header words with zeros" successFlag ifFalse: [ "file write or seek failure" self cCode: 'sqImageFileClose(f)'. ^ nil]. "position file after the header" self sqImageFile: f Seek: headerStart + headerSize. "write the image data" bytesWritten _ self cCode: 'sqImageFileWrite(memory, sizeof(unsigned char), imageBytes, f)'. self success: bytesWritten = imageBytes. self cCode: 'sqImageFileClose(f)'. "set Mac file type and creator; this is a noop on other platforms" self cCode: 'dir_SetMacFileTypeAndCreator(imageName, strlen(imageName), "STim", "FAST")'. ! ! This class overrides a few methods in InterpreterSimulator required for simulation to work on little-endian architectures (such as the x86 family of processors). To start it up simply use InterpreterSimulatorLSB instead of InterpreterSimulator (see the class comment there for more details). For example: (InterpreterSimulatorLSB new openOn: Smalltalk imageName) test Note that the image must have been saved at least once on the local architecture, since the compiled VM performs some byte swapping that the simulator cannot cope with.! !InterpreterSimulatorLSB methodsFor: 'initialization' stamp: 'ikp 12/11/1998 01:35'! nextLongFrom: aStream "Read a 32-bit quantity from the given (binary) stream." | bytes | bytes _ aStream nextInto: (ByteArray new: 4). ^ Integer byte1: (bytes at: 1) byte2: (bytes at: 2) byte3: (bytes at: 3) byte4: (bytes at: 4)! ! !InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'ikp 12/11/1998 01:35'! byteAt: byteAddress | lowBits | lowBits _ byteAddress bitAnd: 3. ^((self longAt: byteAddress - lowBits) bitShift: (0 - lowBits) * 8) bitAnd: 16rFF! ! !InterpreterSimulatorLSB methodsFor: 'memory access' stamp: 'ikp 12/11/1998 01:35'! byteAt: byteAddress put: byte | longWord shift lowBits | lowBits _ byteAddress bitAnd: 3. longWord _ self longAt: byteAddress - lowBits. shift _ lowBits * 8. longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) + (byte bitShift: shift). self longAt: byteAddress - lowBits put: longWord! ! !InterpreterSimulatorLSB methodsFor: 'debug support' stamp: 'ikp 12/11/1998 01:35'! charsOfLong: long ^ (1 to: 4) collect: [:i | ((long digitAt: i) between: 14 and: 126) ifTrue: [(long digitAt: i) asCharacter] ifFalse: [$?]]! ! This class is a shell that includes all the ancillary C code for supporting Squeak on Mac OS versions 7.6 - 9.x. Many of these source files are cross-platform; only the files with "Mac" in their names are specific to the Mac OS. Executing InterpreterSupportCode writeMacSourceFiles will cause the creation of a number of files in your working directory which, together with the file "interp.c" are sufficient to compile a complete, ready-to-run Squeak interpreter. ! !InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 1/6/98 12:01'! archiveBinaryFileBytes "Convert the Mac CodeWarrier Project archive data into a ByteArray." | data b | data _ self macArchiveBinaryFile. b _ ByteArray new: data size. 1 to: data size do: [ :i | b at: i put: (data at: i)]. ^ b ! ! !InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 11/15/2003 07:30'! cCodeForMiscPrimitives "Return the contents of the miscellaneous primitives file, which is generated via automatic translation to C." ^ CCodeGenerator new codeStringForPrimitives: #( (Bitmap compress:toByteArray:) (Bitmap decompress:fromByteArray:at:) (Bitmap encodeBytesOf:in:at:) (Bitmap encodeInt:in:at:) (String compare:with:collated:) (String translate:from:to:table:) (String findFirstInString:inSet:startingAt:) (String indexOfAscii:inString:startingAt:) (String findSubstring:in:startingAt:matchTable:)) ! ! !InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 12/22/2003 14:21'! compareWithFilesInFolder: folderName "InterpreterSupportCode compareWithFilesInFolder: 'Sackbut:Desktop Folder:MicroSqueak:VM Build'" | dir | dir _ FileDirectory on: folderName. (dir readOnlyFileNamed: 'msq.h') contentsOfEntireFile = InterpreterSupportCode msqHeaderFile ifFalse: [self inform: 'File msq.h differs from the version stored in this image.']. (dir readOnlyFileNamed: 'msqFilePrims.c') contentsOfEntireFile = InterpreterSupportCode msqFilePrimsFile ifFalse: [self inform: 'File msqFilePrims differs from the version stored in this image.']. (dir readOnlyFileNamed: 'msqMain.c') contentsOfEntireFile = InterpreterSupportCode msqMainFile ifFalse: [self inform: 'File msqMain.c differs from the version stored in this image.']. (dir readOnlyFileNamed: 'projectArchive.sit') binary contentsOfEntireFile = InterpreterSupportCode archiveBinaryFileBytes ifFalse: [self inform: 'File projectArchive.sit differs from the version stored in this image.']. ! ! !InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 1/6/98 12:01'! storeProjectArchiveOnFileNamed: fileName "Store into this image's folder a StuffIt archive file containing the CodeWarrier project files for the virtual machine. You will need to use a StuffIt unpacking utility such as StuffIt Expander to unpack the file. The result will be two project files for CodeWarrier, version 8." | f | f _ (FileStream newFileNamed: fileName) binary. self macArchiveBinaryFile do: [:byte | f nextPut: byte]. f close. FileDirectory default setMacFileNamed: fileName type: 'SITD' creator: 'SIT!!'. ! ! !InterpreterSupportCode class methodsFor: 'source file exporting'! storeString: s onFileNamed: fileName "Store the given string in a file of the given name." | f | f _ FileStream newFileNamed: fileName. f nextPutAll: s. f close.! ! !InterpreterSupportCode class methodsFor: 'source file exporting' stamp: 'jm 12/22/2003 14:16'! writeMacSourceFiles "Store into this image's folder the C sources files required to support the interpreter on the Macintosh. To generate code for the interpreter itself (interp.c), use the method 'translate:doInlining:' in Interpreter class." "InterpreterSupportCode writeMacSourceFiles" self storeString: self readmeFile onFileNamed: 'readme'. self storeString: self msqHeaderFile onFileNamed: 'msq.h'. self storeString: self msqFilePrimsFile onFileNamed: 'msqFilePrims.c'. self storeString: self msqMainFile onFileNamed: 'msqMain.c'. self storeString: self cCodeForMiscPrimitives onFileNamed: 'msqMiscPrims.c'. self storeProjectArchiveOnFileNamed: 'projectArchive.sit'. ! ! !InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 11/16/2003 15:15'! macArchiveBinaryFile "To create this method use: (FileStream oldFileNamed: 'projectArchive.sit') binary contentsOfEntireFile asArray" ^ #(83 116 117 102 102 73 116 32 40 99 41 49 57 57 55 45 49 57 57 56 32 65 108 97 100 100 105 110 32 83 121 115 116 101 109 115 44 32 73 110 99 46 44 32 104 116 116 112 58 47 47 119 119 119 46 97 108 97 100 100 105 110 115 121 115 46 99 111 109 47 83 116 117 102 102 73 116 47 13 10 26 0 5 16 0 0 14 239 0 0 0 114 0 1 0 0 0 114 156 125 13 165 165 82 101 115 101 114 118 101 100 165 165 0 165 165 165 165 1 0 0 67 0 0 172 94 117 49 187 221 68 126 0 0 0 0 0 0 0 0 0 0 0 0 0 19 127 58 0 0 14 228 0 0 4 12 0 0 0 0 15 0 77 105 99 114 111 83 113 117 101 97 107 32 86 77 46 112 114 111 106 0 1 131 18 77 77 80 82 67 87 73 69 1 0 255 255 255 255 0 0 0 0 0 0 0 0 0 0 128 0 0 0 0 6 178 167 0 0 42 205 0 0 9 252 0 0 0 0 15 0 66 193 212 168 207 18 112 246 211 235 179 22 159 28 213 46 63 36 218 177 136 30 154 54 104 137 46 198 143 185 7 88 95 35 17 52 137 197 171 186 132 56 9 253 125 10 32 32 4 228 110 92 169 20 15 127 109 205 202 242 231 15 52 44 180 221 199 230 28 189 162 143 237 194 139 128 74 179 214 113 57 14 113 26 250 39 165 92 208 140 166 175 113 18 212 136 249 102 44 117 125 84 8 237 196 0 179 122 2 191 227 155 36 157 12 46 73 64 232 233 226 92 191 181 23 220 202 55 81 3 183 159 151 170 238 116 189 164 74 188 156 152 199 248 194 107 207 129 99 27 150 80 17 189 15 28 247 117 220 168 254 148 115 218 179 228 111 6 250 157 83 223 104 2 12 233 163 166 60 157 108 89 138 92 168 86 29 85 79 41 148 179 58 68 58 237 199 147 101 235 60 116 164 236 227 153 83 44 188 131 233 182 171 216 160 185 130 183 69 236 35 131 178 44 215 169 131 171 181 224 163 9 61 9 223 66 7 4 126 244 65 43 139 111 105 238 6 246 131 85 174 251 72 213 196 20 107 182 111 202 147 59 156 152 88 152 246 180 109 14 71 227 130 233 135 16 211 129 251 195 103 66 182 16 38 172 30 203 87 144 205 220 224 222 165 21 190 6 75 88 60 229 48 113 202 176 69 22 59 78 200 165 235 152 23 112 100 190 183 42 139 177 244 119 197 31 203 88 154 144 119 111 178 100 247 107 79 98 151 238 89 159 245 181 202 104 122 94 195 224 141 36 105 85 110 115 170 225 1 123 205 125 181 225 82 32 71 151 65 86 142 239 117 181 1 189 162 23 224 231 165 147 207 103 102 191 152 127 195 240 173 33 173 166 47 208 254 58 222 28 74 72 43 84 118 133 146 7 66 194 200 186 51 104 179 179 116 243 106 86 232 199 34 127 183 235 250 164 118 81 228 161 116 28 164 127 231 70 2 43 218 253 213 149 81 240 142 233 217 144 195 248 132 178 226 43 11 150 110 39 173 115 215 39 0 81 135 162 155 129 127 116 75 180 42 39 185 247 79 27 5 112 38 65 74 136 7 139 127 141 170 174 184 205 92 192 61 210 20 49 100 45 108 48 145 255 241 44 7 152 176 128 44 231 202 145 155 2 191 218 135 92 49 220 38 125 66 75 190 254 117 74 234 100 32 56 157 154 31 80 231 225 143 53 42 218 74 28 31 221 121 26 74 158 163 147 132 60 71 89 14 5 86 145 240 161 228 219 111 252 196 179 74 107 162 198 169 68 109 245 61 72 133 41 251 60 18 66 86 19 253 133 112 118 95 236 24 161 144 96 3 172 1 254 246 62 92 195 193 188 68 190 53 8 71 219 209 123 235 219 52 158 227 145 209 43 140 18 98 124 72 176 244 3 220 78 228 47 0 116 70 212 58 73 136 237 218 21 73 210 185 42 191 109 198 122 249 252 30 58 18 15 33 112 235 24 24 175 220 42 189 134 132 188 242 5 168 59 151 197 237 82 128 245 68 253 30 145 169 111 133 75 42 150 206 7 56 1 50 202 193 145 169 112 213 216 2 54 241 138 171 176 108 56 4 218 76 114 249 172 32 187 57 24 79 193 100 89 27 227 126 63 170 85 160 85 136 55 221 15 126 201 215 99 212 71 218 21 215 32 144 219 241 180 223 197 147 98 79 13 194 100 119 52 247 162 118 94 191 126 77 168 164 11 62 59 227 26 40 48 204 145 149 107 149 102 70 59 210 143 175 218 84 3 39 68 167 79 191 1 46 126 176 44 135 233 208 37 212 45 249 246 0 105 249 148 193 237 108 38 253 61 70 121 207 134 107 225 20 228 189 80 7 106 80 109 89 70 209 143 186 21 35 176 156 226 29 114 13 144 31 120 152 186 148 176 156 100 230 78 91 199 29 226 203 76 65 189 145 228 167 33 119 163 124 183 207 226 59 233 104 133 218 155 27 223 215 255 247 18 54 203 127 57 64 33 223 34 200 251 121 47 95 117 38 124 57 221 11 220 103 185 180 56 245 10 152 137 61 19 91 200 217 136 78 108 171 40 12 173 67 219 81 37 50 76 208 51 249 183 208 247 93 144 206 217 92 44 228 233 4 68 173 103 88 32 61 202 23 198 48 240 232 225 226 19 214 234 75 10 144 99 111 5 253 224 126 178 212 180 113 63 203 207 60 189 28 235 29 94 196 128 14 61 175 200 63 121 63 143 13 140 165 164 64 42 61 114 73 12 169 110 32 52 181 111 138 47 110 46 196 11 63 236 245 130 111 240 88 245 47 110 48 71 131 29 100 36 200 31 141 94 155 30 219 112 208 8 176 146 126 66 78 58 122 27 244 254 191 145 149 193 118 89 173 109 214 226 177 73 36 237 44 115 219 154 140 197 47 250 19 211 221 120 196 217 197 242 79 195 129 122 95 114 173 158 105 12 231 143 138 142 37 74 66 53 202 117 173 171 29 85 255 200 237 236 19 112 133 54 254 3 233 198 59 26 90 67 171 217 133 110 229 196 19 235 56 111 157 105 5 103 68 195 66 237 3 240 137 186 223 19 39 190 112 23 111 68 141 16 250 183 21 147 208 179 244 68 20 177 19 239 42 168 73 113 38 95 137 31 75 187 107 247 126 75 234 78 227 87 135 72 130 206 207 35 229 110 68 199 192 96 78 16 44 10 169 190 228 15 24 186 157 213 130 62 30 10 44 160 42 218 122 26 101 175 11 194 126 55 112 205 200 113 204 4 253 121 39 121 26 206 113 196 231 40 193 131 59 168 5 80 209 110 233 239 81 211 74 252 181 93 18 21 48 183 63 249 33 135 37 208 153 75 32 169 238 182 149 87 107 79 86 150 146 152 203 255 194 218 34 88 6 122 249 130 228 25 248 30 130 58 172 88 26 48 230 133 221 32 8 242 239 222 215 165 154 32 28 126 190 75 156 46 221 149 227 139 188 125 90 14 115 99 234 221 133 151 147 199 242 155 211 215 106 67 124 189 250 38 119 168 69 186 245 164 61 194 82 254 11 37 203 110 171 132 168 150 205 37 44 253 214 54 57 61 30 8 6 140 45 113 155 22 73 106 98 39 90 230 172 121 3 174 214 56 118 91 181 97 115 250 223 61 228 172 255 177 34 37 87 147 92 197 240 47 241 70 231 81 109 17 111 215 222 212 164 195 127 168 51 199 65 114 199 150 123 132 177 90 248 111 12 191 52 130 122 205 166 206 227 203 202 209 149 120 110 178 30 130 7 93 104 207 63 15 230 20 51 90 14 49 121 225 203 150 53 170 74 10 170 217 141 94 238 75 241 62 99 132 220 65 105 59 198 29 88 196 80 223 98 113 83 224 116 232 155 219 196 78 158 65 0 16 44 48 87 86 27 250 171 127 252 185 48 155 131 138 107 48 196 186 176 186 7 126 49 55 218 137 69 102 210 97 106 89 155 187 241 25 12 169 220 88 192 113 71 231 226 15 47 94 167 27 134 230 80 52 183 133 117 131 210 227 247 41 59 210 208 202 2 186 185 126 94 196 97 30 249 127 114 111 89 38 21 82 85 93 63 17 44 180 149 171 161 137 135 252 183 34 201 164 104 135 194 62 164 195 92 29 36 31 172 140 147 150 227 101 83 49 82 211 241 165 206 248 82 254 70 242 226 49 86 200 183 88 76 252 26 94 0 223 151 136 87 252 218 176 161 88 2 242 192 250 41 118 63 179 246 71 36 127 81 155 234 193 166 140 111 16 9 31 153 0 84 228 191 106 163 236 209 21 43 61 111 221 245 208 251 208 165 210 251 199 129 72 101 238 89 242 29 227 190 95 93 75 162 99 54 115 26 202 131 37 130 83 17 24 40 11 163 71 211 20 13 229 140 140 77 63 183 47 204 135 198 65 89 53 106 254 179 214 32 241 45 250 48 65 28 83 106 41 100 174 117 163 208 99 135 30 115 53 241 61 105 137 214 66 37 14 89 122 110 67 70 20 179 144 148 87 203 46 76 213 250 176 36 49 152 20 138 238 89 99 243 74 96 233 254 17 172 88 218 34 154 33 177 132 166 126 73 48 85 76 219 8 119 17 251 213 58 125 237 1 124 239 35 126 52 115 147 123 97 21 253 92 132 144 191 191 54 1 210 189 71 175 100 29 110 27 61 218 185 220 147 122 254 122 153 72 161 99 221 216 22 89 75 94 164 144 25 168 35 214 197 40 62 203 110 98 14 93 43 51 106 75 178 162 129 112 63 145 236 152 94 28 107 179 25 223 191 241 243 236 14 254 217 94 136 195 198 65 143 28 120 171 162 241 34 120 171 68 246 128 89 88 151 13 211 127 221 201 162 34 100 85 52 231 135 68 180 92 212 136 38 168 88 243 185 59 67 137 253 242 111 22 236 30 30 46 133 115 39 211 82 230 2 31 76 17 203 179 238 188 109 83 166 2 117 231 113 30 182 190 14 216 41 225 86 88 99 33 169 163 6 185 83 190 156 82 106 227 150 228 106 75 188 219 253 144 87 182 152 71 176 124 89 159 158 56 83 34 77 166 160 21 22 193 124 37 142 100 101 77 74 41 186 77 254 137 4 43 56 137 169 193 141 11 23 212 22 10 55 195 110 173 245 50 219 7 10 30 117 89 198 219 131 179 45 201 157 88 252 175 90 227 48 183 94 163 32 75 94 174 80 17 214 86 229 98 34 149 47 74 28 90 6 188 142 215 197 84 129 145 176 89 91 220 54 88 169 75 236 219 30 192 4 21 114 214 37 2 93 92 61 28 38 123 65 25 136 104 113 90 124 174 86 156 40 109 128 129 136 27 29 69 67 238 120 89 12 4 49 221 130 95 143 161 185 106 97 43 52 172 47 238 2 131 153 154 123 145 213 122 253 141 54 227 163 210 134 16 62 45 9 229 93 224 146 127 181 122 163 215 229 184 131 242 44 189 35 177 9 28 28 80 219 120 168 128 77 190 227 27 87 38 70 241 148 184 212 155 38 35 9 168 251 82 212 201 139 75 192 163 206 42 67 211 230 59 108 39 49 111 240 183 30 232 204 132 164 111 21 115 5 11 130 122 77 223 82 72 159 229 182 34 205 76 240 121 23 137 251 101 94 175 25 9 194 159 19 238 236 28 25 15 108 195 74 101 251 171 71 15 226 138 12 101 221 151 107 76 22 71 86 239 46 125 191 245 21 91 124 112 31 48 178 191 78 87 90 245 35 176 125 224 145 246 48 211 7 198 55 137 218 203 46 90 127 162 141 52 5 164 225 252 243 109 61 60 138 9 243 121 152 80 153 219 229 5 140 142 230 254 34 213 19 148 99 188 111 39 124 123 178 103 161 226 247 203 252 121 225 56 191 53 108 201 230 182 212 88 59 157 185 71 203 199 213 115 113 18 178 166 83 11 151 131 197 230 41 232 45 186 202 84 155 51 168 179 54 46 91 91 48 81 247 127 11 159 67 1 35 194 91 29 63 234 90 148 214 117 111 27 209 96 196 85 45 145 220 249 113 46 53 196 149 129 0 85 44 239 178 129 253 209 119 32 255 137 58 27 98 127 50 249 216 46 190 206 39 248 9 125 195 38 106 18 71 196 173 56 200 103 54 184 82 55 77 88 219 143 93 5 163 189 69 26 90 200 20 250 242 64 82 178 248 155 38 77 81 186 182 237 92 25 235 55 0 59 136 170 33 235 227 17 21 237 67 76 196 162 197 71 208 184 66 193 212 192 90 96 245 144 132 185 215 54 68 244 240 40 68 21 85 144 190 215 195 147 130 248 0 7 207 20 121 108 159 55 237 5 158 180 77 215 48 63 211 112 79 158 30 252 185 191 211 23 249 87 52 9 191 54 163 205 169 206 77 77 163 114 199 88 96 82 171 70 67 55 114 214 194 230 64 125 255 152 104 40 92 70 21 123 53 242 170 25 74 180 198 39 160 193 221 120 136 23 205 243 16 214 82 23 114 132 64 185 231 27 99 76 25 114 152 83 15 189 139 164 214 194 247 66 47 86 207 45 49 149 251 161 115 165 126 185 217 79 247 15 226 217 191 182 141 230 4 195 50 47 38 144 52 120 56 153 142 63 156 252 229 127 13 222 44 153 168 106 185 137 33 22 195 245 170 69 216 145 120 14 29 141 175 86 159 231 247 6 117 128 236 137 142 26 113 204 91 157 152 77 182 194 18 101 223 43 210 241 15 118 234 74 46 63 56 170 69 165 150 60 189 132 8 134 158 127 244 149 201 112 43 2 194 105 63 202 119 34 241 244 177 74 239 80 132 39 85 225 112 108 127 165 154 51 231 51 134 129 61 85 100 226 78 171 204 69 211 205 162 63 59 236 156 57 112 176 15 28 193 17 89 141 179 175 182 136 188 10 129 162 122 241 239 17 142 112 29 130 244 79 230 107 183 222 173 108 123 154 100 197 76 254 170 244 194 90 214 245 244 25 190 75 97 24 249 202 186 54 145 45 247 199 238 126 32 10 120 147 189 209 188 26 30 109 111 225 169 120 162 165 201 155 96 85 92 163 39 212 110 34 92 61 240 117 187 87 104 60 140 108 102 137 26 215 1 213 243 119 131 155 126 111 108 66 53 12 82 4 24 4 156 159 135 193 130 128 193 190 3 232 109 190 232 115 143 197 25 172 167 77 60 105 172 171 191 0 101 148 2 223 4 51 115 251 27 118 83 96 125 173 101 113 91 122 4 23 118 85 30 245 145 232 224 137 128 220 116 122 173 142 94 150 127 19 151 145 82 132 240 247 153 224 124 176 232 66 239 94 207 153 208 245 233 164 11 236 37 185 142 179 223 76 13 207 183 168 131 120 239 230 29 30 12 13 175 228 125 58 186 173 6 164 53 160 170 224 186 240 70 18 55 160 19 249 36 183 97 7 119 202 131 25 153 14 124 253 253 184 232 238 98 76 130 211 195 16 35 233 124 174 207 163 128 242 143 70 139 208 163 203 129 5 208 167 227 192 55 12 203 98 21 228 122 200 4 136 140 73 161 188 3 215 44 255 82 154 51 35 59 148 85 176 191 159 46 248 69 220 132 206 230 55 216 66 112 166 30 90 221 137 15 18 110 51 8 190 54 186 42 96 241 70 222 204 27 124 84 6 42 227 131 108 215 128 164 101 131 244 106 229 160 145 117 213 57 44 50 59 86 248 60 21 147 6 194 39 93 167 44 220 252 126 56 195 8 151 233 169 51 76 208 61 182 176 228 14 176 0 189 36 253 65 185 216 233 35 65 80 146 3 191 154 69 253 147 42 203 251 137 40 228 213 210 19 229 180 147 46 248 118 17 208 223 84 145 13 35 172 188 14 19 60 188 64 13 181 75 145 212 69 12 156 117 7 219 255 36 11 68 43 182 138 91 101 209 254 105 135 106 10 34 147 177 18 74 84 18 242 158 149 255 107 68 103 68 82 152 178 33 233 42 77 224 21 126 130 48 191 250 88 116 222 236 237 143 24 63 111 94 171 89 15 5 247 162 179 135 85 205 20 12 164 110 128 137 248 34 79 48 250 234 89 224 78 154 139 171 77 243 252 196 158 236 123 46 122 1 228 253 251 11 122 196 34 145 130 249 3 62 72 103 110 15 241 128 93 159 77 243 221 242 221 146 103 84 28 180 49 180 128 52 202 158 67 182 73 151 222 248 229 116 48 91 39 85 171 26 204 97 64 61 25 105 34 207 85 155 6 201 232 126 217 168 78 44 0 16 183 58 185 247 108 32 189 216 249 132 251 147 127 51 77 50 82 189 134 128 5 164 38 51 188 88 172 103 166 138 227 37 98 8 156 35 179 225 36 221 92 134 50 104 233 220 163 98 31 86 97 79 177 209 111 238 129 165 249 136 137 213 141 191 189 148 84 83 218 233 58 78 188 37 195 207 237 165 181 212 134 99 84 106 114 154 193 187 238 249 174 190 160 179 15 136 80 3 87 111 34 185 115 81 144 123 141 14 142 199 74 71 215 183 236 13 27 108 155 249 71 239 126 128 62 139 31 140 131 144 28 95 208 55 97 67 226 31 49 72 30 8 138 136 0) ! ! !InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 12/22/2003 14:22'! msqFilePrimsFile ^ '#include "msq.h" /*** The state of a file is kept in the following structure, which is stored directly in a Squeak bytes object. NOTE: The Squeak side is responsible for creating an object with enough room to store sizeof(SQFile) bytes. The session ID is used to detect stale file objects-- files that were still open when an image was written. The file pointer of such files is meaningless. Files are always opened in binary mode; Smalltalk code does (or someday will do) line-end conversion if needed. Writeable files are opened read/write. The stdio spec requires that a positioning operation be done when switching between reading and writing of a read/write filestream. The lastOp field records whether the last operation was a read or write operation, allowing this positioning operation to be done automatically if needed. typedef struct { File *file; int sessionID; int writable; int fileSize; int lastOp; // 0 = uncommitted, 1 = read, 2 = write // } SQFile; ***/ /*** Constants ***/ #define UNCOMMITTED 0 #define READ_OP 1 #define WRITE_OP 2 #ifndef SEEK_SET #define SEEK_SET 0 #define SEEK_CUR 1 #define SEEK_END 2 #endif /*** Variables ***/ int thisSession = 0; int sqFileAtEnd(SQFile *f) { /* Return true if the file''s read/write head is at the end of the file. */ if (!!sqFileValid(f)) return success(false); return ftell(f->file) == f->fileSize; } int sqFileClose(SQFile *f) { /* Close the given file. */ if (!!sqFileValid(f)) return success(false); fclose(f->file); f->file = NULL; f->sessionID = 0; f->writable = false; f->fileSize = 0; f->lastOp = UNCOMMITTED; } int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize) { char cFileName[1000]; int i, err; if (sqFileNameSize >= 1000) { return success(false); } /* copy the file name into a null-terminated C string */ for (i = 0; i < sqFileNameSize; i++) { cFileName[i] = *((char *) (sqFileNameIndex + i)); } cFileName[sqFileNameSize] = 0; err = remove(cFileName); if (err) { return success(false); } } int sqFileGetPosition(SQFile *f) { /* Return the current position of the file''s read/write head. */ int position; if (!!sqFileValid(f)) return success(false); position = ftell(f->file); if (position < 0) return success(false); return position; } int sqFileInit(void) { /* Create a session ID that is unlikely to be repeated. Zero is never used for a valid session number. Should be called once at startup time. */ thisSession = clock() + time(NULL); if (thisSession == 0) thisSession = 1; /* don''t use 0 */ } int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag) { /* Opens the given file using the supplied sqFile structure to record its state. Fails with no side effects if f is already open. Files are always opened in binary mode; Squeak must take care of any line-end character mapping. */ char cFileName[1001]; int i; /* don''t open an already open file */ if (sqFileValid(f)) return success(false); /* copy the file name into a null-terminated C string */ if (sqFileNameSize > 1000) { return success(false); } for (i = 0; i < sqFileNameSize; i++) { cFileName[i] = *((char *) (sqFileNameIndex + i)); } cFileName[sqFileNameSize] = 0; if (writeFlag) { /* First try to open an existing file read/write: */ f->file = fopen(cFileName, "r+b"); if (f->file == NULL) { /* Previous call fails if file does not exist. In that case, try opening it in write mode to create a new, empty file. */ f->file = fopen(cFileName, "w+b"); if (f->file !!= NULL) { /* set the type and creator of newly created Mac files */ dir_SetMacFileTypeAndCreator(cFileName, strlen(cFileName), "TEXT", "R*ch"); } } f->writable = true; } else { f->file = fopen(cFileName, "rb"); f->writable = false; } if (f->file == NULL) { f->sessionID = 0; f->fileSize = 0; return success(false); } else { f->sessionID = thisSession; /* compute and cache file size */ fseek(f->file, 0, SEEK_END); f->fileSize = ftell(f->file); fseek(f->file, 0, SEEK_SET); } f->lastOp = UNCOMMITTED; } int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex) { /* Read count bytes from the given file into byteArray starting at startIndex. byteArray is the address of the first byte of a Squeak bytes object (e.g. String or ByteArray). startIndex is a zero-based index; that is a startIndex of 0 starts writing at the first byte of byteArray. */ char *dst; int bytesRead; if (!!sqFileValid(f)) return success(false); if (f->writable && (f->lastOp == WRITE_OP)) fseek(f->file, 0, SEEK_CUR); /* seek between writing and reading */ dst = (char *) (byteArrayIndex + startIndex); bytesRead = fread(dst, 1, count, f->file); f->lastOp = READ_OP; return bytesRead; } int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize) { char cOldName[1000], cNewName[1000]; int i, err; if ((oldNameSize >= 1000) || (newNameSize >= 1000)) { return success(false); } /* copy the file names into null-terminated C strings */ for (i = 0; i < oldNameSize; i++) { cOldName[i] = *((char *) (oldNameIndex + i)); } cOldName[oldNameSize] = 0; for (i = 0; i < newNameSize; i++) { cNewName[i] = *((char *) (newNameIndex + i)); } cNewName[newNameSize] = 0; err = rename(cOldName, cNewName); if (err) { return success(false); } } int sqFileSetPosition(SQFile *f, int position) { /* Set the file''s read/write head to the given position. */ if (!!sqFileValid(f)) return success(false); fseek(f->file, position, SEEK_SET); f->lastOp = UNCOMMITTED; } int sqFileSize(SQFile *f) { /* Return the length of the given file. */ if (!!sqFileValid(f)) return success(false); return f->fileSize; } int sqFileValid(SQFile *f) { return ( (f !!= NULL) && (f->file !!= NULL) && (f->sessionID == thisSession)); } int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex) { /* Write count bytes to the given writable file starting at startIndex in the given byteArray. (See comment in sqFileReadIntoAt for interpretation of byteArray and startIndex). */ char *src; int bytesWritten, position; if (!!(sqFileValid(f) && f->writable)) return success(false); if (f->lastOp == READ_OP) fseek(f->file, 0, SEEK_CUR); /* seek between reading and writing */ src = (char *) (byteArrayIndex + startIndex); bytesWritten = fwrite(src, 1, count, f->file); position = ftell(f->file); if (position > f->fileSize) { f->fileSize = position; /* update file size */ } if (bytesWritten !!= count) { success(false); } f->lastOp = WRITE_OP; return bytesWritten; } ' ! ! !InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 12/22/2003 14:14'! msqHeaderFile ^ '#include <math.h> #include <stdio.h> #include <stdlib.h> #include <string.h> #include <time.h> #include "sqConfig.h" #define true 1 #define false 0 #define null 0 /* using ''null'' because nil is predefined in Think C */ /* pluggable primitives macros */ /* Note: All pluggable primitives are defined as EXPORT(int) somePrimitive(void) If the platform requires special declaration modifiers the EXPORT macro can be redefined */ #define EXPORT(returnType) returnType /* image save/restore macros */ /* Note: The image file save and restore code uses these macros; they can be redefined in sqPlatformSpecific.h if desired. These default versions are defined in terms of the ANSI Standard C libraries. */ #define sqImageFile FILE * #define sqImageFileClose(f) fclose(f) #define sqImageFileOpen(fileName, mode) fopen(fileName, mode) #define sqImageFilePosition(f) ftell(f) #define sqImageFileRead(ptr, sz, count, f) fread(ptr, sz, count, f) #define sqImageFileSeek(f, pos) fseek(f, pos, SEEK_SET) #define sqImageFileWrite(ptr, sz, count, f) fwrite(ptr, sz, count, f) #define sqAllocateMemory(minHeapSize, desiredHeapSize) malloc(desiredHeapSize) /* platform-dependent float conversion macros */ /* Note: Second argument must be a variable name, not an expression!! */ /* Note: Floats in image are always in PowerPC word order; change these macros to swap words if necessary. This costs no extra and obviates sometimes having to word-swap floats when reading an image. */ #if defined(DOUBLE_WORD_ALIGNMENT) || defined(DOUBLE_WORD_ORDER) # ifdef DOUBLE_WORD_ORDER /* word-based copy with swapping for non-PowerPC order */ # define storeFloatAtfrom(i, floatVarName) \ *((int *) (i) + 0) = *((int *) &(floatVarName) + 1); \ *((int *) (i) + 1) = *((int *) &(floatVarName) + 0); # define fetchFloatAtinto(i, floatVarName) \ *((int *) &(floatVarName) + 0) = *((int *) (i) + 1); \ *((int *) &(floatVarName) + 1) = *((int *) (i) + 0); # else /*!!DOUBLE_WORD_ORDER*/ /* word-based copy for machines with alignment restrictions */ # define storeFloatAtfrom(i, floatVarName) \ *((int *) (i) + 0) = *((int *) &(floatVarName) + 0); \ *((int *) (i) + 1) = *((int *) &(floatVarName) + 1); # define fetchFloatAtinto(i, floatVarName) \ *((int *) &(floatVarName) + 0) = *((int *) (i) + 0); \ *((int *) &(floatVarName) + 1) = *((int *) (i) + 1); # endif /*!!DOUBLE_WORD_ORDER*/ #else /*!!(DOUBLE_WORD_ORDER||DOUBLE_WORD_ALIGNMENT)*/ /* for machines that allow doubles to be on any word boundary */ # define storeFloatAtfrom(i, floatVarName) \ *((double *) (i)) = (floatVarName); # define fetchFloatAtinto(i, floatVarName) \ (floatVarName) = *((double *) (i)); #endif /* this include file may redefine earlier definitions and macros: */ #include "sqPlatformSpecific.h" /* squeak file record; see sqFilePrims.c for details */ typedef struct { FILE *file; int sessionID; int writable; int fileSize; int lastOp; /* 0 = uncommitted, 1 = read, 2 = write */ } SQFile; /* file i/o */ int sqFileAtEnd(SQFile *f); int sqFileClose(SQFile *f); int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize); int sqFileGetPosition(SQFile *f); int sqFileInit(void); int sqFileOpen(SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag); int sqFileReadIntoAt(SQFile *f, int count, int byteArrayIndex, int startIndex); int sqFileRenameOldSizeNewSize(int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize); int sqFileSetPosition(SQFile *f, int position); int sqFileSize(SQFile *f); int sqFileValid(SQFile *f); int sqFileWriteFromAt(SQFile *f, int count, int byteArrayIndex, int startIndex); /* directories */ int dir_Create(char *pathString, int pathStringLength); int dir_Delimitor(void); int dir_Lookup(char *pathString, int pathStringLength, int index, /* outputs: */ char *name, int *nameLength, int *creationDate, int *modificationDate, int *isDirectory, int *sizeIfFile); int dir_PathToWorkingDir(char *pathName, int pathNameMax); int dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator); /* interpreter entry points */ void error(char *s); int checkedByteAt(int byteAddress); int checkedByteAtput(int byteAddress, int byte); int checkedLongAt(int byteAddress); int checkedLongAtput(int byteAddress, int a32BitInteger); int fullDisplayUpdate(void); int initializeInterpreter(int bytesToShift); int interpret(void); int primitiveFail(void); int signalSemaphoreWithIndex(int index); int success(int); /* display, mouse, keyboard, time i/o */ int ioBeep(void); int ioExit(void); int ioForceDisplayUpdate(void); int ioFormPrint( int bitsAddr, int width, int height, int depth, double hScale, double vScale, int landscapeFlag); int ioSetFullScreen(int fullScreen); int ioGetButtonState(void); int ioGetKeystroke(void); int ioMicroMSecs(void); int ioMSecs(void); int ioMousePoint(void); int ioPeekKeystroke(void); int ioProcessEvents(void); int ioPutChar(int); int ioRelinquishProcessorForMicroseconds(int microSeconds); int ioScreenSize(void); int ioSeconds(void); int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY); int ioSetCursorWithMask(int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY); int ioShowDisplay( int dispBitsIndex, int width, int height, int depth, int affectedL, int affectedR, int affectedT, int affectedB); /* cheap clock with coarse resolution (about 17 msecs on Mac) */ # define ioLowResMSecs() ((1000 * clock()) / CLOCKS_PER_SEC) /* optional millisecond clock macro */ #ifdef USE_CLOCK_MSECS # define ioMSecs() ((1000 * clock()) / CLOCKS_PER_SEC) #endif /* image file and VM path names */ extern char imageName[]; int imageNameGetLength(int sqImageNameIndex, int length); int imageNamePutLength(int sqImageNameIndex, int length); int imageNameSize(void); int vmPathSize(void); int vmPathGetLength(int sqVMPathIndex, int length); /* save/restore */ int readImageFromFileHeapSize(sqImageFile f, int desiredHeapSize); /* clipboard (cut/copy/paste) */ int clipboardSize(void); int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex); int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex); /* sound output */ int snd_AvailableSpace(void); int snd_InsertSamplesFromLeadTime(int frameCount, int srcBufPtr, int samplesOfLeadTime); int snd_PlaySamplesFromAtLength(int frameCount, int arrayIndex, int startIndex); int snd_PlaySilence(void); int snd_Start(int frameCount, int samplesPerSec, int stereo, int semaIndex); int snd_Stop(void); /* sound input */ int snd_SetRecordLevel(int level); int snd_StartRecording(int desiredSamplesPerSec, int stereo, int semaIndex); int snd_StopRecording(void); double snd_GetRecordingSampleRate(void); int snd_RecordSamplesIntoAtLength(int buf, int startSliceIndex, int bufferSizeInBytes); /* joystick support */ int joystickInit(void); int joystickRead(int stickIndex); /* netscape plug-in support */ int plugInInit(char *imageName); int plugInShutdown(void); int plugInInterpretCycles(int cycleCount); /* interpreter entry points needed by compiled primitives */ void * arrayValueOf(int arrayOop); int checkedIntegerValueOf(int intOop); void * fetchArrayofObject(int fieldIndex, int objectPointer); double fetchFloatofObject(int fieldIndex, int objectPointer); int fetchIntegerofObject(int fieldIndex, int objectPointer); double floatValueOf(int floatOop); int pop(int nItems); int pushInteger(int integerValue); int sizeOfSTArrayFromCPrimitive(void *cPtr); int storeIntegerofObjectwithValue(int fieldIndex, int objectPointer, int integerValue); /* sound generation primitives (old, for backward compatibility) */ int primWaveTableSoundmixSampleCountintostartingAtpan(void); int primFMSoundmixSampleCountintostartingAtpan(void); int primPluckedSoundmixSampleCountintostartingAtpan(void); int primSampledSoundmixSampleCountintostartingAtpan(void); /* sound generation primitives */ int primFMSoundmixSampleCountintostartingAtleftVolrightVol(void); int primLoopedSampledSoundmixSampleCountintostartingAtleftVolrightVol(void); int primPluckedSoundmixSampleCountintostartingAtleftVolrightVol(void); int primReverbSoundapplyReverbTostartingAtcount(void); int primSampledSoundmixSampleCountintostartingAtleftVolrightVol(void); /* squeak socket record; see sqMacNetwork.c for details */ typedef struct { int sessionID; int socketType; /* 0 = TCP, 1 = UDP */ void *privateSocketPtr; } SQSocket, *SocketPtr; /* networking primitives */ int sqNetworkInit(int resolverSemaIndex); void sqNetworkShutdown(void); void sqResolverAbort(void); void sqResolverAddrLookupResult(char *nameForAddress, int nameSize); int sqResolverAddrLookupResultSize(void); int sqResolverError(void); int sqResolverLocalAddress(void); int sqResolverNameLookupResult(void); void sqResolverStartAddrLookup(int address); void sqResolverStartNameLookup(char *hostName, int nameSize); int sqResolverStatus(void); void sqSocketAbortConnection(SocketPtr s); void sqSocketCloseConnection(SocketPtr s); int sqSocketConnectionStatus(SocketPtr s); void sqSocketConnectToPort(SocketPtr s, int addr, int port); void sqSocketCreateNetTypeSocketTypeRecvBytesSendBytesSemaID( SocketPtr s, int netType, int socketType, int recvBufSize, int sendBufSize, int semaIndex); void sqSocketDestroy(SocketPtr s); int sqSocketError(SocketPtr s); void sqSocketListenOnPort(SocketPtr s, int port); int sqSocketLocalAddress(SocketPtr s); int sqSocketLocalPort(SocketPtr s); int sqSocketReceiveDataAvailable(SocketPtr s); int sqSocketReceiveDataBufCount(SocketPtr s, int buf, int bufSize); int sqSocketRemoteAddress(SocketPtr s); int sqSocketRemotePort(SocketPtr s); int sqSocketSendDataBufCount(SocketPtr s, int buf, int bufSize); int sqSocketSendDone(SocketPtr s); /* profiling */ int clearProfile(void); int dumpProfile(void); int startProfiling(void); int stopProfiling(void); /* system attributes */ int attributeSize(int id); int getAttributeIntoLength(int id, int byteArrayIndex, int length); /* miscellaneous primitives */ int primBitmapcompresstoByteArray(void); int primBitmapdecompressfromByteArrayat(void); int primSampledSoundconvert8bitSignedFromto16Bit(void); int primStringcomparewithcollated(void); int primStringfindFirstInStringinSetstartingAt(void); int primStringfindSubstringinstartingAtmatchTable(void); int primStringindexOfAsciiinStringstartingAt(void); int primStringtranslatefromtotable(void); /* serial port primitives */ int serialPortClose(int portNum); int serialPortOpen( int portNum, int baudRate, int stopBitsType, int parityType, int dataBits, int inFlowCtrl, int outFlowCtrl, int xOnChar, int xOffChar); int serialPortReadInto(int portNum, int count, int bufferPtr); int serialPortWriteFrom(int portNum, int count, int bufferPtr); /* MIDI primitives */ int sqMIDIGetClock(void); int sqMIDIGetPortCount(void); int sqMIDIGetPortDirectionality(int portNum); int sqMIDIGetPortName(int portNum, int namePtr, int length); int sqMIDIClosePort(int portNum); int sqMIDIOpenPort(int portNum, int readSemaIndex, int interfaceClockRate); int sqMIDIParameter(int whichParameter, int modify, int newValue); int sqMIDIPortReadInto(int portNum, int count, int bufferPtr); int sqMIDIPortWriteFromAt(int portNum, int count, int bufferPtr, int time); /*** Experimental Asynchronous File I/O ***/ typedef struct { int sessionID; void *state; } AsyncFile; int asyncFileClose(AsyncFile *f); int asyncFileOpen(AsyncFile *f, int fileNamePtr, int fileNameSize, int writeFlag, int semaIndex); int asyncFileRecordSize(); int asyncFileReadResult(AsyncFile *f, int bufferPtr, int bufferSize); int asyncFileReadStart(AsyncFile *f, int fPosition, int count); int asyncFileWriteResult(AsyncFile *f); int asyncFileWriteStart(AsyncFile *f, int fPosition, int bufferPtr, int bufferSize); /*** pluggable primitive support ***/ int ioLoadExternalFunctionOfLengthFromModuleOfLength( int functionNameIndex, int functionNameLength, int moduleNameIndex, int moduleNameLength); '. ! ! !InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 12/22/2003 14:14'! msqMainFile ^ '/* sqMacMicro.c This file includes fairly minimal support code to build a Macintosh virtual machine. File and directory primitives can be "stubbed-out", meaning that if they are invoked from the image they will return a "primitive failed" error. One purpose of this file is to provide an implementation roadmap when bootstrapping Squeak on a new platform. Once all the non-stubbed-out functions in this file have been implemented, you will have a working, usable Squeak virtual machine!! *** Implementation Notes *** File Naming The virtual machine keeps track of the full path name of the Squeak image file and the path to the directory containing the virtual machine. In this minimal implementation, the VM path is the empty string and the image name is hardwired to "msqueak.image". It is assumed that the image file, the changes file, the Squeak application, and the system sources file are all in the the same directory, and that that directory is the default working directory for file operations. The "shortImageName" is used to display the image file name (but not its full path) in the title bar of the Macintosh window. I/O Functions The following I/O functions are essential for graphical display and user interaction: ioScreenSize() ioShowDisplay() ioGetButtonState() ioGetKeystroke() ioMousePoint() ioPeekKeystroke() The following can be made no-ops: ioProcessEvents() -- poll for input events on some platforms ioSetCursor() -- install a 16x16 black and white hardware cursor ioSetCursorWithMask() -- install a masked cursor ioBeep() -- make a short beep through the speaker ioExit() -- exit the VM: quit the application, reboot, power down, or -- some other behavior appropriate to this platform -- (if this is a noop you won''t be able to quit from Squeak) ioRelinquishProcessorForMicroseconds() -- called when Squeak is idle to return time to the OS Time Functions ioMSecs(), ioMicroMSecs() -- both return a millisecond clock value, but historically -- ioMicroMSecs() used a higher resolution timer; the -- ideal implementation is an inexpensive clock with 1 -- millisecond accuracy, but both functions can use a -- clock with much coarser accuracy (e.g., 50-100 mSecs) -- if necessary ioSeconds() -- return the number of seconds since Jan 1, 1901 -- may return 0, but then the current date and time -- will be wrong *** Linking *** To build a Macintosh VM using this file, link together: interp.c -- automatically generated interpreter file sqDirPrims.c -- directory primitives (can be stubbed out) sqFilePrims.c -- file primitives (can be stubbed out) sqMacMicro.c -- this file sqMiscPrims.c -- automatically generated primitives (optional) plus the appropriate support libraries. For example, to build the PowerPC virtual machine using CodeWarrior 11, use these libraries: MathLib MSL C.PPC.Lib MWCRuntime.Lib InterfaceLib */ /*** Configuration Settings *** * * Define HEADLESS to stub out display, mouse, and keyboard primitives. * Define NO_FILE_PRIMS to stub out support for the file primitives. * Define NO_DIR_PRIMS to stub out support for the directory primitives. */ #define HEADLESS // #define NO_FILE_PRIMS // #define NO_DIR_PRIMS /*** End of Configuration Settings */ #include <MacHeaders.h> #include <Dialogs.h> #include <Devices.h> #include <Files.h> #include <Fonts.h> #include <Strings.h> #include <Timer.h> #include <ToolUtils.h> #include "sq.h" #define STUBBED_OUT { success(false); } /*** Variables -- Imported from Virtual Machine ***/ extern int fullScreenFlag; extern int interruptCheckCounter; extern int interruptKeycode; extern int interruptPending; /* set to true by recordKeystroke if interrupt key is pressed */ extern unsigned char *memory; extern int savedWindowSize; /* set from header when image file is loaded */ /*** Variables -- image and path names ***/ #define IMAGE_NAME_SIZE 300 char imageName[IMAGE_NAME_SIZE + 1]; /* full path to image */ #define SHORTIMAGE_NAME_SIZE 100 char shortImageName[SHORTIMAGE_NAME_SIZE + 1]; /* just the image file name */ #define VMPATH_SIZE 300 char vmPath[VMPATH_SIZE + 1]; /* full path to interpreter''s directory */ /*********** Headless I/O Operations (stubs) ***********/ #ifdef HEADLESS #define SetWindowTitle(s) /* noop */ void InitMacintosh(void); void InitMacintosh() { MaxApplZone(); } int ioSetFullScreen(int fullScreen) {/* noop */} int ioGetButtonState(void) {return 0;} int ioGetKeystroke(void) {return getchar();} int ioMousePoint(void) {return 0;} int ioPeekKeystroke(void) {return 0;} int ioProcessEvents(void) {/* noop */} int ioPutChar(int ch) {putchar(ch);} int ioRelinquishProcessorForMicroseconds(int microSeconds) {/* noop */} int ioScreenSize(void) {return (10 << 16) | 10;} int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY) {/* noop */} int ioSetCursorWithMask( int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY) {/* noop */} int ioShowDisplay( int dispBitsIndex, int width, int height, int depth, int affectedL, int affectedR, int affectedT, int affectedB) {/* noop */} #else // not headless /*********** Macintosh Window I/O Operations ***********/ /*** Enumerations ***/ enum { appleID = 1, fileID, editID }; enum { quitItem = 1 }; /*** Variables -- Mac Related ***/ MenuHandle appleMenu = nil; MenuHandle editMenu = nil; MenuHandle fileMenu = nil; CTabHandle stColorTable = nil; PixMapHandle stPixMap = nil; WindowPtr stWindow = nil; /*** Variables -- Event Recording ***/ #define KEYBUF_SIZE 64 int keyBuf[KEYBUF_SIZE]; /* circular buffer */ int keyBufGet = 0; /* index of next item of keyBuf to read */ int keyBufPut = 0; /* index of next item of keyBuf to write */ int keyBufOverflows = 0; /* number of characters dropped */ int buttonState = 0; /* mouse button and modifier state when mouse button went down or 0 if not pressed */ Point savedMousePosition; /* mouse position when window is inactive */ int windowActive = true; /* true if the Squeak window is the active window */ /* This table maps the 5 Macintosh modifier key bits to 4 Squeak modifier bits. (The Mac shift and caps lock keys are both mapped to the single Squeak shift bit). Mac bits: <control><option><caps lock><shift><command> ST bits: <command><option><control><shift> */ char modifierMap[32] = { 0, 8, 1, 9, 1, 9, 1, 9, 4, 12, 5, 13, 5, 13, 5, 13, 2, 10, 3, 11, 3, 11, 3, 11, 6, 14, 7, 15, 7, 15, 7, 15 }; /*** Functions ***/ void AdjustMenus(void); int HandleEvents(void); void HandleMenu(int mSelect); void HandleMouseDown(EventRecord *theEvent); void InitMacintosh(void); void SetColorEntry(int index, int red, int green, int blue); void SetUpMenus(void); void SetUpPixmap(void); void SetUpWindow(void); void SetWindowTitle(char *title); /* event capture */ int recordKeystroke(EventRecord *theEvent); int recordModifierButtons(EventRecord *theEvent); int recordMouseDown(EventRecord *theEvent); /*** Mac-related Functions ***/ void AdjustMenus(void) { WindowPeek wp; int isDeskAccessory; wp = (WindowPeek) FrontWindow(); if (wp !!= NULL) { isDeskAccessory = (wp->windowKind < 0); } else { isDeskAccessory = false; } if (isDeskAccessory) { /* Enable items in the Edit menu */ EnableItem(editMenu, 1); EnableItem(editMenu, 3); EnableItem(editMenu, 4); EnableItem(editMenu, 5); EnableItem(editMenu, 6); } else { /* Disable items in the Edit menu */ DisableItem(editMenu, 1); DisableItem(editMenu, 3); DisableItem(editMenu, 4); DisableItem(editMenu, 5); DisableItem(editMenu, 6); } } int HandleEvents(void) { EventRecord theEvent; int ok; SystemTask(); ok = GetNextEvent(everyEvent, &theEvent); if (ok) { switch (theEvent.what) { case mouseDown: HandleMouseDown(&theEvent); return false; break; case mouseUp: recordModifierButtons(&theEvent); return false; break; case keyDown: case autoKey: if ((theEvent.modifiers & cmdKey) !!= 0) { AdjustMenus(); HandleMenu(MenuKey(theEvent.message & charCodeMask)); } recordModifierButtons(&theEvent); recordKeystroke(&theEvent); break; case updateEvt: BeginUpdate(stWindow); fullDisplayUpdate(); /* this makes VM call ioShowDisplay */ EndUpdate(stWindow); break; case activateEvt: if (theEvent.modifiers & activeFlag) { windowActive = true; } else { GetMouse(&savedMousePosition); windowActive = false; } InvalRect(&stWindow->portRect); break; } } return ok; } void HandleMenu(int mSelect) { int menuID, menuItem; Str255 name; GrafPtr savePort; menuID = HiWord(mSelect); menuItem = LoWord(mSelect); switch (menuID) { case appleID: GetPort(&savePort); GetMenuItemText(appleMenu, menuItem, name); OpenDeskAcc(name); SetPort(savePort); break; case fileID: if (menuItem == quitItem) { ioExit(); } break; case editID: if (!!SystemEdit(menuItem - 1)) { SysBeep(5); } break; } } void HandleMouseDown(EventRecord *theEvent) { WindowPtr theWindow; Rect growLimits = { 20, 20, 4000, 4000 }; Rect dragBounds; int windowCode, newSize; windowCode = FindWindow(theEvent->where, &theWindow); switch (windowCode) { case inSysWindow: SystemClick(theEvent, theWindow); break; case inMenuBar: AdjustMenus(); HandleMenu(MenuSelect(theEvent->where)); break; case inDrag: dragBounds = qd.screenBits.bounds; if (theWindow == stWindow) { DragWindow(stWindow, theEvent->where, &dragBounds); } break; case inGrow: if (theWindow == stWindow) { newSize = GrowWindow(stWindow, theEvent->where, &growLimits); if (newSize !!= 0) { SizeWindow(stWindow, LoWord(newSize), HiWord(newSize), true); } } break; case inContent: if (theWindow == stWindow) { if (theWindow !!= FrontWindow()) { SelectWindow(stWindow); } recordMouseDown(theEvent); } break; case inGoAway: if ((theWindow == stWindow) && (TrackGoAway(stWindow, theEvent->where))) { /* HideWindow(stWindow); noop for now */ } break; } } void InitMacintosh(void) { MaxApplZone(); InitGraf(&qd.thePort); InitFonts(); FlushEvents(everyEvent, 0); InitWindows(); InitMenus(); TEInit(); InitDialogs(NULL); InitCursor(); SetUpMenus(); SetUpWindow(); SetUpPixmap(); } void SetUpMenus(void) { InsertMenu(appleMenu = NewMenu(appleID, "\p\024"), 0); InsertMenu(fileMenu = NewMenu(fileID, "\pFile"), 0); InsertMenu(editMenu = NewMenu(editID, "\pEdit"), 0); DrawMenuBar(); AppendResMenu(appleMenu, ''DRVR''); AppendMenu(fileMenu, "\pQuit"); AppendMenu(editMenu, "\pUndo/Z;(-;Cut/X;Copy/C;Paste/V;Clear"); } void SetColorEntry(int index, int red, int green, int blue) { (*stColorTable)->ctTable[index].value = index; (*stColorTable)->ctTable[index].rgb.red = red; (*stColorTable)->ctTable[index].rgb.green = green; (*stColorTable)->ctTable[index].rgb.blue = blue; } void SetUpPixmap(void) { int i, r, g, b; stColorTable = (CTabHandle) NewHandle(sizeof(ColorTable) + (256 * sizeof(ColorSpec))); (*stColorTable)->ctSeed = GetCTSeed(); (*stColorTable)->ctFlags = 0; (*stColorTable)->ctSize = 255; /* 1-bit colors (monochrome) */ SetColorEntry(0, 65535, 65535, 65535); /* white or transparent */ SetColorEntry(1, 0, 0, 0); /* black */ /* additional colors for 2-bit color */ SetColorEntry(2, 65535, 65535, 65535); /* opaque white */ SetColorEntry(3, 32768, 32768, 32768); /* 1/2 gray */ /* additional colors for 4-bit color */ SetColorEntry( 4, 65535, 0, 0); /* red */ SetColorEntry( 5, 0, 65535, 0); /* green */ SetColorEntry( 6, 0, 0, 65535); /* blue */ SetColorEntry( 7, 0, 65535, 65535); /* cyan */ SetColorEntry( 8, 65535, 65535, 0); /* yellow */ SetColorEntry( 9, 65535, 0, 65535); /* magenta */ SetColorEntry(10, 8192, 8192, 8192); /* 1/8 gray */ SetColorEntry(11, 16384, 16384, 16384); /* 2/8 gray */ SetColorEntry(12, 24576, 24576, 24576); /* 3/8 gray */ SetColorEntry(13, 40959, 40959, 40959); /* 5/8 gray */ SetColorEntry(14, 49151, 49151, 49151); /* 6/8 gray */ SetColorEntry(15, 57343, 57343, 57343); /* 7/8 gray */ /* additional colors for 8-bit color */ /* 24 more shades of gray (does not repeat 1/8th increments) */ SetColorEntry(16, 2048, 2048, 2048); /* 1/32 gray */ SetColorEntry(17, 4096, 4096, 4096); /* 2/32 gray */ SetColorEntry(18, 6144, 6144, 6144); /* 3/32 gray */ SetColorEntry(19, 10240, 10240, 10240); /* 5/32 gray */ SetColorEntry(20, 12288, 12288, 12288); /* 6/32 gray */ SetColorEntry(21, 14336, 14336, 14336); /* 7/32 gray */ SetColorEntry(22, 18432, 18432, 18432); /* 9/32 gray */ SetColorEntry(23, 20480, 20480, 20480); /* 10/32 gray */ SetColorEntry(24, 22528, 22528, 22528); /* 11/32 gray */ SetColorEntry(25, 26624, 26624, 26624); /* 13/32 gray */ SetColorEntry(26, 28672, 28672, 28672); /* 14/32 gray */ SetColorEntry(27, 30720, 30720, 30720); /* 15/32 gray */ SetColorEntry(28, 34815, 34815, 34815); /* 17/32 gray */ SetColorEntry(29, 36863, 36863, 36863); /* 18/32 gray */ SetColorEntry(30, 38911, 38911, 38911); /* 19/32 gray */ SetColorEntry(31, 43007, 43007, 43007); /* 21/32 gray */ SetColorEntry(32, 45055, 45055, 45055); /* 22/32 gray */ SetColorEntry(33, 47103, 47103, 47103); /* 23/32 gray */ SetColorEntry(34, 51199, 51199, 51199); /* 25/32 gray */ SetColorEntry(35, 53247, 53247, 53247); /* 26/32 gray */ SetColorEntry(36, 55295, 55295, 55295); /* 27/32 gray */ SetColorEntry(37, 59391, 59391, 59391); /* 29/32 gray */ SetColorEntry(38, 61439, 61439, 61439); /* 30/32 gray */ SetColorEntry(39, 63487, 63487, 63487); /* 31/32 gray */ /* The remainder of color table defines a color cube with six steps for each primary color. Note that the corners of this cube repeat previous colors, but simplifies the mapping between RGB colors and color map indices. This color cube spans indices 40 through 255. */ for (r = 0; r < 6; r++) { for (g = 0; g < 6; g++) { for (b = 0; b < 6; b++) { i = 40 + ((36 * r) + (6 * b) + g); if (i > 255) error("index out of range in color table compuation"); SetColorEntry(i, (r * 65535) / 5, (g * 65535) / 5, (b * 65535) / 5); } } } stPixMap = NewPixMap(); (*stPixMap)->pixelType = 0; /* chunky */ (*stPixMap)->cmpCount = 1; (*stPixMap)->pmTable = stColorTable; } void SetUpWindow(void) { Rect windowBounds = {44, 8, 300, 500}; stWindow = NewCWindow( 0L, &windowBounds, "\p Welcome to Squeak!! Reading Squeak image file... ", true, documentProc, (WindowPtr) -1L, true, 0); } void SetWindowTitle(char *title) { SetWTitle(stWindow, c2pstr(title)); p2cstr((unsigned char *) title); } /*** Event Recording Functions ***/ int recordKeystroke(EventRecord *theEvent) { int keystate; /* keystate: low byte is the ascii character; next 4 bits are modifier bits */ keystate = (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 8) | (theEvent->message & 0xFF); if (keystate == interruptKeycode) { /* Note: interrupt key is "meta"; it not reported as a keystroke */ interruptPending = true; interruptCheckCounter = 0; } else { keyBuf[keyBufPut] = keystate; keyBufPut = (keyBufPut + 1) % KEYBUF_SIZE; if (keyBufGet == keyBufPut) { /* buffer overflow; drop the last character */ keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE; keyBufOverflows++; } } } int recordMouseDown(EventRecord *theEvent) { int stButtons; stButtons = 4; /* red button by default */ if ((theEvent->modifiers & optionKey) !!= 0) { stButtons = 2; /* yellow button if option down */ } if ((theEvent->modifiers & cmdKey) !!= 0) { stButtons = 1; /* blue button if command down */ } /* button state: low three bits are mouse buttons; next 4 bits are modifier bits */ buttonState = (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) | (stButtons & 0x7); } int recordModifierButtons(EventRecord *theEvent) { int stButtons = 0; if (Button()) { stButtons = buttonState & 0x7; } else { stButtons = 0; } /* button state: low three bits are mouse buttons; next 4 bits are modifier bits */ buttonState = (modifierMap[(theEvent->modifiers >> 8) & 0x1F] << 3) | (stButtons & 0x7); } /*** I/O Primitives ***/ int ioGetButtonState(void) { ioProcessEvents(); /* process all pending events */ return buttonState; } int ioGetKeystroke(void) { int keystate; ioProcessEvents(); /* process all pending events */ if (keyBufGet == keyBufPut) { return -1; /* keystroke buffer is empty */ } else { keystate = keyBuf[keyBufGet]; keyBufGet = (keyBufGet + 1) % KEYBUF_SIZE; /* set modifer bits in buttonState to reflect the last keystroke fetched */ buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7); } return keystate; } int ioMousePoint(void) { Point p; ioProcessEvents(); /* process all pending events */ if (windowActive) { GetMouse(&p); } else { /* don''t report mouse motion if window is not active */ p = savedMousePosition; } return (p.h << 16) | (p.v & 0xFFFF); /* x is high 16 bits; y is low 16 bits */ } int ioPeekKeystroke(void) { int keystate; ioProcessEvents(); /* process all pending events */ if (keyBufGet == keyBufPut) { return -1; /* keystroke buffer is empty */ } else { keystate = keyBuf[keyBufGet]; /* set modifer bits in buttonState to reflect the last keystroke peeked at */ buttonState = ((keystate >> 5) & 0xF8) | (buttonState & 0x7); } return keystate; } int ioProcessEvents(void) { /* Process Macintosh events, checking for the interrupt key. Return true if the interrupt key was pressed. */ int maxPollsPerSec = 30; static clock_t nextPollTick = 0; if (clock() > nextPollTick) { /* time to process events!! */ while (HandleEvents()) { /* process all pending events */ } /* wait a while before trying again */ nextPollTick = clock() + (CLOCKS_PER_SEC / maxPollsPerSec); } return interruptPending; } int ioPutChar(int ch) { putchar(ch); } int ioRelinquishProcessorForMicroseconds(int microSeconds) { /* This operation is platform dependent. On the Mac, it simply calls * HandleEvents(), which gives other applications a chance to run. */ while (HandleEvents()) { /* process all pending events */ } return microSeconds; } int ioScreenSize(void) { int w = 10, h = 10; if (stWindow !!= nil) { w = stWindow->portRect.right - stWindow->portRect.left; h = stWindow->portRect.bottom - stWindow->portRect.top; } return (w << 16) | (h & 0xFFFF); /* w is high 16 bits; h is low 16 bits */ } int ioSetCursor(int cursorBitsIndex, int offsetX, int offsetY) { /* Old version; forward to new version. */ ioSetCursorWithMask(cursorBitsIndex, nil, offsetX, offsetY); } int ioSetCursorWithMask(int cursorBitsIndex, int cursorMaskIndex, int offsetX, int offsetY) { /* Set the 16x16 cursor bitmap. If cursorMaskIndex is nil, then make the mask the same as the cursor bitmap. If not, then mask and cursor bits combined determine how cursor is displayed: mask cursor effect 0 0 transparent (underlying pixel shows through) 1 1 opaque black 1 0 opaque white 0 1 invert the underlying pixel */ Cursor macCursor; int i; if (cursorMaskIndex == nil) { for (i = 0; i < 16; i++) { macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF; macCursor.mask[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF; } } else { for (i = 0; i < 16; i++) { macCursor.data[i] = (checkedLongAt(cursorBitsIndex + (4 * i)) >> 16) & 0xFFFF; macCursor.mask[i] = (checkedLongAt(cursorMaskIndex + (4 * i)) >> 16) & 0xFFFF; } } /* Squeak hotspot offsets are negative; Mac''s are positive */ macCursor.hotSpot.h = -offsetX; macCursor.hotSpot.v = -offsetY; SetCursor(&macCursor); } int ioSetFullScreen(int fullScreen) { Rect screen = qd.screenBits.bounds; int width, height, maxWidth, maxHeight; int oldWidth, oldHeight; if (fullScreen) { oldWidth = stWindow->portRect.right - stWindow->portRect.left; oldHeight = stWindow->portRect.bottom - stWindow->portRect.top; width = screen.right - screen.left; height = (screen.bottom - screen.top) - 20; if ((oldWidth < width) || (oldHeight < height)) { /* save old size if it wasn''t already full-screen */ savedWindowSize = (oldWidth << 16) + (oldHeight & 0xFFFF); } MoveWindow(stWindow, 0, 20, true); SizeWindow(stWindow, width, height, true); fullScreenFlag = true; } else { /* get old window size */ width = (unsigned) savedWindowSize >> 16; height = savedWindowSize & 0xFFFF; /* minimum size is 64 x 64 */ width = (width > 64) ? width : 64; height = (height > 64) ? height : 64; /* maximum size is screen size inset slightly */ maxWidth = (screen.right - screen.left) - 16; maxHeight = (screen.bottom - screen.top) - 52; width = (width <= maxWidth) ? width : maxWidth; height = (height <= maxHeight) ? height : maxHeight; MoveWindow(stWindow, 8, 44, true); SizeWindow(stWindow, width, height, true); fullScreenFlag = false; } } int ioShowDisplay( int dispBitsIndex, int width, int height, int depth, int affectedL, int affectedR, int affectedT, int affectedB) { Rect dstRect = { 0, 0, 0, 0 }; Rect srcRect = { 0, 0, 0, 0 }; RgnHandle maskRect = nil; if (stWindow == nil) { return; } dstRect.left = 0; dstRect.top = 0; dstRect.right = width; dstRect.bottom = height; srcRect.left = 0; srcRect.top = 0; srcRect.right = width; srcRect.bottom = height; (*stPixMap)->baseAddr = (void *) dispBitsIndex; /* Note: top three bits of rowBytes indicate this is a PixMap, not a BitMap */ (*stPixMap)->rowBytes = (((((width * depth) + 31) / 32) * 4) & 0x1FFF) | 0x8000; (*stPixMap)->bounds = srcRect; (*stPixMap)->pixelSize = depth; (*stPixMap)->cmpSize = depth; /* create a mask region so that only the affected rectangle is copied */ maskRect = NewRgn(); SetRectRgn(maskRect, affectedL, affectedT, affectedR, affectedB); SetPort(stWindow); CopyBits((BitMap *) *stPixMap, &stWindow->portBits, &srcRect, &dstRect, srcCopy, maskRect); DisposeRgn(maskRect); } #endif HEADLESS /*** Timing Primitives ***/ int ioMicroMSecs(void) { /* millisecond clock based on microsecond timer (about 60 times slower than clock()!!!!) */ /* Note: This function and ioMSecs() both return a time in milliseconds. The difference is that ioMicroMSecs() is called only when precise millisecond resolution is essential, and thus it can use a more expensive timer than ioMSecs, which is called frequently. However, later VM optimizations reduced the frequency of calls to ioMSecs to the point where clock performance became less critical, and we also started to want millisecond- resolution timers for real time applications such as music. Thus, on the Mac, we''ve opted to use the microsecond clock for both ioMSecs() and ioMicroMSecs(). */ UnsignedWide microTicks; Microseconds(µTicks); return (microTicks.lo / 1000) + (microTicks.hi * 4294967); } int ioMSecs(void) { /* return a time in milliseconds for use in Delays and Time millisecondClockValue */ /* Note: This was once a macro based on clock(); it now uses the microsecond clock for greater resolution. See the comment in ioMicroMSecs(). */ UnsignedWide microTicks; Microseconds(µTicks); return (microTicks.lo / 1000) + (microTicks.hi * 4294967); } int ioSeconds(void) { struct tm timeRec; time_t time1904, timeNow; /* start of ANSI epoch is midnight of Jan 1, 1904 */ timeRec.tm_sec = 0; timeRec.tm_min = 0; timeRec.tm_hour = 0; timeRec.tm_mday = 1; timeRec.tm_mon = 0; timeRec.tm_year = 4; timeRec.tm_wday = 0; timeRec.tm_yday = 0; timeRec.tm_isdst = 0; time1904 = mktime(&timeRec); timeNow = time(NULL); /* Squeak epoch is Jan 1, 1901, 3 non-leap years earlier than ANSI one */ return (timeNow - time1904) + (3 * 365 * 24 * 60 * 60); } /*** VM Home Directory Path ***/ int vmPathSize(void) { return strlen(vmPath); } int vmPathGetLength(int sqVMPathIndex, int length) { char *stVMPath = (char *) sqVMPathIndex; int count, i; count = strlen(vmPath); count = (length < count) ? length : count; /* copy the file name into the Squeak string */ for (i = 0; i < count; i++) { stVMPath[i] = vmPath[i]; } return count; } /*** Image File Naming ***/ int imageNameSize(void) { return strlen(imageName); } int imageNameGetLength(int sqImageNameIndex, int length) { char *sqImageName = (char *) sqImageNameIndex; int count, i; count = strlen(imageName); count = (length < count) ? length : count; /* copy the file name into the Squeak string */ for (i = 0; i < count; i++) { sqImageName[i] = imageName[i]; } return count; } int imageNamePutLength(int sqImageNameIndex, int length) { char *sqImageName = (char *) sqImageNameIndex; int count, i, ch, j; int lastColonIndex = -1; count = (IMAGE_NAME_SIZE < length) ? IMAGE_NAME_SIZE : length; /* copy the file name into a null-terminated C string */ for (i = 0; i < count; i++) { ch = imageName[i] = sqImageName[i]; if (ch == '':'') { lastColonIndex = i; } } imageName[count] = 0; /* copy short image name into a null-terminated C string */ for (i = lastColonIndex + 1, j = 0; i < count; i++, j++) { shortImageName[j] = imageName[i]; } shortImageName[j] = 0; SetWindowTitle(shortImageName); return count; } /*** System Attributes ***/ char * GetAttributeString(int id); char * GetAttributeString(int id) { /* This is a hook for getting various status strings back from the OS. In particular, it allows Squeak to be passed arguments such as the name of a file to be processed. Command line options are reported this way as well, on platforms that support them. */ // id #0 should return the full name of VM; for now it just returns its path if (id == 0) return vmPath; // id #1 should return imageName, but returns empty string in this release to // ease the transition (1.3x images otherwise try to read image as a document) if (id == 1) return ""; /* will be imageName */ if (id == 2) return ""; if (id == 1001) return "Mac OS"; if (id == 1002) return "System 7 or Later"; if (id == 1003) return "PowerPC or 680xx"; /* attribute undefined by this platform */ success(false); return ""; } int attributeSize(int id) { return strlen(GetAttributeString(id)); } int getAttributeIntoLength(int id, int byteArrayIndex, int length) { char *srcPtr, *dstPtr, *end; int charsToMove; srcPtr = GetAttributeString(id); charsToMove = strlen(srcPtr); if (charsToMove > length) { charsToMove = length; } dstPtr = (char *) byteArrayIndex; end = srcPtr + charsToMove; while (srcPtr < end) { *dstPtr++ = *srcPtr++; } return charsToMove; } /*** Clipboard Support ***/ int clipboardReadIntoAt(int count, int byteArrayIndex, int startIndex) { return 0; } int clipboardSize(void) { return 0; } int clipboardWriteFromAt(int count, int byteArrayIndex, int startIndex) { return 0; } /*** Misc Primitives ***/ int ioBeep(void) { SysBeep(1000); } int ioExit(void) { ExitToShell(); } int ioForceDisplayUpdate(void) { /* do nothing on a Mac */ } int ioFormPrint(int bitsAddr, int width, int height, int depth, double hScale, double vScale, int landscapeFlag) { /* experimental: print a form with the given bitmap, width, height, and depth at the given horizontal and vertical scales in the given orientation */ success(false); /* stubbed out */ } /*** Image File Operations ***/ void sqImageFileClose(sqImageFile f) { FSClose(f); } sqImageFile sqImageFileOpen(char *fileName, char *mode) { short int err, err2, fRefNum; unsigned char *pascalFileName; pascalFileName = c2pstr(fileName); err = FSOpen(pascalFileName, 0, &fRefNum); if ((err !!= 0) && (strchr(mode, ''w'') !!= null)) { /* creating a new file for "save as" */ err2 = Create(pascalFileName, 0, ''FAST'', ''STim''); if (err2 == 0) { err = FSOpen(pascalFileName, 0, &fRefNum); } } p2cstr(pascalFileName); if (err !!= 0) return null; if (strchr(mode, ''w'') !!= null) { /* truncate file if opening in write mode */ err = SetEOF(fRefNum, 0); if (err !!= 0) { FSClose(fRefNum); return null; } } return (sqImageFile) fRefNum; } int sqImageFilePosition(sqImageFile f) { long int currentPosition = 0; GetFPos(f, ¤tPosition); return currentPosition; } int sqImageFileRead(void *ptr, int elementSize, int count, sqImageFile f) { long int byteCount = elementSize * count; short int err; err = FSRead(f, &byteCount, ptr); if (err !!= 0) return 0; return byteCount / elementSize; } void sqImageFileSeek(sqImageFile f, int pos) { SetFPos(f, fsFromStart, pos); } int sqImageFileWrite(void *ptr, int elementSize, int count, sqImageFile f) { long int byteCount = elementSize * count; short int err; err = FSWrite(f, &byteCount, ptr); if (err !!= 0) return 0; return byteCount / elementSize; } /*** File Prim Stubs ***/ #ifdef NO_FILE_PRIMS int sqFileAtEnd(SQFile *f) STUBBED_OUT int sqFileClose(SQFile *f) STUBBED_OUT int sqFileDeleteNameSize(int sqFileNameIndex, int sqFileNameSize) STUBBED_OUT int sqFileGetPosition(SQFile *f) STUBBED_OUT int sqFileInit(void) {/* noop */} int sqFileOpen( SQFile *f, int sqFileNameIndex, int sqFileNameSize, int writeFlag) STUBBED_OUT int sqFileReadIntoAt( SQFile *f, int count, int byteArrayIndex, int startIndex) STUBBED_OUT int sqFileRenameOldSizeNewSize( int oldNameIndex, int oldNameSize, int newNameIndex, int newNameSize) STUBBED_OUT int sqFileSetPosition(SQFile *f, int position) STUBBED_OUT int sqFileSize(SQFile *f) STUBBED_OUT int sqFileValid(SQFile *f) {return 0; } int sqFileWriteFromAt( SQFile *f, int count, int byteArrayIndex, int startIndex) STUBBED_OUT #endif /*** Directory Prim Stubs ***/ #ifdef NO_DIR_PRIMS int dir_Create(char *pathString, int pathStringLength) STUBBED_OUT int dir_Delimitor(void) {return '':'';} int dir_Lookup(char *pathString, int pathStringLength, int index, char *name, int *nameLength, int *creationDate, int *modificationDate, int *isDirectory, int *sizeIfFile) STUBBED_OUT int dir_SetMacFileTypeAndCreator(char *filename, int filenameSize, char *fType, char *fCreator) {/* noop */} #endif /*** Main ***/ void main(void) { sqImageFile f; int reservedMemory, availableMemory; /* check the interpreter''s size assumptions for basic data types */ if (sizeof(int) !!= 4) { error("This C compiler''s integers are not 32 bits."); } if (sizeof(double) !!= 8) { error("This C compiler''s floats are not 64 bits."); } if (sizeof(time_t) !!= 4) { error("This C compiler''s time_t''s are not 32 bits."); } InitMacintosh(); sqFileInit(); imageName[0] = shortImageName[0] = vmPath[0] = 0; strcpy(imageName, "msqueak.image"); strcpy(shortImageName, "msqueak.image"); /* compute the desired memory allocation */ reservedMemory = 150000; availableMemory = MaxBlock() - reservedMemory; /****** Note: This is platform-specific. On the Mac, the user specifies the desired memory partition for each application using the Finder''s Get Info command. MaxBlock() returns the amount of memory in the partition minus space for the code segment and other resources. On other platforms, the desired heap size would be specified in other ways (e.g, via a command line argument). The maximum size of the object heap is fixed at at startup. If you run low on space, you must save the image and restart with more memory. Note: Some memory must be reserved for Mac toolbox calls, sound buffers, etc. A 30K reserve is too little. 40K allows Squeal to run but crashes if the console is opened. 50K allows the console to be opened (with and w/o the profiler). I added another 30K to provide for sound buffers and reliability. (Note: Later discovered that sound output failed if SoundManager was not preloaded unless there is about 100K reserved. Added 30K to that.) ******/ /* uncomment the following to open the C transcript window for debugging: */ //printf("Move this window, then hit CR\n"); getchar(); /* read the image file and allocate memory for Squeak heap */ f = sqImageFileOpen(imageName, "rb"); if (f == NULL) { /* give a Mac-specific error message if image file is not found */ printf("Could not open the Squeak image file ''%s''\n\n", imageName); printf("In this minimal VM, the image file must be named ''msqueak.image''\n"); printf("and must be in the same directory as the Squeak application.\n"); printf("Press the return key to exit.\n"); getchar(); printf("Aborting...\n"); ioExit(); } readImageFromFileHeapSize(f, availableMemory); sqImageFileClose(f); SetWindowTitle(shortImageName); ioSetFullScreen(fullScreenFlag); /* run Squeak */ interpret(); } '! ! !InterpreterSupportCode class methodsFor: 'source files' stamp: 'jm 12/22/2003 14:22'! readmeFile ^ 'Building the Squeak Virtual Machine The Macintosh virtual machine is built from the following files: sq.h -- shared definitions included in all .c files sqFilePrims.c -- file primitives, implemented using ANSI C File I/O (stdio.h) sqMacMicro.c -- Mac window and event handling; main program sqMiscPrims.c -- automatically generated code for a few miscellaneous primitives interp.c -- automatically generated code for the virtual machine The platform specific files are sqMacXXX.c, totaling about 1600 lines of code when this document was written. All other code is written to standard ANSI libraries and should port easily to other C environments. The file sqMacMicro.c can be used a porting guide. This ~1100 line file stubs out all non-essential support functions and allows one to build a functioning virtual machine that has only the essential I/O functions. The small size of this file shows how little code is really needed to get Squeak running on a new platform. Thanks to Ian Piumarta, the C header files are identical across all the major Squeak platforms. The code assumes that C ints and pointers are 4 bytes and double floats are 8 bytes; these assumptions are checked at start up time. Float objects in the image are stored in the IEEE standard byte ordering for double-precision floats on all platforms; macros in sq.h can be defined to swap bytes into and out of the platform native float format if necessary. (To ensure proper word alignment, one typically has to copy a Squeak Float object into a C "double" variable before operating on it; byte swapping can be done while doing this copy for little or no additional cost.) The files interp.c and sqMiscPrims.c are generated automatically. To generate the interp.c, see the "translation" category in Interpreter class. This set of file has been compiled for Power PC using Metrowerks CodeWarrior and the following libraries: InterfaceLib MathLib MSL C.PPC.Lib MWCRuntime.Lib To get an additional speedup, the object code for the bytecode dispatch loop of the PPC version can be patched using the method "patchInterp:" in Interpreter class. Note: We include a CodeWarrior project file for release 11 of CodeWarrior. If you have a current version of CodeWarrior, you may be able to automatically convert these project files to your release. If you have a release of CodeWarrior earlier than release 11 (which is ancient), you may need to either build new project files from scratch. -- John Maloney, Jan 12, 1999 (Updated Nov 16, 2003) '. ! ! I represent a finite arithmetic progression.! !Interval methodsFor: 'accessing' stamp: 'rpj 11/30/1999 11:04'! includes: aNumber "Determine if aNumber is an element of this interval." ^ (self rangeIncludes: aNumber) and: [ self valuesInclude: aNumber ]! ! !Interval methodsFor: 'accessing' stamp: 'di 12/6/1999 11:00'! rangeIncludes: aNumber "Return true if the number lies in the interval between start and stop." step >= 0 ifTrue: [^ aNumber between: start and: stop] ifFalse: [^ aNumber between: stop and: start] ! ! !Interval methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:38'! size "Answer how many elements the receiver contains." step < 0 ifTrue: [start < stop ifTrue: [^ 0] ifFalse: [^ stop - start // step + 1]] ifFalse: [stop < start ifTrue: [^ 0] ifFalse: [^ stop - start // step + 1]]! ! !Interval methodsFor: 'copying' stamp: 'sma 3/3/2000 13:18'! shallowCopy "Without this method, #copy would return an array instead of a new interval. The whole problem is burried in the class hierarchy and every fix will worsen the problem, so once the whole issue is resolved one should come back to this method fix it." ^ self class from: start to: stop by: step! ! !Interval methodsFor: 'printing' stamp: 'sma 6/1/2000 09:50'! printOn: aStream aStream nextPut: $(; print: start; nextPutAll: ' to: '; print: stop. step ~= 1 ifTrue: [aStream nextPutAll: ' by: '; print: step]. aStream nextPut: $)! ! !Interval methodsFor: 'private' stamp: 'di 4/24/2000 13:56'! valuesInclude: aNumber "Private - answer whether or not aNumber is one of the enumerated values in this interval." | val | val _ (aNumber - self first) asFloat / self increment. ^ val fractionPart abs < (step * 1.0e-10)! ! I am a virtual joystick that can report values in either Cartesian or Polar coordinates. ! !JoystickMorph methodsFor: 'other' stamp: 'sw 5/11/1998 13:51'! handlesMouseDown: evt self inPartsBin ifTrue: [^ false]. true ifTrue: [^ true]. "5/7/98 jhm temporary fix to allow use when rotated" (handleMorph fullContainsPoint: evt cursorPoint) ifTrue: [^ true] ifFalse: [^ super handlesMouseDown: evt]. ! ! !JoystickMorph methodsFor: 'stepping' stamp: 'sw 8/13/1999 14:03'! step "Track the real joystick whose index is realJoystickIndex." "Details: a. if realJoystickIndex is nil we're not tracking a joystick b. [-joyMax..joyMax] is nominal range of joystick in both X and Y c. [-threshold..threshold] is considered 0 to compensate for poor joystick centering" | threshold joyMax joyPt m mCenter r scaledPt | super step. "Run ticking user-written scripts if any" realJoystickIndex ifNil: [^ self]. threshold _ 30. joyMax _ 350. joyPt _ Sensor joystickXY: realJoystickIndex. joyPt x abs < threshold ifTrue: [joyPt _ 0@joyPt y]. joyPt y abs < threshold ifTrue: [joyPt _ joyPt x@0]. lastRealJoystickValue = joyPt ifTrue: [^ self]. lastRealJoystickValue _ joyPt. m _ handleMorph. mCenter _ m center. r _ m owner innerBounds insetBy: ((mCenter - m fullBounds origin) corner: (m fullBounds corner - mCenter)). scaledPt _ r center + ((r extent * joyPt) / (joyMax * 2)) truncated. m position: (scaledPt adhereTo: r) - (m extent // 2). ! ! !JoystickMorph methodsFor: 'stepping' stamp: 'sw 8/13/1999 14:00'! stepTime ^ realJoystickIndex ifNil: [0] "fast as we can to track actual joystick" ifNotNil: [super stepTime] ! ! !JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:19'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'set X range' action: #setXRange. aCustomMenu add: 'set Y range' action: #setYRange. autoCenter ifTrue: [aCustomMenu add: 'turn auto-center off' action: #toggleAutoCenter] ifFalse: [aCustomMenu add: 'turn auto-center on' action: #toggleAutoCenter]. realJoystickIndex ifNil: [aCustomMenu add: 'track real joystick' action: #trackRealJoystick] ifNotNil: [aCustomMenu add: 'stop tracking joystick' action: #stopTrackingJoystick]. ! ! !JoystickMorph methodsFor: 'menu' stamp: 'jm 6/22/1998 17:24'! stopTrackingJoystick realJoystickIndex _ nil. self stopStepping. ! ! !JoystickMorph methodsFor: 'menu' stamp: 'jm 10/14/2002 19:04'! trackRealJoystick | s | s _ FillInTheBlank request: 'Number of joystick to track?' initialAnswer: '1'. s isEmpty ifTrue: [^ self]. realJoystickIndex _ Number readFrom: (ReadStream on: s). self startStepping. ! ! !JoystickMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:02'! includeInNewMorphMenu ^ true ! ! I am used by TextMorph to simulate an InputSensor when interfacing to an old MVC ParagraphEditor. ! !KeyboardBuffer methodsFor: 'as yet unclassified' stamp: 'di 4/27/1999 21:49'! keyboardPressed | evt | eventUsed ifFalse: [^ true]. (evt _ event hand checkForMoreKeyboard) ifNil: [^ false]. event _ evt. eventUsed _ false. ^ true! ! This class adds state and controls to the basic PianoKeyboardMorph so that notes of reliable duration can be keyed into a score without the need for a real keyboard. To try this out, execute... | n score | n _ 3. score _ (MIDIScore new tracks: ((1 to: n) collect: [:i | Array new]); trackInfo: ((1 to: n) collect: [:i | 'Instrument' , i printString]); tempoMap: nil; ticksPerQuarterNote: 96). ScorePlayerMorph openOn: score title: 'empty score' Then open a pianoRoll and, from that, open a keyboard. The rule is that the keyboard will append after the current selection. If the current selection is muted or nil, then input will go to the end of the first non-muted track.! !KeyboardMorphForInput methodsFor: 'initialization' stamp: 'di 6/20/1999 12:57'! addRecordingControls | button switch playRow durRow articRow modRow | button _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2; color: color. switch _ SimpleSwitchMorph new target: self; offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; setSwitchState: false. "Add chord, rest and delete buttons" playRow _ AlignmentMorph newRow. playRow color: color; borderWidth: 0; inset: 0. playRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. playRow addMorphBack: (switch fullCopy label: 'chord'; actionSelector: #buildChord:). playRow addMorphBack: (button fullCopy label: ' rest '; actionSelector: #emitRest). playRow addMorphBack: (button fullCopy label: 'del'; actionSelector: #deleteNotes). self addMorph: playRow. playRow align: playRow bounds topCenter with: self bounds bottomCenter. "Add note duration buttons" durRow _ AlignmentMorph newRow. durRow color: color; borderWidth: 0; inset: 0. durRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. durRow addMorphBack: (switch fullCopy label: 'whole'; actionSelector: #duration:onOff:; arguments: #(1)). durRow addMorphBack: (switch fullCopy label: 'half'; actionSelector: #duration:onOff:; arguments: #(2)). durRow addMorphBack: (switch fullCopy label: 'quarter'; actionSelector: #duration:onOff:; arguments: #(4)). durRow addMorphBack: (switch fullCopy label: 'eighth'; actionSelector: #duration:onOff:; arguments: #(8)). durRow addMorphBack: (switch fullCopy label: 'sixteenth'; actionSelector: #duration:onOff:; arguments: #(16)). self addMorph: durRow. durRow align: durRow bounds topCenter with: playRow bounds bottomCenter. "Add note duration modifier buttons" modRow _ AlignmentMorph newRow. modRow color: color; borderWidth: 0; inset: 0. modRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. modRow addMorphBack: (switch fullCopy label: 'dotted'; actionSelector: #durMod:onOff:; arguments: #(dotted)). modRow addMorphBack: (switch fullCopy label: 'normal'; actionSelector: #durMod:onOff:; arguments: #(normal)). modRow addMorphBack: (switch fullCopy label: 'triplets'; actionSelector: #durMod:onOff:; arguments: #(triplets)). modRow addMorphBack: (switch fullCopy label: 'quints'; actionSelector: #durMod:onOff:; arguments: #(quints)). self addMorph: modRow. modRow align: modRow bounds topCenter with: durRow bounds bottomCenter. "Add articulation buttons" articRow _ AlignmentMorph newRow. articRow color: color; borderWidth: 0; inset: 0. articRow hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. articRow addMorphBack: (switch fullCopy label: 'legato'; actionSelector: #articulation:onOff:; arguments: #(legato)). articRow addMorphBack: (switch fullCopy label: 'normal'; actionSelector: #articulation:onOff:; arguments: #(normal)). articRow addMorphBack: (switch fullCopy label: 'staccato'; actionSelector: #articulation:onOff:; arguments: #(staccato)). self addMorph: articRow. articRow align: articRow bounds topCenter with: modRow bounds bottomCenter. self bounds: (self fullBounds expandBy: (0@0 extent: 0@borderWidth)) ! ! !KeyboardMorphForInput methodsFor: 'initialization' stamp: 'jm 10/31/2002 08:18'! initialize super initialize. buildingChord _ false. self addRecordingControls. self duration: 4 onOff: true. self durMod: #normal onOff: true. self articulation: #normal onOff: true. ! ! !KeyboardMorphForInput methodsFor: 'initialization' stamp: 'di 6/18/1999 15:52'! pianoRoll: prMorph pianoRoll _ prMorph! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/19/1999 23:37'! articulation: artic onOff: ignored "artic = eg, #legato, #normal, #staccato." "Set the articulation of notes to be emitted when a key is pressed." self allMorphsDo: [:m | ((m isMemberOf: SimpleSwitchMorph) and: [m actionSelector == #articulation:onOff:]) ifTrue: [m setSwitchState: m arguments first == artic]]. articulation _ artic! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/18/1999 15:50'! buildChord: onOff! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:20'! deleteNotes pianoRoll deleteSelection! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 12:55'! durMod: durMod onOff: ignored "durMod = eg, #dotted, #normal, #triplets, #quints" "Set the duration of notes to be emitted when a key is pressed." self allMorphsDo: [:m | ((m isMemberOf: SimpleSwitchMorph) and: [m actionSelector == #durMod:onOff:]) ifTrue: [m setSwitchState: m arguments first = durMod]]. durationModifier _ durMod! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 18:31'! duration: denom onOff: ignored "denom = eg, 1, 2, 4, 8, 16" "Set the duration of notes to be emitted when a key is pressed." self allMorphsDo: [:m | ((m isMemberOf: SimpleSwitchMorph) and: [m actionSelector == #duration:onOff:]) ifTrue: [m setSwitchState: m arguments first = denom]]. duration _ denom. self durMod: #normal onOff: true! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'jm 10/31/2002 08:17'! emitRest "Note: All this selection logic should be shared with turnOnNote:..." | sel noteEvent | (sel _ pianoRoll selection) ifNil: [^ self]. sel = prevSelection ifFalse: ["This is a new selection -- need to determine start time" sel third = 0 ifTrue: [startOfNextNote _ 0] ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first) at: sel third) endTime. startOfNextNote _ startOfNextNote + self fullDuration - 1 truncateTo: self fullDuration]]. noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration; key: -1 "my flag for rest" velocity: self velocity channel: 1. pianoRoll appendEvent: noteEvent fullDuration: self fullDuration. soundPlaying ifNotNil: [soundPlaying stopGracefully]. prevSelection _ pianoRoll selection. startOfNextNote _ startOfNextNote + self fullDuration.! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 13:03'! fullDuration | num denom | num _ denom _ 1. durationModifier == #dotted ifTrue: [num _ 3. denom _ 2]. durationModifier == #triplets ifTrue: [num _ 2. denom _ 3]. durationModifier == #quints ifTrue: [num _ 2. denom _ 5]. ^ pianoRoll score ticksPerQuarterNote * 4 * num // duration // denom! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/20/1999 00:27'! noteDuration articulation == #staccato ifTrue: [^ (self fullDuration * 0.65) asInteger]. articulation == #normal ifTrue: [^ (self fullDuration * 0.8) asInteger]. articulation == #legato ifTrue: [^ (self fullDuration * 0.95) asInteger]. ! ! !KeyboardMorphForInput methodsFor: 'note controls' stamp: 'di 6/19/1999 23:13'! velocity ^ 80 "Later put a slider on the keyboard control"! ! !KeyboardMorphForInput methodsFor: 'events' stamp: 'di 6/20/1999 15:53'! soundForEvent: noteEvent inTrack: trackIndex | sound player | player _ pianoRoll scorePlayer. sound _ MixedSound new. sound add: ((player instrumentForTrack: trackIndex) soundForMidiKey: noteEvent midiKey dur: noteEvent duration / (pianoRoll scorePlayer ticksForMSecs: 1000) loudness: (noteEvent velocity asFloat / 127.0)) pan: (player panForTrack: trackIndex) volume: player overallVolume * (player volumeForTrack: trackIndex). ^ sound ! ! !KeyboardMorphForInput methodsFor: 'events' stamp: 'jm 10/31/2002 08:17'! turnOnNote: midiKey | sel noteEvent | (sel _ pianoRoll selection) ifNil: [^ self]. sel = prevSelection ifFalse: ["This is a new selection -- need to determine start time" sel third = 0 ifTrue: [startOfNextNote _ 0] ifFalse: [startOfNextNote _ ((pianoRoll score tracks at: sel first) at: sel third) endTime. startOfNextNote _ startOfNextNote + self fullDuration - 1 truncateTo: self fullDuration]]. noteEvent _ NoteEvent new time: startOfNextNote; duration: self noteDuration; key: midiKey velocity: self velocity channel: 1. pianoRoll appendEvent: noteEvent fullDuration: self fullDuration. soundPlaying ifNotNil: [soundPlaying stopGracefully]. (soundPlaying _ self soundForEvent: noteEvent inTrack: sel first) play. prevSelection _ pianoRoll selection. startOfNextNote _ startOfNextNote + self fullDuration.! ! Just like LargePositiveInteger, but represents a negative number.! !LargeNegativeInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:10'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self shouldNotImplement! ! !LargeNegativeInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:10'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen minVal | <primitive: 'primNormalizeNegative' module:'LargeIntegers'> "First establish len = significant length" len _ oldLen _ self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len _ len - 1]. "Now check if in SmallInteger range" sLen _ 4 "SmallInteger minVal digitLength". len <= sLen ifTrue: [minVal _ SmallInteger minVal. (len < sLen or: [(self digitAt: sLen) < minVal lastDigit]) ifTrue: ["If high digit less, then can be small" val _ 0. len to: 1 by: -1 do: [:i | val _ (val *256) - (self digitAt: i)]. ^ val]. 1 to: sLen do: "If all digits same, then = minVal" [:i | (self digitAt: i) = (minVal digitAt: i) ifFalse: ["Not so; return self shortened" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]]]. ^ minVal]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! I represent positive integers of more than 30 bits (ie, >= 1073741824). These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize). Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! !LargePositiveInteger methodsFor: 'arithmetic' stamp: 'RAA 5/31/2000 13:21'! \\\ anInteger "a faster modulo method for use in DSA. Be careful if you try to use this elsewhere" ^(self digitDiv: anInteger neg: false) second! ! !LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:11'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." ^ self highBitOfMagnitude! ! !LargePositiveInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:15'! highBitOfMagnitude "Answer the index of the high order bit of the magnitude of the receiver, or zero if the receiver is zero. This method is used for LargeNegativeIntegers as well, since Squeak's LargeIntegers are sign/magnitude." | realLength lastDigit | realLength _ self digitLength. [(lastDigit _ self digitAt: realLength) = 0] whileTrue: [(realLength _ realLength - 1) = 0 ifTrue: [^ 0]]. ^ lastDigit highBitOfPositiveReceiver + (8 * (realLength - 1))! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ar 5/17/2000 16:09'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen | <primitive: 'primNormalizePositive' module:'LargeIntegers'> "First establish len = significant length" len _ oldLen _ self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len _ len - 1]. "Now check if in SmallInteger range" sLen _ SmallInteger maxVal digitLength. (len <= sLen and: [(self digitAt: sLen) <= (SmallInteger maxVal digitAt: sLen)]) ifTrue: ["If so, return its SmallInt value" val _ 0. len to: 1 by: -1 do: [:i | val _ (val *256) + (self digitAt: i)]. ^ val]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! !LargePositiveInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'! digitAt: index "Primitive. Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." <primitive: 60> self digitLength < index ifTrue: [^0] ifFalse: [^super at: index]! ! !LargePositiveInteger class methodsFor: 'testing' stamp: 'sr 6/10/2000 18:24'! testTwoComplementRightShift "self testTwoComplementRightShift" | large small | small _ 2 << 16. large _ 2 << 32. "2-complement test" (small negated bitShift: -1) ~= ((small + 1) negated bitShift: -1) == ((large negated bitShift: -1) ~= ((large + 1) negated bitShift: -1)) ifFalse: [^ self inform: 'ERROR: Two-complement shifts of negative Integers are NOT consistent!!']. (small bitShift: -1) ~= (small + 1 bitShift: -1) == ((large bitShift: -1) ~= (large + 1 bitShift: -1)) ifFalse: [^ self inform: 'ERROR: Two-complement shifts of negative Integers are NOT consistent!!']. ^ self inform: 'OK: Two-complement shifts of negative Integers are consistent!!'.! ! I represent a leaf node of the compiler parse tree. I am abstract. Types (defined in class ParseNode): 1 LdInstType (which uses class VariableNode) 2 LdTempType (which uses class VariableNode) 3 LdLitType (which uses class LiteralNode) 4 LdLitIndType (which uses class VariableNode) 5 SendType (which uses class SelectorNode). Note that Squeak departs slightly from the Blue Book bytecode spec. In order to allow access to more than 63 literals and instance variables, bytecode 132 has been redefined as DoubleExtendedDoAnything: byte2 byte3 Operation (hi 3 bits) (lo 5 bits) 0 nargs lit index Send Literal Message 0-255 1 nargs lit index Super-Send Lit Msg 0-255 2 ignored rcvr index Push Receiver Variable 0-255 3 ignored lit index Push Literal Constant 0-255 4 ignored lit index Push Literal Variable 0-255 5 ignored rcvr index Store Receiver Variable 0-255 6 ignored rcvr index Store-pop Receiver Variable 0-255 7 ignored lit index Store Literal Variable 0-255 This has allowed bytecode 134 also to be redefined as a second extended send that can access literals up to 64 for nargs up to 3 without needing three bytes. It is just like 131, except that the extension byte is aallllll instead of aaalllll, where aaa are bits of argument count, and lll are bits of literal index.! A LimitedWriteStream is a specialized WriteStream that has a maximum size of the collection it streams over. When this limit is reached a special limitBlock is executed. This can for example be used to "bail out" of lengthy streaming operations before they have finished. For a simple example take a look at the universal Object printString. The message SequenceableCollection class streamContents:limitedTo: creates a LimitedWriteStream. In this case it prevents very large (or possibly recursive) object structures to "overdo" their textual representation. ! ]style[(323 18 15 54 151)f1,f1LObject printString;,f1,f1LSequenceableCollection class streamContents:limitedTo:;,f1! An instance of me is a simple record of a pointer to another Link. I am an abstract class; my concrete subclasses, for example, Process, can be stored in a LinkedList structure.! I represent a collection of links, which are containers for other objects. Using the message sequence addFirst:/removeLast causes the receiver to behave as a stack; using addLast:/removeFirst causes the receiver to behave as a queue.! An instance of me holds a list of methods (or class comment, class defintion, class hierarchy). When a user clicks on a HyperText link, the place referred to is displayed in me. The non-method contents are not meant to be edited and accepted. To create a link to a class comment: In any piece of text, type the name of a class. Select it. Command-6. Choose 'go to comment of class' Then a user can click on that text later and she will be transported to the class's comment. To create a link to a method, class definition, or class hierarchy: Do the same as above, but choose the appropriate menu item. ! !LinkedMessageSet methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 18:15'! selectedMessage "Answer the source method for the currently selected message. Allow class comment, definition, and hierarchy." | source | self setClassAndSelectorIn: [:class :selector | selector first isUppercase ifFalse: [source _ class sourceMethodAt: selector. currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil].. ^ source asText makeSelectorBoldIn: self selectedClassOrMetaClass]. selector = #Comment ifTrue: [^ class comment]. selector = #Definition ifTrue: [^ class definition]. selector = #Hierarchy ifTrue: [^ class printHierarchy]. source _ class sourceMethodAt: selector. currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil]. Preferences browseWithPrettyPrint ifTrue: [source _ class compilerClass new format: source in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. ^ source asText makeSelectorBoldIn: self selectedClassOrMetaClass]! ! I am a kind of ScrollController that assumes that the view is a kind of ListView. Therefore, scrolling means moving the items in a textual list (menu) up or down. In addition, I provide the red button activity of determining when the red button is selecting an item in the list.! !ListController methodsFor: 'control defaults' stamp: 'bf 4/14/1999 12:41'! controlActivity self scrollByKeyboard ifTrue: [^self]. self processKeyboard. super controlActivity. ! ! !ListController methodsFor: 'menu messages' stamp: 'acg 9/18/1999 14:09'! processKeyboard "Derived from a Martin Pammer submission, 02/98" | keyEvent oldSelection nextSelection max min howMany | sensor keyboardPressed ifFalse: [^ self]. keyEvent := sensor keyboard asciiValue. oldSelection := view selection. nextSelection := oldSelection. max := view maximumSelection. min := view minimumSelection. howMany := view clippingBox height // view list lineGrid. keyEvent == 31 ifTrue: ["down-arrow; move down one, wrapping to top if needed" nextSelection := oldSelection + 1. nextSelection > max ifTrue: [nextSelection _ 1]]. keyEvent == 30 ifTrue: ["up arrow; move up one, wrapping to bottom if needed" nextSelection := oldSelection - 1. nextSelection < 1 ifTrue: [nextSelection _ max]]. keyEvent == 1 ifTrue: [nextSelection := 1]. "home" keyEvent == 4 ifTrue: [nextSelection := max]. "end" keyEvent == 11 ifTrue: [nextSelection := min max: (oldSelection - howMany)]. "page up" keyEvent == 12 ifTrue: [nextSelection := (oldSelection + howMany) min: max]. "page down" nextSelection = oldSelection ifFalse: [model okToChange ifTrue: [self changeModelSelection: nextSelection. self moveMarker]] ! ! I represent a special type of Paragraph that is used in the list panes of a browser. I avoid all the composition done by more general Paragraphs, because I know the structure of my Text.! !ListParagraph class methodsFor: 'instance creation' stamp: 'jm 9/20/1998 17:10'! withArray: anArray style: aTextStyleOrNil "Convert an array of strings into a ListParagraph using the given TextStyle." aTextStyleOrNil ifNil: [^ (super withText: Text new style: ListStyle) withArray: anArray] ifNotNil: [^ (super withText: Text new style: aTextStyleOrNil) withArray: anArray]. ! ! !ListParagraph class methodsFor: 'initialization' stamp: 'sw 12/10/1999 10:37'! initialize "ListParagraph initialize" | aFont | "Allow different line spacing for lists" aFont _ Preferences standardListFont. ListStyle _ aFont textStyle copy consistOnlyOf: aFont. ListStyle gridForFont: 1 withLead: 1! ! !ListParagraph class methodsFor: 'style' stamp: 'sw 12/10/1999 10:43'! standardListStyle ^ ListStyle! ! I am an abstract View of a list of items. I provide support for storing a selection of one item, as well as formatting the list for presentation on the screen. My instances' default controller is ListController.! !ListView methodsFor: 'font access' stamp: 'sw 12/9/1999 18:07'! font ^ self assuredTextStyle fontNamed: textStyle fontNames first ! ! !ListView methodsFor: 'font access' stamp: 'jm 9/20/1998 19:44'! font: aFontOrNil aFontOrNil ifNil: [textStyle _ nil] ifNotNil: [ textStyle _ TextStyle fontArray: (Array with: aFontOrNil). textStyle gridForFont: 1 withLead: 1]. self changed: #list. "update display" ! ! !ListView methodsFor: 'list access' stamp: 'sw 12/10/1999 10:43'! assuredTextStyle ^ textStyle ifNil: [textStyle _ ListParagraph standardListStyle] ! ! !ListView methodsFor: 'list access' stamp: 'sw 12/9/1999 18:06'! list: anArray "Set the list of items the receiver displays to be anArray." | arrayCopy i | isEmpty _ anArray isEmpty. arrayCopy _ Array new: (anArray size + 2). arrayCopy at: 1 put: topDelimiter. arrayCopy at: arrayCopy size put: bottomDelimiter. i _ 2. anArray do: [:el | arrayCopy at: i put: el. i _ i+1]. arrayCopy _ arrayCopy copyWithout: nil. list _ ListParagraph withArray: arrayCopy style: self assuredTextStyle. selection _ 0. self positionList. ! ! !ListView methodsFor: 'display box access' stamp: 'mkd 11/4/1999 14:31'! isSelectionBoxClipped "Answer whether there is a selection and whether the selection is visible on the screen." ^ selection ~= 0 and: [(self selectionBox intersects: (self clippingBox insetBy: (Rectangle left: 0 right: 0 top: 1 bottom: 0))) not]! ! A LiteralDictionary, like an IdentityDictionary, has a special test for equality. In this case it is simple equality between objects of like class. This allows equal Float or String literals to be shared without the possibility of erroneously sharing, say, 1 and 1.0! I am a parse tree leaf representing a literal string or number.! !LiteralNode methodsFor: 'printing' stamp: 'sw 11/16/1999 16:42'! printOn: aStream indent: level (key isMemberOf: Association) ifTrue: [key key isNil ifTrue: [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] ifFalse: [aStream nextPutAll: '##'; nextPutAll: key key]] ifFalse: [aStream withAttributes: (Preferences syntaxAttributesFor: #literal) do: [key storeOn: aStream]]! ! !LiteralNode methodsFor: 'evaluation' stamp: 'tk 8/4/1999 17:35'! eval "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" ^ key! ! !LiteralNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:52'! asTranslatorNode ^ TConstantNode new setValue: key ! ! I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.! I respresent a sequence of sound samples, often used to record a single note played by a real instrument. I can be pitch-shifted up or down, and can include a looped portion to allow a sound to be sustained indefinitely. ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 10/14/1998 16:04'! addReleaseEnvelope "Add a simple release envelope to this sound." | p env | p _ OrderedCollection new. p add: 0@1.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. env _ (VolumeEnvelope points: p loopStart: 2 loopEnd: 3) target: self. envelopes size > 0 ifTrue: [ "remove any existing volume envelopes" envelopes copy do: [:e | (e isKindOf: VolumeEnvelope) ifTrue: [self removeEnvelope: e]]]. self addEnvelope: env. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 11:48'! computeSampleCountForRelease "Calculate the number of samples before the end of the note after which looping back will be be disabled. The units of this value, sampleCountForRelease, are samples at the original sampling rate. When playing a specific note, this value is converted to releaseCount, which is number of samples to be computed at the current pitch and sampling rate." "Details: For short loops, set the sampleCountForRelease to the loop length plus the number of samples between loopEnd and lastSample. Otherwise, set it to 1/10th of a second worth of samples plus the number of samples between loopEnd and lastSample. In this case, the trailing samples will be played only if the last loop-back occurs within 1/10th of a second of the total note duration, and the note may be shortened by up to 1/10th second. For long loops, this is the best we can do." (scaledLoopLength > 0 and: [lastSample > loopEnd]) ifTrue: [ sampleCountForRelease _ (lastSample - loopEnd) + (self loopLength min: (originalSamplingRate / 10.0)) asInteger] ifFalse: [sampleCountForRelease _ 0]. releaseCount _ sampleCountForRelease. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 5/5/1999 20:59'! fromAIFFFileNamed: fileName mergeIfStereo: mergeFlag "Initialize this sound from the data in the given AIFF file. If mergeFlag is true and the file is stereo, its left and right channels are mixed together to produce a mono sampled sound." | aiffFileReader | aiffFileReader _ AIFFFileReader new. aiffFileReader readFromFile: fileName mergeIfStereo: mergeFlag skipDataChunk: false. aiffFileReader isLooped ifTrue: [ self samples: aiffFileReader leftSamples loopEnd: aiffFileReader loopEnd loopLength: aiffFileReader loopLength pitch: aiffFileReader pitch samplingRate: aiffFileReader samplingRate] ifFalse: [ self unloopedSamples: aiffFileReader leftSamples pitch: aiffFileReader pitch samplingRate: aiffFileReader samplingRate]. "the following must be done second, since the initialization above sets leftSamples and rightSamples to the same sample data" aiffFileReader isStereo ifTrue: [rightSamples _ aiffFileReader rightSamples]. initialCount _ (leftSamples size * self samplingRate) // originalSamplingRate. self loudness: 1.0. self addReleaseEnvelope. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 8/18/1998 07:43'! initialize "This default initialization creates a loop consisting of a single cycle of a sine wave." "(LoopedSampledSound pitch: 440.0 dur: 1.0 loudness: 0.4) play" | samples | super initialize. samples _ FMSound sineTable. self samples: samples loopEnd: samples size loopLength: samples size pitch: 1.0 samplingRate: samples size. self addReleaseEnvelope. self setPitch: 440.0 dur: 1.0 loudness: 0.5. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'! samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz "Make this sound use the given samples array with a loop of the given length starting at the given index. The loop length may have a fractional part; this is necessary to achieve pitch accuracy for short loops." | loopStartIndex | super initialize. loopStartIndex _ (loopEndIndex - loopSampleCount) truncated + 1. ((1 <= loopStartIndex) and: [loopStartIndex < loopEndIndex and: [loopEndIndex <= aSoundBuffer size]]) ifFalse: [self error: 'bad loop parameters']. leftSamples _ rightSamples _ aSoundBuffer. originalSamplingRate _ samplingRateInHz asFloat. perceivedPitch _ perceivedPitchInHz asFloat. gain _ 1.0. firstSample _ 1. lastSample _ leftSamples size. lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [ self error: 'cannot handle more than ', (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples']. loopEnd _ loopEndIndex. scaledLoopLength _ (loopSampleCount * LoopIndexScaleFactor) asInteger. scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate. self computeSampleCountForRelease. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'! setPitch: pitchNameOrNumber dur: d loudness: vol "(LoopedSampledSound pitch: 440.0 dur: 2.5 loudness: 0.4) play" super setPitch: pitchNameOrNumber dur: d loudness: vol. self pitch: (self nameOrNumberToPitch: pitchNameOrNumber). self reset. ! ! !LoopedSampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 22:28'! unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz "Make this sound play the given samples unlooped. The samples have the given perceived pitch when played at the given sampling rate. By convention, unpitched sounds such as percussion sounds should specify a pitch of nil or 100 Hz." super initialize. leftSamples _ rightSamples _ aSoundBuffer. originalSamplingRate _ samplingRateInHz asFloat. perceivedPitchInHz ifNil: [perceivedPitch _ 100.0] ifNotNil: [perceivedPitch _ perceivedPitchInHz asFloat]. gain _ 1.0. firstSample _ 1. lastSample _ leftSamples size. lastSample >= (SmallInteger maxVal // LoopIndexScaleFactor) ifTrue: [ self error: 'cannot handle more than ', (SmallInteger maxVal // LoopIndexScaleFactor) printString, ' samples']. loopEnd _ leftSamples size. scaledLoopLength _ 0. "zero length means unlooped" scaledIndexIncr _ (samplingRateInHz * LoopIndexScaleFactor) // self samplingRate. self computeSampleCountForRelease. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 5/31/1999 14:09'! beUnlooped scaledLoopLength _ 0. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'! duration "Answer the duration of this sound in seconds." ^ initialCount asFloat / self samplingRate asFloat ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:36'! duration: seconds super duration: seconds. count _ initialCount _ (seconds * self samplingRate) rounded. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'! firstSample ^ firstSample ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:25'! firstSample: aNumber firstSample _ (aNumber asInteger max: 1) min: lastSample. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'! gain ^ gain ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/3/1998 18:52'! gain: aNumber gain _ aNumber asFloat. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 07:26'! isLooped ^ scaledLoopLength ~= 0. "zero loop length means unlooped" ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:14'! isStereo ^ leftSamples ~~ rightSamples ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! leftSamples ^ leftSamples ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! leftSamples: aSampleBuffer leftSamples _ aSampleBuffer. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:35'! loopEnd ^ loopEnd ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:12'! loopLength ^ scaledLoopLength / FloatLoopIndexScaleFactor ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 10/14/1998 16:26'! originalSamplingRate ^ originalSamplingRate ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 2/2/1999 09:54'! perceivedPitch ^ perceivedPitch ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 09:08'! pitch ^ (scaledIndexIncr asFloat * perceivedPitch * self samplingRate asFloat) / (originalSamplingRate * FloatLoopIndexScaleFactor) ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 8/18/1998 11:38'! pitch: p scaledIndexIncr _ ((p asFloat * originalSamplingRate * FloatLoopIndexScaleFactor) / (perceivedPitch * self samplingRate asFloat)) asInteger. sampleCountForRelease > 0 ifTrue: [releaseCount _ (sampleCountForRelease * LoopIndexScaleFactor) // scaledIndexIncr] ifFalse: [releaseCount _ 0]. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! rightSamples ^ rightSamples ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 7/13/1998 11:46'! rightSamples: aSampleBuffer rightSamples _ aSampleBuffer. ! ! !LoopedSampledSound methodsFor: 'accessing' stamp: 'jm 3/15/1999 08:01'! samples "For compatability with SampledSound. Just return my left channel (which is the only channel if I am mono)." ^ leftSamples ! ! !LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/19/1998 10:43'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol "Play samples from a wave table by stepping a fixed amount through the table on every sample. The table index and increment are scaled to allow fractional increments for greater pitch accuracy. If a loop length is specified, then the index is looped back when the loopEnd index is reached until count drops below releaseCount. This allows a short sampled sound to be sustained indefinitely." "(LoopedSampledSound pitch: 440.0 dur: 5.0 loudness: 0.5) play" | lastIndex sampleIndex i s compositeLeftVol compositeRightVol nextSampleIndex m isInStereo rightVal leftVal | <primitive: 184> self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. self var: #leftSamples declareC: 'short int *leftSamples'. self var: #rightSamples declareC: 'short int *rightSamples'. isInStereo _ leftSamples ~~ rightSamples. compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor. compositeRightVol _ (rightVol * scaledVol) // ScaleFactor. i _ (2 * startIndex) - 1. lastIndex _ (startIndex + n) - 1. startIndex to: lastIndex do: [:sliceIndex | sampleIndex _ (scaledIndex _ scaledIndex + scaledIndexIncr) // LoopIndexScaleFactor. ((sampleIndex > loopEnd) and: [count > releaseCount]) ifTrue: [ "loop back if not within releaseCount of the note end" "note: unlooped sounds will have loopEnd = lastSample" sampleIndex _ (scaledIndex _ scaledIndex - scaledLoopLength) // LoopIndexScaleFactor]. (nextSampleIndex _ sampleIndex + 1) > lastSample ifTrue: [ sampleIndex > lastSample ifTrue: [count _ 0. ^ nil]. "done!!" scaledLoopLength = 0 ifTrue: [nextSampleIndex _ sampleIndex] ifFalse: [nextSampleIndex _ ((scaledIndex - scaledLoopLength) // LoopIndexScaleFactor) + 1]]. m _ scaledIndex bitAnd: LoopIndexFractionMask. rightVal _ leftVal _ (((leftSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) + ((leftSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor. isInStereo ifTrue: [ rightVal _ (((rightSamples at: sampleIndex) * (LoopIndexScaleFactor - m)) + ((rightSamples at: nextSampleIndex) * m)) // LoopIndexScaleFactor]. leftVol > 0 ifTrue: [ s _ (aSoundBuffer at: i) + ((compositeLeftVol * leftVal) // ScaleFactor). s > 32767 ifTrue: [s _ 32767]. "clipping!!" s < -32767 ifTrue: [s _ -32767]. "clipping!!" aSoundBuffer at: i put: s]. i _ i + 1. rightVol > 0 ifTrue: [ s _ (aSoundBuffer at: i) + ((compositeRightVol * rightVal) // ScaleFactor). s > 32767 ifTrue: [s _ 32767]. "clipping!!" s < -32767 ifTrue: [s _ -32767]. "clipping!!" aSoundBuffer at: i put: s]. i _ i + 1. scaledVolIncr ~= 0 ifTrue: [ "update volume envelope if it is changing" scaledVol _ scaledVol + scaledVolIncr. ((scaledVolIncr > 0 and: [scaledVol >= scaledVolLimit]) or: [scaledVolIncr < 0 and: [scaledVol <= scaledVolLimit]]) ifTrue: [ "reached the limit; stop incrementing" scaledVol _ scaledVolLimit. scaledVolIncr _ 0]. compositeLeftVol _ (leftVol * scaledVol) // ScaleFactor. compositeRightVol _ (rightVol * scaledVol) // ScaleFactor]]. count _ count - n. ! ! !LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/17/1998 09:38'! reset super reset. count _ initialCount. scaledIndex _ firstSample * LoopIndexScaleFactor. ! ! !LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 8/18/1998 09:31'! samplesRemaining "Answer the number of samples remaining until the end of this sound." ^ count ! ! !LoopedSampledSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:57'! stopAfterMSecs: mSecs "Terminate this sound this note after the given number of milliseconds." count _ (mSecs * self samplingRate) // 1000. ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 08:19'! copyDownSampledLowPassFiltering: doFiltering "Answer a copy of the receiver at half its sampling rate. The result consumes half the memory space, but has only half the frequency range of the original. If doFiltering is true, the original sound buffers are low-pass filtered before down-sampling. This is slower, but prevents aliasing of any high-frequency components of the original signal. (While it may be possible to avoid low-pass filtering when down-sampling from 44.1 kHz to 22.05 kHz, it is probably essential when going to lower sampling rates.)" ^ self copy downSampleLowPassFiltering: doFiltering ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:30'! edit "Open a WaveEditor on this sound." | loopLen ed | loopLen _ scaledLoopLength asFloat / LoopIndexScaleFactor. ed _ WaveEditor new data: leftSamples; samplingRate: originalSamplingRate; loopEnd: loopEnd; loopLength: loopLen; loopCycles: (loopLen / (originalSamplingRate asFloat / perceivedPitch)) rounded. ed openInWorld. ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 07:49'! fftAt: startIndex "Answer the Fast Fourier Transform (FFT) of my samples (only the left channel, if stereo) starting at the given index." | availableSamples fftWinSize | availableSamples _ (leftSamples size - startIndex) + 1. fftWinSize _ 2 raisedTo: (((availableSamples - 1) log: 2) truncated + 1). fftWinSize _ fftWinSize min: 4096. fftWinSize > availableSamples ifTrue: [fftWinSize _ fftWinSize / 2]. ^ self fftWindowSize: fftWinSize startingAt: startIndex ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 5/29/1999 18:56'! findStartPointAfter: index "Answer the index of the last zero crossing sample before the given index." | i | i _ index min: lastSample. "scan backwards to the last zero-crossing" (leftSamples at: i) > 0 ifTrue: [ [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]] ifFalse: [ [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]]. ^ i ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:29'! findStartPointForThreshold: threshold "Answer the index of the last zero crossing sample before the first sample whose absolute value (in either the right or left channel) exceeds the given threshold." | i | i _ self indexOfFirstPointOverThreshold: threshold. i >= lastSample ifTrue: [^ self error: 'no sample exceeds the given threshold']. "scan backwards to the last zero-crossing" (leftSamples at: i) > 0 ifTrue: [ [i > 1 and: [(leftSamples at: i) > 0]] whileTrue: [i _ i - 1]] ifFalse: [ [i > 1 and: [(leftSamples at: i) < 0]] whileTrue: [i _ i - 1]]. ^ i ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/18/1998 09:26'! highestSignificantFrequencyAt: startIndex "Answer the highest significant frequency in the sample window starting at the given index. The a frequency is considered significant if it's power is at least 1/50th that of the maximum frequency component in the frequency spectrum." | fft powerArray threshold indices | fft _ self fftAt: startIndex. powerArray _ self normalizedResultsFromFFT: fft. threshold _ powerArray max / 50.0. indices _ (1 to: powerArray size) select: [:i | (powerArray at: i) > threshold]. ^ originalSamplingRate / (fft samplesPerCycleForIndex: indices last) ! ! !LoopedSampledSound methodsFor: 'other' stamp: 'jm 8/17/1998 09:22'! indexOfFirstPointOverThreshold: threshold "Answer the index of the first sample whose absolute value exceeds the given threshold." | s | leftSamples == rightSamples ifTrue: [ 1 to: lastSample do: [:i | s _ leftSamples at: i. s < 0 ifTrue: [s _ 0 - s]. s > threshold ifTrue: [^ i]]] ifFalse: [ 1 to: lastSample do: [:i | s _ leftSamples at: i. s < 0 ifTrue: [s _ 0 - s]. s > threshold ifTrue: [^ i]. s _ rightSamples at: i. s < 0 ifTrue: [s _ 0 - s]. s > threshold ifTrue: [^ i]]]. ^ lastSample + 1 ! ! !LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/18/1998 08:11'! downSampleLowPassFiltering: doFiltering "Cut my sampling rate in half. Use low-pass filtering (slower) if doFiltering is true." "Note: This operation loses information, and modifies the receiver in place." | stereo newLoopLength | stereo _ self isStereo. leftSamples _ leftSamples downSampledLowPassFiltering: doFiltering. stereo ifTrue: [rightSamples _ rightSamples downSampledLowPassFiltering: doFiltering] ifFalse: [rightSamples _ leftSamples]. originalSamplingRate _ originalSamplingRate / 2.0. loopEnd odd ifTrue: [newLoopLength _ (self loopLength / 2.0) + 0.5] ifFalse: [newLoopLength _ self loopLength / 2.0]. firstSample _ (firstSample + 1) // 2. lastSample _ (lastSample + 1) // 2. loopEnd _ (loopEnd + 1) // 2. scaledLoopLength _ (newLoopLength * LoopIndexScaleFactor) asInteger. scaledIndexIncr _ scaledIndexIncr // 2. ! ! !LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/18/1998 07:48'! fftWindowSize: windowSize startingAt: startIndex "Answer a Fast Fourier Transform (FFT) of the given number of samples starting at the given index (the left channel only, if stereo). The window size will be rounded up to the nearest power of two greater than the requested size. There must be enough samples past the given starting index to accomodate this window size." | nu n fft | nu _ ((windowSize - 1) log: 2) truncated + 1. n _ 2 raisedTo: nu. fft _ FFT new nu: nu. fft realData: ((startIndex to: startIndex + n - 1) collect: [:i | leftSamples at: i]). ^ fft transformForward: true. ! ! !LoopedSampledSound methodsFor: 'private' stamp: 'jm 8/16/1998 17:48'! normalizedResultsFromFFT: fft "Answer an array whose size is half of the FFT window size containing power in each frequency band, normalized to the average power over the entire FFT. A value of 10.0 in this array thus means that the power at the corresponding frequences is ten times the average power across the entire FFT." | r avg | r _ (1 to: fft realData size // 2) collect: [:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt]. avg _ r sum / r size. ^ r collect: [:v | v / avg]. ! ! !LoopedSampledSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 20:36'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." | reverseBytes | (self isStereo or: [self samplingRate ~= originalSamplingRate]) ifTrue: [ ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. "optimization: if I'm not stereo and sampling rates match, just store my buffer" reverseBytes _ bigEndianFlag ~= (Smalltalk endianness = #big). reverseBytes ifTrue: [leftSamples reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (leftSamples size // 2) putAll: leftSamples startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: leftSamples monoSampleCount do: [:i | aBinaryStream int16: (leftSamples at: i)]]. reverseBytes ifTrue: [leftSamples reverseEndianness]. "restore to original endianness" ! ! !LoopedSampledSound class methodsFor: 'class initialization' stamp: 'jm 8/13/1998 12:54'! initialize "LoopedSampledSound initialize" LoopIndexScaleFactor _ 512. FloatLoopIndexScaleFactor _ LoopIndexScaleFactor asFloat. LoopIndexFractionMask _ LoopIndexScaleFactor - 1. ! ! !LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:40'! samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz "See the comment in the instance method of this name." ^ self basicNew samples: aSoundBuffer loopEnd: loopEndIndex loopLength: loopSampleCount pitch: perceivedPitchInHz samplingRate: samplingRateInHz ! ! !LoopedSampledSound class methodsFor: 'instance creation' stamp: 'jm 8/18/1998 07:41'! unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz "See the comment in the instance method of this name." ^ self basicNew unloopedSamples: aSoundBuffer pitch: perceivedPitchInHz samplingRate: samplingRateInHz ! ! I represent an ArrayedCollection whose elements are objects. ! !MArray methodsFor: 'comparing'! hash "Make sure that equal (=) arrays hash equally." self size = 0 ifTrue: [^17171]. ^(self at: 1) hash + (self at: self size) hash! ! !MArray methodsFor: 'converting'! asArray "Answer with the receiver itself." ^self! ! !MArray methodsFor: 'converting' stamp: 'jm 10/27/2003 06:10'! elementsExchangeIdentityWith: otherArray "This primitive performs a bulk mutation, causing all pointers to the elements of this array to be replaced by pointers to the corresponding elements of otherArray. At the same time, all pointers to the elements of otherArray are replaced by pointers to the corresponding elements of this array." <primitive: 128> self primitiveFailed! ! !MArray methodsFor: 'printing' stamp: 'jm 11/14/2002 12:41'! printOn: aStream aStream nextPutAll: '#('. self do: [:each | each printOn: aStream. aStream space]. aStream nextPut: $). ! ! !MArray 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." <primitive: 105> super replaceFrom: start to: stop with: replacement startingAt: repStart! ! I am an abstract collection whose elements can be accessed using integer keys between 1 and my size. I also support sorting. ! !MArrayedCollection methodsFor: 'accessing' stamp: 'jm 10/26/2003 19:52'! 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 MSequenceableCollection size. Essential. See Object documentation whatIsAPrimitive. " <primitive: 62> ^ self basicSize ! ! !MArrayedCollection methodsFor: 'adding' stamp: 'jm 10/26/2003 19:52'! add: newObject self shouldNotImplement. ! ! !MArrayedCollection methodsFor: 'sorting' stamp: 'jm 9/17/2000 22:20'! mergeFirst: first middle: middle last: last into: dst by: aBlock "Private!! Merge the sorted ranges [first..middle] and [middle+1..last] of the receiver into the range [first..last] of dst." | i1 i2 val1 val2 out | i1 _ first. i2 _ middle + 1. val1 _ self at: i1. val2 _ self at: i2. out _ first - 1. "will be pre-incremented" "select 'lower' half of the elements based on comparator" [(i1 <= middle) and: [i2 <= last]] whileTrue: [ (aBlock value: val2 value: val1) ifTrue: [ dst at: (out _ out + 1) put: val2. i2 _ i2 + 1. i2 <= last ifTrue: [val2 _ self at: i2]] ifFalse: [ dst at: (out _ out + 1) put: val1. val1 _ self at: (i1 _ i1 + 1)]]. "copy the remaining elements" i1 <= middle ifTrue: [ dst replaceFrom: out + 1 to: last with: self startingAt: i1] ifFalse: [ dst replaceFrom: out + 1 to: last with: self startingAt: i2]. ! ! !MArrayedCollection methodsFor: 'sorting' stamp: 'jm 12/2/2003 22:12'! mergeSortFrom: startIndex to: stopIndex by: aBlock "Sort the given range of indices using the mergesort algorithm. Mergesort is a worst-case O(N log N) sorting algorithm that usually does only half as many comparisons as heapsort or quicksort." "Details: recursively split the range to be sorted into two halves, mergesort each half, then merge the two halves together. An extra copy of the data is used as temporary storage and successive merge phases copy data back and forth between the receiver and this copy. The recursion is set up so that the final merge is performed into the receiver, resulting in the receiver being completely sorted." | temp | self size <= 1 ifTrue: [^ self]. "nothing to do" startIndex = stopIndex ifTrue: [^ self]. (startIndex >= 1 and: [startIndex < stopIndex]) ifFalse: [self error: 'bad start index']. stopIndex <= self size ifFalse: [self error: 'bad stop index']. temp _ self basicCopy. self mergeSortFrom: startIndex to: stopIndex src: temp dst: self by: aBlock. ! ! !MArrayedCollection methodsFor: 'sorting' stamp: 'jm 4/27/98 04:54'! mergeSortFrom: first to: last src: src dst: dst by: aBlock "Private!! Split the range to be sorted in half, sort each half, and merge the two half-ranges into dst." | middle | first = last ifTrue: [^ self]. middle _ (first + last) // 2. self mergeSortFrom: first to: middle src: dst dst: src by: aBlock. self mergeSortFrom: middle + 1 to: last src: dst dst: src by: aBlock. src mergeFirst: first middle: middle last: last into: dst by: aBlock. ! ! !MArrayedCollection methodsFor: 'sorting' stamp: 'jm 4/27/98 05:48'! sort "Sort this array into ascending order using the '<' operator." self mergeSortFrom: 1 to: self size by: [:el1 :el2 | el1 < el2]. ! ! !MArrayedCollection methodsFor: 'sorting' stamp: 'jm 4/27/98 04:52'! sort: aBlock "Sort this array using the given comparision block. The block should take two arguments and return true if the first element should precede the second in the sorted result." self mergeSortFrom: 1 to: self size by: aBlock. ! ! !MArrayedCollection class methodsFor: 'instance creation' stamp: 'jm 11/30/2003 09:28'! new "Answer a new instance of me, with size = 0." ^ self new: 0 ! ! !MArrayedCollection class methodsFor: 'instance creation' stamp: 'jm 10/26/2003 19:55'! with: anObject "Answer a new instance of me, containing only anObject." | newCollection | newCollection _ self new: 1. newCollection at: 1 put: anObject. ^ newCollection ! ! !MArrayedCollection class methodsFor: 'instance creation' stamp: 'jm 10/26/2003 19:57'! with: firstObject with: secondObject "Answer a new instance of me containing the two arguments as elements." | newCollection | newCollection _ self new: 2. newCollection at: 1 put: firstObject. newCollection at: 2 put: secondObject. ^ newCollection ! ! !MArrayedCollection class methodsFor: 'instance creation' stamp: 'jm 10/26/2003 19:57'! with: firstObject with: secondObject with: thirdObject "Answer a new instance of me, containing 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 ! ! I represent a key-value pair. My instances can serve as entries in a Dictionary. They are used to store global and class variables. ! !MAssociation methodsFor: 'accessing' stamp: 'jm 12/21/2000 06:38'! key ^ key ! ! !MAssociation methodsFor: 'accessing' stamp: 'jm 12/21/2000 06:38'! key: anObject key _ anObject. ! ! !MAssociation methodsFor: 'accessing' stamp: 'jm 12/21/2000 06:38'! key: aKey value: anObject key _ aKey. value _ anObject. ! ! !MAssociation methodsFor: 'accessing' stamp: 'jm 12/21/2000 06:39'! value ^ value ! ! !MAssociation methodsFor: 'accessing' stamp: 'jm 12/21/2000 06:39'! value: anObject value _ anObject. ! ! !MAssociation methodsFor: 'printing' stamp: 'jm 10/29/2003 11:24'! printOn: aStream "Print in the format (key->value)." aStream nextPut: $(. key printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream. aStream nextPut: $). ! ! !MAssociation methodsFor: 'comparing' stamp: 'jm 12/21/2000 06:43'! < aLookupKey "Sort by keys." ^ key < aLookupKey key ! ! !MAssociation methodsFor: 'comparing' stamp: 'jm 12/21/2000 06:42'! = anAssociation "True if the receiver and argument have equal keys." self species = anAssociation species ifTrue: [^ key = anAssociation key] ifFalse: [^ false]. ! ! !MAssociation methodsFor: 'comparing' stamp: 'jm 12/21/2000 06:41'! hash "Hash is reimplemented because = is implemented." ^ key hash ! ! !MAssociation class methodsFor: 'instance creation' stamp: 'jm 12/21/2000 06:40'! key: newKey value: newValue "Answer a new Association with the given key and value." ^ self new key: newKey value: newValue ! ! I describe the behavior of other objects. I provide the minimum state needed by the virtual machine to lookup and execute methods. Most objects are actually instances of my richer subclass, Class, but I may a good starting point for providing instance-specific object behavior. Note: The virtual machine depends on the exact ordering of my instance variables. Note: For debugging purposes, three dummy instance variables have been added. This allows existing VM's to find class names during debugging and stack printing. ! !MBehavior methodsFor: 'initialization' stamp: 'jm 11/24/2003 09:23'! initialize "Default initialization." superclass _ MObject. format _ 2. methodDict _ MMethodDictionary new. ! ! !MBehavior methodsFor: 'instance creation' stamp: 'jm 10/28/2003 13:55'! basicNew "Primitive. Answer an instance of the receiver (which is a class) with no indexable fields. Fail if the class is variable-sized. Essential. See Object documentation whatIsAPrimitive." <primitive: 70> self isVariable ifTrue: [^ self basicNew: 0]. "space must be low" self error: 'low space'. ! ! !MBehavior methodsFor: 'instance creation' stamp: 'jm 10/28/2003 13:55'! basicNew: desiredSize "Primitive. Answer an instance of this class with the given number of indexable variables. Fail if this class is not indexable, if the argument is not a positive Integer, or if there is not enough memory available. Essential. See Object documentation whatIsAPrimitive." <primitive: 71> self isVariable ifFalse: [ self error: self name, ' is not variable-sized']. (desiredSize isInteger not or: [desiredSize < 0]) ifTrue: [ self error: 'bad size']. self error: 'low space'. ! ! !MBehavior methodsFor: 'instance creation' stamp: 'jm 11/23/2003 10:00'! new ^ self basicNew ! ! !MBehavior methodsFor: 'instance creation' stamp: 'jm 11/23/2003 09:58'! new: desiredSize ^ self basicNew: desiredSize ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/23/2003 10:16'! allInstVarNames "Answer an Array of the names of all my instance variables." ^ (1 to: self instSize) collect: [:i | 'instVar', i printString]. ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/26/2003 18:38'! classPool ^ nil ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/24/2003 14:20'! isBehavior "Answer true if I am a subclass of Behavior." ^ true ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/14/2002 17:44'! methodDict "Answer my method dictionary." ^ methodDict ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/14/2002 21:09'! name "Answer a String that names the receiver as well possible. Overridden by my subclasses." superclass ifNil: [^ 'a subclass of nil'] ifNotNil: [^ 'a subclass of ', superclass name]. ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/23/2003 13:24'! selectorAtMethod: method setClass: classResultBlock "Answer the message selector associated with the compiled method and evaluate the classResultBlock on the class in which that selector is defined." "Note: This method is here only to support the Squeak debugger." | sel | sel _ self methodDict keyAtIdentityValue: method ifAbsent: [ superclass ifNil: [ classResultBlock value: self. ^ #DoIt]. sel _ superclass selectorAtMethod: method setClass: classResultBlock. sel == #DoIt ifTrue: [classResultBlock value: self]. "if selector is DoIt, set class to me" ^ sel]. classResultBlock value: self. ^ sel ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/26/2003 18:38'! sharedPools ^ nil ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/14/2002 17:02'! superclass "Answer my superclass." ^ superclass ! ! !MBehavior methodsFor: 'accessing' stamp: 'jm 11/23/2003 11:46'! superclass: aBehaviorOrNil "Set my superclass." superclass _ aBehaviorOrNil. ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:29'! format "Answer a integer that encodes the format of instances of this class receiver. For now, this format word has exactly the same format as normal Squeak." ^ format ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:33'! indexIfCompact "If my compact class index is non-zero, then instances of this class will be compact, and their class will have an entry in Smalltalk compactClassesArray." ^ (format bitShift: -11) bitAnd: 16r1F ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:17'! instSize "Answer the number of named instance variables of the receiver. Objects can have up to 255 instance variables." ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1 ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:23'! instSpec ^ (format bitShift: -7) bitAnd: 16rF ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:25'! isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6 ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:24'! isBytes "Answer true if the receiver is byte-indexable. This is always false for non-indexable and pointer objects." ^ self instSpec >= 8 ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:25'! isPointers "Answer true if the receiver contains object pointers (versus bytes or words)." ^ self isBits not ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/23/2003 10:24'! isVariable "Answer true if the receiver has indexable fields." ^ self instSpec >= 2 ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 11/27/2003 09:55'! setCompactClassIndex: ccIndex "If my compact class index is non-zero, then instances of this class will be compact, and their class will have an entry in Smalltalk compactClassesArray." ((ccIndex > 0) and: [ccIndex <= 31]) ifFalse: [^ self error: 'compact class index must 1-31']. self indexIfCompact = 0 ifFalse: [^ self error: self name, ' is already compact!!']. format _ format + (ccIndex bitShift: 11). ! ! !MBehavior methodsFor: 'format accessing' stamp: 'jm 12/1/2003 22:26'! setFormat: anInteger "Warning!! Risky operation. Should only be done when there are not instances of this class." format _ anInteger. ! ! !MBehavior methodsFor: 'subclasses and superclasses' stamp: 'jm 12/8/2003 22:13'! 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 lookupSelector: selector) ~~ nil ! ! !MBehavior methodsFor: 'subclasses and superclasses' stamp: 'jm 11/14/2002 20:25'! inheritsFrom: aClass "Answer whether the argument is on the receiver's superclass chain." | this | this _ superclass. [this == nil] whileFalse: [ this == aClass ifTrue: [^true]. this _ this superclass]. ^ false ! ! !MBehavior methodsFor: 'subclasses and superclasses' stamp: 'jm 11/30/2003 18:33'! lookupSelector: selector "Look up the given selector in the methodDictionaries of every class in my superclass chain and answer the corresponding method if found. Answer nil if no method is found." | lookupClass mDict | lookupClass _ self. [lookupClass == nil] whileFalse: [ mDict _ lookupClass methodDict. (mDict includesKey: selector) ifTrue: [^ mDict at: selector]. lookupClass _ lookupClass superclass]. ^ nil ! ! !MBehavior methodsFor: 'instance enumeration' stamp: 'jm 10/27/2003 06:27'! allInstances "Answer a collection of all current instances of the receiver." | all | all _ MOrderedCollection new. self allInstancesDo: [:x | x == all ifFalse: [all add: x]]. ^ all asArray ! ! !MBehavior methodsFor: 'instance enumeration' stamp: 'jm 11/14/2002 20:22'! allInstancesDo: aBlock "Evaluate the given block for each instance of the receiver." | inst | self == MUndefinedObject ifTrue: [^ aBlock value: nil]. inst _ self someInstance. [inst == nil] whileFalse: [ aBlock value: inst. inst _ inst nextInstance]. ! ! !MBehavior methodsFor: 'instance enumeration' stamp: 'jm 10/27/2003 06:14'! someInstance "Primitive. Answer the first instance in the enumeration of all instances of the receiver. Answer nil if there are none. Essential. See Object documentation whatIsAPrimitive." <primitive: 77> ^ nil ! ! !MBehavior methodsFor: 'printing' stamp: 'jm 11/23/2003 12:55'! printOn: aStream aStream nextPutAll: self name. ! ! !MBitBlt methodsFor: 'initialization' stamp: 'jm 12/29/2003 11:17'! initialize rule _ MForm over. sourceX _ sourceY _ 0. destX _ destY _ 0. clipX _ clipY _ 0. clipWidth _ clipHeight _ 100000. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/11/2003 07:41'! clipX: x y: y width: w height: h "Set my clipping boundaries. Setting the clipping bounds is optional." clipX _ x. clipY _ y. clipWidth _ w. clipHeight _ h. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/14/2003 18:00'! destForm: aForm "Set my destination Form." destForm _ aForm. clipX _ 0. clipY _ 0. clipWidth _ aForm width. clipHeight _ aForm height. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/10/2003 22:56'! destX: x y: y width: w height: h "Set the destination rectangle for this operation." destX _ x. destY _ y. width _ w. height _ h. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/29/2003 11:13'! fillR: r g: g b: b "Set my fill color to the given RGB value, where r, g, and b are in the range 0-255. The destination form must be set before calling this method, since the pixel pattern created depends on the destination depth." "Note: The ranges of r, g, and b are not checked." | d pix | d _ destForm depth. d = 8 ifTrue: [ pix _ 41 + ((r // 37) * 36) + ((g // 37) * 6) + (b // 37). ^ self fillWords: (MWordArray with: 16r01010101 * pix)]. d = 16 ifTrue: [ "5 bits each of r, g, b" pix _ ((r // 8) bitShift: 10) + ((g // 8) bitShift: 5) + (b // 8). ^ self fillWords: (MWordArray with: (pix bitShift: 16) + pix)]. d = 32 ifTrue: [^ self fillWords: (MWordArray with: (r bitShift: 16) + (g bitShift: 8) + b)]. self error: 'color is supported only for depths 8, 16, and 32' ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/10/2003 23:00'! rule: anInteger "Set the combination rule, an integer between 0 and 34 that determines how pixels are combined in this operation." rule _ anInteger. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/14/2003 17:49'! sourceForm: aForm "Set my source and destination forms. The source form may be nil if filling with a color." sourceForm _ aForm. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/10/2003 22:58'! sourceX: x y: y "Set the top-left corner of the destination rectangle for this operation." sourceX _ x. sourceY _ y. ! ! !MBitBlt methodsFor: 'setup' stamp: 'jm 12/10/2003 22:59'! width: w height: h "Set the width and height for this operation." width _ w. height _ h. ! ! !MBitBlt methodsFor: 'operate' stamp: 'jm 12/29/2003 11: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 or if the combination rule is not implemented." <primitive: 96> self primitiveFailed ! ! !MBitBlt methodsFor: 'operate' stamp: 'jm 12/29/2003 11:07'! copyBitsTranslucent: factor "This entry point to BitBlt supplies an extra argument to specify translucency for operations 30 and 31. The argument must be an integer between 0 and 255." <primitive: 96> self primitiveFailed ! ! !MBitBlt methodsFor: 'private' stamp: 'jm 12/14/2003 17:42'! fillWords "Answer the array of pixel words using for filling with a color." ^ fillWords ! ! !MBitBlt methodsFor: 'private' stamp: 'jm 12/14/2003 17:54'! fillWords: aBitmapOrNil "Set the array of pixel words using for filling with a color." fillWords _ aBitmapOrNil. ! ! I represent the context (stack frame) for a code block (code in square backets such as "[3 + 4]"). I know how many arguments I need. I support a number of messages for evaluating myself. ! !MBlockContext methodsFor: 'accessing' stamp: 'jm 11/30/2003 16:41'! home ^ home ! ! !MBlockContext methodsFor: 'accessing' stamp: 'jm 11/30/2003 16:57'! home: aMethodContext startpc: initialPC nargs: argCount home _ aMethodContext. startpc _ initialPC. nargs _ argCount. ! ! !MBlockContext methodsFor: 'accessing' stamp: 'jm 11/30/2003 16:49'! method ^ home method ! ! !MBlockContext methodsFor: 'accessing' stamp: 'jm 12/8/2003 23:16'! numArgs ^ nargs ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 5/22/2003 20:25'! ifError: errorHandlerBlock "Evaluate the block represented by the receiver. If an error occurs the given handler block is evaluated. The handler block can be either a zero- or two-argument block; if the latter, then the error message and receiver are supplied to it as parameters. Answer the value returned by the handler block if the receiver gets an error." "Warning: The receiver should not contain an explicit return since that would leave an obsolete error handler hanging around." "Examples: [1 whatsUpDoc] ifError: [:err :rcvr | ^ 'huh?']. [1 whatsUpDoc] ifError: ['huh']. [1 / 0] ifError: [:err :rcvr | 'division by 0' = err ifTrue: [^ Float infinity] ifFalse: [self error: err]] " | activeProcess lastHandler val | activeProcess _ Processor activeProcess. lastHandler _ activeProcess errorHandler. activeProcess errorHandler: [:aString :aReceiver | activeProcess errorHandler: lastHandler. errorHandlerBlock numArgs = 0 ifTrue: [^ errorHandlerBlock value]. ^ errorHandlerBlock value: aString value: aReceiver]. val _ self value. activeProcess errorHandler: lastHandler. ^ val ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 12/9/2003 00:07'! msecs "Answer the number of milliseconds it took to evaluate this block." | startMSecs | startMSecs _ MSystem milliseconds. self value. ^ MSystem milliseconds - startMSecs ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 11/30/2003 17:02'! value "Evaluate this block without any arguments." <primitive: 81> ^ self valueWithArguments: #() ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 11/30/2003 17:02'! value: arg "Evaluate this block with one argument." <primitive: 81> ^ self valueWithArguments: (MArray with: arg) ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 11/30/2003 17:03'! value: arg1 value: arg2 "Evaluate this block with two arguments." <primitive: 81> ^ self valueWithArguments: (MArray with: arg1 with: arg2) ! ! !MBlockContext methodsFor: 'evaluating' stamp: 'jm 11/30/2003 17:06'! valueWithArguments: anArray "Primitive. Evaluate the block represented by the receiver. The argument is an Array whose elements are the arguments for the block. Fail if the length of the Array is not the same as the the number of arguments that the block was expecting. Fail if the block is already being executed. Essential. See Object documentation whatIsAPrimitive." <primitive: 82> anArray size = nargs ifTrue: [self error: 'Attempt to evaluate a block that is already being evaluated.'] ifFalse: [self error: 'This block requires ', nargs printString, ' arguments.'] ! ! I represent an ArrayedCollection whose elements are integers between 0 and 255 packed efficiently into memory. ! !MByteArray methodsFor: 'converting' stamp: 'jm 12/27/2000 10:28'! asByteArray ^ self ! ! !MByteArray methodsFor: 'converting' stamp: 'jm 10/27/2003 07:26'! asString "Answer the receiver converted to a String." ^ (MString new: self size) replaceFrom: 1 to: self size with: self startingAt: 1 ! ! !MByteArray methodsFor: 'private' stamp: 'jm 12/27/2000 10:32'! replaceFrom: startIndex to: stopIndex with: source startingAt: srcStartIndex "Primitive. Destructively replace the elements from startIndex to stopIndex in the receiver with the elements starting at srcStartIndex in the source collection. Answer the receiver. Range checks are performed in the primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 105> super replaceFrom: startIndex to: stopIndex with: source startingAt: srcStartIndex. ! ! 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. ! !MCharacter methodsFor: 'accessing' stamp: 'jm 11/23/2003 13:10'! asciiValue "Answer the value of the receiver that represents its ascii encoding." ^ value ! ! !MCharacter methodsFor: 'accessing' stamp: 'jm 11/28/2003 17:29'! digitValue "Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z, and -1 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! ! !MCharacter methodsFor: 'comparing' stamp: 'jm 11/28/2003 17:30'! < aCharacter "Answer true if my value is less than the given character's value." ^ self asciiValue < aCharacter asciiValue ! ! !MCharacter methodsFor: 'comparing' stamp: 'jm 11/28/2003 17:30'! = 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." <primitive: 110> ^ self == aCharacter ! ! !MCharacter methodsFor: 'comparing' stamp: 'jm 11/28/2003 17:31'! > aCharacter "Answer true if my value is greater than the given character's value." ^ self asciiValue > aCharacter asciiValue ! ! !MCharacter methodsFor: 'comparing' stamp: 'jm 11/28/2003 17:31'! hash "My hash is my value." ^ value ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 11/28/2003 17:14'! isDigit "Answer whether the receiver is a digit." ^ value >= 48 and: [value <= 57] ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 11/28/2003 17:13'! isLetter "Answer whether the receiver is a letter." ^ (65 <= value and: [value <= 90]) or: [97 <= value and: [value <= 122]] ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 11/28/2003 17:15'! isSpecial "Answer whether the receiver is one of the special characters" ^ '+/\*~<>=@%|&?!!' includes: self ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 10/28/2003 11:40'! isUppercase "Answer whether the receiver is an uppercase letter." ^ 65 <= value and: [value <= 90] ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 11/28/2003 17:16'! isVowel "Answer true if the receiver is one of the vowels AEIOU (either upper- or lowercase)." ^ 'AEIOU' includes: self asUppercase ! ! !MCharacter methodsFor: 'testing' stamp: 'jm 11/28/2003 17:16'! tokenish "Answer true if the receiver is a valid token-character--that is, a letter, digit, or colon." ^ self isLetter or: [self isDigit or: [self = $:]] ! ! !MCharacter methodsFor: 'copying' stamp: 'jm 12/2/2003 22:02'! basicCopy "Answer myself because Characters are unique." ! ! !MCharacter methodsFor: 'printing' stamp: 'jm 10/26/2003 17:45'! printOn: aStream aStream nextPut: $$. aStream nextPut: self. ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 10/28/2003 11:33'! asCharacter "Answer the receiver itself." ^ self ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 11/28/2003 17:33'! asInteger "Answer my ASCII value." ^ value ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 11/28/2003 17:34'! asLowercase "If I am uppercase, answer the matching lowercase Character. Otherwise, answer myself." (65 <= value and: [value <= 90]) "self isUppercase" ifTrue: [^ (value + 32) asCharacter] ifFalse: [^ self] ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 11/13/2002 18:19'! asString ^ MString with: self ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 10/28/2003 11:42'! asUppercase "If the receiver is lowercase, answer its matching uppercase Character." (97 <= value and: [value <= 122]) "self isLowercase" ifTrue: [^ (value - 32) asCharacter] ifFalse: [^ self] ! ! !MCharacter methodsFor: 'converting' stamp: 'jm 10/28/2003 11:38'! to: other "Answer with a collection of all characters in the given ASCII range. For example, $a to: $z" ^ (self asciiValue to: other asciiValue) collect: [:i | i asCharacter] ! ! !MCharacter class methodsFor: 'instance creation' stamp: 'jm 11/28/2003 17:35'! asciiValue: anInteger "Answer the Character whose ASCII value is anInteger." ^ CharacterTable at: anInteger + 1 ! ! !MCharacter class methodsFor: 'instance creation' stamp: 'jm 10/28/2003 11:33'! 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." | i | i _ x asInteger. ^ CharacterTable at: (i < 10 ifTrue: [48 + i] ifFalse: [55 + i]) + 1 ! ! !MCharacter class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:25'! new "There are 256 unique Characters; creating new ones is not allowed." self cannotInstantiate. ! ! !MCharacter class methodsFor: 'instance creation' stamp: 'jm 10/26/2003 17:39'! value: anInteger "Answer the MCharacter whose ascii value is anInteger." ^ CharacterTable at: anInteger + 1 ! ! !MCharacter class methodsFor: 'constants' stamp: 'jm 11/23/2003 13:06'! cr "Answer the Character representing a carriage return." ^ 13 asCharacter ! ! !MCharacter class methodsFor: 'constants' stamp: 'jm 11/23/2003 13:06'! lf "Answer the Character representing a linefeed." ^ 10 asCharacter ! ! !MCharacter class methodsFor: 'constants' stamp: 'jm 11/23/2003 13:06'! space "Answer the Character representing a space." ^ 32 asCharacter ! ! !MCharacter class methodsFor: 'constants' stamp: 'jm 11/23/2003 13:06'! tab "Answer the Character representing a tab." ^ 9 asCharacter ! ! I add the following facilities to Behavior: o class name o named instance variables o an optional dictionary of class variables ! !MClass methodsFor: 'initialization' stamp: 'jm 11/24/2003 23:06'! initFrom: aSqueakClass methodDict: newMethodDict "Fill in my instance variables from the given Squeak Class using the given MethodDictionary." superclass _ MObject. "corrected later" methodDict _ newMethodDict. format _ aSqueakClass format. name _ (aSqueakClass name copyFrom: 2 to: aSqueakClass name size) asSymbol. "omit leading M" instVarNames _ aSqueakClass instVarNames. classVariables _ aSqueakClass classPool. instVarNames size = 0 ifTrue: [instVarNames _ nil]. classVariables size = 0 ifTrue: [classVariables _ nil]. ! ! !MClass methodsFor: 'accessing' stamp: 'jm 11/23/2003 13:30'! classVariables "Answer the dictionary of class variables that I share with my sole instance, or nil if I have none." ^ classVariables ! ! !MClass methodsFor: 'accessing' stamp: 'jm 10/28/2003 08:37'! instVarNames "Answer an Array of the receiver's instance variable names." instVarNames ifNil: [^ #()]. ^ instVarNames ! ! !MClass methodsFor: 'accessing' stamp: 'jm 10/28/2003 08:49'! name ^ name ! ! I am the abstract superclass for classes that represent a collection of elements such as lists, arrays, sets, and dictionaries. ! !MCollection methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:31'! size "Answer how many elements the receiver contains." | count | count _ 0. self do: [:each | count _ count + 1]. ^ count ! ! !MCollection methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:35'! sum "Answer the sum of the elements of this collection. If the collection is empty, answer zero." "Details: Use an arbitrary element of the collection as the initial value so this method will work for collections of any kind of object that understands + and -." | total seed | total _ seed _ self detect: [:x | true] ifNone: [^ 0]. self do: [:el | total _ total + el]. ^ total - seed "subtract the seed value from the total" ! ! !MCollection methodsFor: 'testing' stamp: 'jm 12/31/2003 12:31'! includes: anObject "Answer whether anObject is one of the receiver's elements." self do: [:each | anObject = each ifTrue: [^ true]]. ^ false ! ! !MCollection methodsFor: 'testing' stamp: 'jm 12/31/2003 12:32'! isEmpty "Answer whether the receiver contains any elements." ^ self size = 0 ! ! !MCollection methodsFor: 'adding/removing' stamp: 'jm 12/31/2003 12:32'! add: newObject "Include newObject as one of my elements. Answer newObject. ArrayedCollections cannot respond to this message." self subclassResponsibility ! ! !MCollection methodsFor: 'adding/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]! ! !MCollection methodsFor: 'adding/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! ! !MCollection 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! ! !MCollection 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! ! !MCollection methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." self subclassResponsibility! ! !MCollection 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! ! !MCollection methodsFor: 'converting' stamp: 'jm 11/13/2002 16:24'! asArray "Answer an Array whose elements are the elements of this collection. The order in which elements are added depends on the order in which this collection enumerates its elements. In the case of unordered collections, the ordering is not necessarily the same for multiple requests for the conversion." | result i | result _ MArray new: self size. i _ 0. self do: [:each | result at: (i _ i + 1) put: each]. ^ result ! ! !MCollection methodsFor: 'converting' stamp: 'jm 11/24/2003 07:48'! asByteArray "Answer a ByteArray containing my elements." | result i | result _ MByteArray new: self size. i _ 0. self do: [:each | result at: (i _ i + 1) put: each]. ^ result ! ! !MCollection methodsFor: 'converting' stamp: 'jm 11/13/2002 17:19'! asSet "Answer a Set whose elements are the unique elements of the receiver." | aSet | aSet _ MSet new: self size. self do: [:each | aSet add: each]. ^ aSet ! ! !MCollection 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: $)! ! !MCollection methodsFor: 'private'! emptyCheck self isEmpty ifTrue: [self errorEmptyCollection]! ! !MCollection methodsFor: 'private'! errorEmptyCollection self error: 'this collection is empty'! ! !MCollection methodsFor: 'private'! errorNotFound self error: 'Object is not in the collection.'! ! !MCollection class methodsFor: 'instance creation'! with: anObject "Answer an instance of me containing anObject." | newCollection | newCollection _ self new. newCollection add: anObject. ^newCollection! ! !MCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject "Answer an instance of me containing the two arguments as elements." | newCollection | newCollection _ self new. newCollection add: firstObject. newCollection add: secondObject. ^newCollection! ! !MCollection class methodsFor: 'instance creation'! with: firstObject with: secondObject with: thirdObject "Answer an instance of me containing the three arguments as elements." | newCollection | newCollection _ self new. newCollection add: firstObject. newCollection add: secondObject. newCollection add: thirdObject. ^newCollection! ! I represent a compiled method. I contain a header word, a set of indexable slots that hold literal objects needed by my code, and a sequence of bytecodes. CompiledMethods are the only kind of object that can contain a mixture of pointer slots (the literal slots) and uninterpreted bits (the bytecodes). This is an optimization that minimizes both space the the number of objects needed to represent the code of a Smalltalk image. Because there are typically a large number of CompiledMethods in an image, this optimization an important one, although it does add complexity to the system. ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 12/31/2003 10:11'! frameSize "Answer the size of temporary frame needed to run the receiver." "NOTE: Versions 2.7 and later use two sizes of contexts." (self header bitAnd: 16r20000) = 0 ifTrue: [^ 16] ifFalse: [^ 56]. ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/29/2003 19:47'! header "Answer the method header word containing information about the form of this method (e.g., number of literals) and the context needed to run it." ^ self objectAt: 1 ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/30/2003 18:47'! initialPC "Answer the program counter for my first bytecode." ^ (4 * (self numLiterals + 1)) + 1 ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/30/2003 18:48'! numLiterals "Answer the number of literals used by the receiver." ^ (self header bitShift: -9) bitAnd: 16rFF ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/30/2003 18:41'! numTemps "Answer the number of temporary variables used by this method." ^ (self header bitShift: -18) bitAnd: 16r3F ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/29/2003 19:48'! objectAt: index "Primitive. Answer the method header (if index = 1) or a literal (if index > 1) from the receiver. Essential. See Object documentation whatIsAPrimitive." <primitive: 68> self primitiveFailed ! ! !MCompiledMethod methodsFor: 'accessing' stamp: 'jm 11/30/2003 18:42'! 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." <primitive: 69> self primitiveFailed ! ! Contexts are used by the virtual machine to represent stack frames. This is an abstract class. My two concrete subclasses are used to represent block and method stack frames. ! !MContext methodsFor: 'accessing' stamp: 'jm 10/28/2003 13:10'! sender "Answer the context that sent the message that created the receiver." ^ sender ! ! !MContext methodsFor: 'other' stamp: 'jm 12/31/2003 09:37'! 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." <primitive: 80> ^ (MBlockContext newForMethod: self home method) home: self home startpc: pc + 2 nargs: numArgs ! ! !MContext class methodsFor: 'instance creation' stamp: 'jm 11/30/2003 16:54'! newForMethod: aMethod "This is the only method for creating new contexts, other than by using the clone primitive. Any other attempts, such as inherited methods like shallowCopy, should be avoided or must at least be rewritten to determine the proper size for the method that will use this context. This is because asking a context its size (even basicSize!!) will not return the actual object size but only the number of fields currently accessible, as determined by stackp." ^ super basicNew: aMethod frameSize ! ! 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. ! !MDictionary methodsFor: 'accessing'! associationAt: key ^ self associationAt: key ifAbsent: [self errorKeyNotFound]! ! !MDictionary 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! ! !MDictionary methodsFor: 'accessing'! at: key "Answer the value associated with the key." ^ self at: key ifAbsent: [self errorKeyNotFound]! ! !MDictionary methodsFor: 'accessing'! at: key ifAbsent: aBlock | index assoc | index _ self findElementOrNil: key. assoc _ array at: index. nil == assoc ifTrue: [ ^ aBlock value ]. ^ assoc value! ! !MDictionary methodsFor: 'accessing' stamp: 'jm 11/13/2002 16:25'! 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: (MAssociation key: key value: anObject)] ifFalse: [element value: anObject]. ^ anObject! ! !MDictionary 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]! ! !MDictionary 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! ! !MDictionary methodsFor: 'accessing' stamp: 'jm 11/13/2002 18:08'! keys "Answer a Set containing the receiver's keys." | aSet | aSet _ MSet new: self size. self keysDo: [:key | aSet add: key]. ^ aSet ! ! !MDictionary methodsFor: 'testing'! includes: anObject self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !MDictionary 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]! ! !MDictionary 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! ! !MDictionary methodsFor: 'removing' stamp: 'jm 10/27/2003 06:08'! remove: anObject self shouldNotImplement. ! ! !MDictionary methodsFor: 'removing' stamp: 'jm 10/27/2003 06:08'! remove: anObject ifAbsent: exceptionBlock self shouldNotImplement. ! ! !MDictionary 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]! ! !MDictionary 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! ! !MDictionary methodsFor: 'enumerating'! associationsDo: aBlock "Evaluate aBlock for each of the receiver's elements (key/value associations)." super do: aBlock! ! !MDictionary methodsFor: 'enumerating' stamp: 'jm 11/13/2002 17:37'! 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 _ MOrderedCollection new: self size. self do: [:each | newCollection add: (aBlock value: each)]. ^ newCollection ! ! !MDictionary methodsFor: 'enumerating'! do: aBlock super do: [:assoc | aBlock value: assoc value]! ! !MDictionary methodsFor: 'enumerating'! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association key]! ! !MDictionary 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! ! !MDictionary methodsFor: 'copying' stamp: 'jm 12/2/2003 22:31'! copy "Must copy all my associations or later stores into either dictionary will effect both the original and the copy." ^ self basicCopy withArray: (array collect: [:assoc | assoc ifNil: [nil] ifNotNil: [MAssociation key: assoc key value: assoc value]]) ! ! !MDictionary 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: $)! ! !MDictionary methodsFor: 'private'! errorKeyNotFound self error: 'key not found'! ! !MDictionary methodsFor: 'private'! errorValueNotFound self error: 'value not found'! ! !MDictionary 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]! ! !MDictionary 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! ! !MDictionary 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"! ! I represent the logical value true. ! !MFalse methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:37'! & aBoolean "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." ^ false ! ! !MFalse methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:43'! and: alternativeBlock "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." ^ false ! ! !MFalse methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:37'! not "Answer the negation of the receiver." ^ true ! ! !MFalse methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:44'! or: alternativeBlock "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." ^ alternativeBlock value ! ! !MFalse methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:37'! | aBoolean "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." ^ aBoolean ! ! !MFalse methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:39'! ifFalse: falseBlock "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." ^ falseBlock value ! ! !MFalse methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:39'! ifTrue: trueBlock "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." ^ nil ! ! !MFalse methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:40'! ifTrue: trueBlock ifFalse: falseBlock "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." ^ falseBlock value ! ! !MFalse methodsFor: 'printing' stamp: 'jm 11/11/2002 19:00'! printOn: aStream aStream nextPutAll: 'false'. ! ! I support simple file i/o for MicroSqueak. Unlike Squeak FileStreams, I am not a Stream. ! !MFile methodsFor: 'open/close' stamp: 'jm 11/24/2003 18:41'! close "Close this file." fileID ifNotNil: [ self primClose: fileID. fileID _ nil]. ! ! !MFile methodsFor: 'open/close' stamp: 'jm 11/24/2003 20:14'! name "Answer the name of this file." ^ name ! ! !MFile methodsFor: 'open/close' stamp: 'jm 11/24/2003 20:23'! openReadOnly: fileName "Open the file with the given name for reading and writing." name _ nil. fileID _ self primOpen: fileName writable: false. name _ fileName. ! ! !MFile methodsFor: 'open/close' stamp: 'jm 11/24/2003 20:23'! openReadWrite: fileName "Open the file with the given name for reading only." name _ nil. fileID _ self primOpen: fileName writable: true. name _ fileName. ! ! !MFile methodsFor: 'file ops' stamp: 'jm 12/8/2003 23:44'! cr self nextPutAll: (MString with: MCharacter cr). ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/26/2003 20:02'! next: count "Answer a String containing the next count bytes of the file. If there are not count bytes left in the file, answer a String with as many bytes as available." | buffer n | buffer _ '' class new: count. n _ self primRead: fileID into: buffer startingAt: 1 count: count. n < count ifTrue: [buffer _ buffer copyFrom: 1 to: n]. ^ buffer ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/24/2003 19:59'! nextPutAll: buffer "Write the contents of the given bytes or words object to this file." ^ self primWrite: fileID from: buffer startingAt: 1 count: buffer basicSize ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/24/2003 20:18'! position "Answer the current file position in bytes." ^ self primGetPosition: fileID ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/24/2003 20:18'! position: newPosition "Seek to the given file position in bytes." ^ self primSetPosition: fileID to: newPosition ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/24/2003 20:03'! readInto: buffer startingAt: startIndex count: count "Read up to count elements into the given array and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." ^ self primRead: fileID into: buffer startingAt: startIndex count: count ! ! !MFile methodsFor: 'file ops' stamp: 'jm 11/24/2003 20:16'! size "Answer the size of this file in bytes." ^ self primSize: fileID ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:01'! primClose: id "Close this file. Don't raise an error if the primitive fails." <primitive: 151> ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 18:47'! primGetPosition: id "Get this files current position." <primitive: 152> self primitiveFailed ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:22'! primOpen: fileName writable: writableFlag "Open a file of the given name, and return the file ID obtained. If writableFlag is true, then if there is none with this name, then create one else prepare to overwrite the existing from the beginning otherwise if the file exists, open it read-only else return nil" <primitive: 153> self primitiveFailed ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:05'! primRead: id into: byteArray startingAt: startIndex count: count "Read up to count elements into the given buffer and answer the number of elements actually read. The buffer may either a byte- or word-indexable object." <primitive: 154> self primitiveFailed ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:01'! primSetPosition: id to: anInteger "Set this file to the given position." <primitive: 155> self primitiveFailed ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:01'! primSize: id "Answer the size of this file." <primitive: 157> self primitiveFailed ! ! !MFile methodsFor: 'primitives' stamp: 'jm 11/24/2003 20:05'! primWrite: id from: buffer startingAt: startIndex count: count "Write up to count elements from the given buffer and answer the number of elements actually written. The buffer may either a byte- or word-indexable object." <primitive: 158> self primitiveFailed ! ! My instances represent IEEE-754 floating-point double-precision numbers. They have about 16 digits of accuracy and their range is between plus and minus 10^307. Some valid examples are: 8.0 13.3 0.3 2.5e6 1.27e-30 1.27e-31 -12.987654e12 Mainly: no embedded blanks, little e for tens power, and a digit on both sides of the decimal point. ! !MFloat methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:54'! * aNumber "Primitive. Answer the result of multiplying the receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 49> ^ aNumber adaptToFloat: self andSend: #*! ! !MFloat methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:22'! + aNumber "Primitive. Answer the sum of the receiver and aNumber. Essential. Fail if the argument is not a Float. See Object documentation whatIsAPrimitive." <primitive: 41> ^ aNumber adaptToFloat: self andSend: #+! ! !MFloat methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'! - aNumber "Primitive. Answer the difference between the receiver and aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 42> ^ aNumber adaptToFloat: self andSend: #-! ! !MFloat methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:55'! / aNumber "Primitive. Answer the result of dividing receiver by aNumber. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 50> aNumber = 0 ifTrue: [self error: 'attempt to divide by zero']. ^ aNumber adaptToFloat: self andSend: #/! ! !MFloat methodsFor: 'arithmetic'! abs "This is faster than using Number abs." self < 0.0 ifTrue: [^ 0.0 - self] ifFalse: [^ self]! ! !MFloat methodsFor: 'arithmetic'! negated "Answer a Number that is the negation of the receiver." ^0.0 - self! ! !MFloat methodsFor: 'arithmetic'! reciprocal ^ 1.0 / self! ! !MFloat methodsFor: 'mathematical functions'! arcCos "Answer the angle in radians." ^ Halfpi - self arcSin! ! !MFloat methodsFor: 'mathematical functions'! arcSin "Answer the angle in radians." ((self < -1.0) or: [self > 1.0]) ifTrue: [self error: 'Value out of range']. ((self = -1.0) or: [self = 1.0]) ifTrue: [^ Halfpi] ifFalse: [^ (self / (1.0 - (self * self)) sqrt) arcTan]! ! !MFloat methodsFor: 'mathematical functions'! arcTan "Answer the angle in radians. Optional. See Object documentation whatIsAPrimitive." | theta eps step sinTheta cosTheta | <primitive: 57> "Newton-Raphson" self < 0.0 ifTrue: [ ^ 0.0 - (0.0 - self) arcTan ]. "first guess" theta _ (self * Halfpi) / (self + 1.0). "iterate" eps _ Halfpi * Epsilon. step _ theta. [(step * step) > eps] whileTrue: [ sinTheta _ theta sin. cosTheta _ theta cos. step _ (sinTheta * cosTheta) - (self * cosTheta * cosTheta). theta _ theta - step]. ^ theta! ! !MFloat methodsFor: 'mathematical functions'! cos "Answer the cosine of the receiver taken as an angle in radians." ^ (self + Halfpi) sin! ! !MFloat methodsFor: 'mathematical functions'! exp "Answer E raised to the receiver power. Optional. See Object documentation whatIsAPrimitive." | base fract correction delta div | <primitive: 59> "Taylor series" "check the special cases" self < 0.0 ifTrue: [^ (self negated exp) reciprocal]. self = 0.0 ifTrue: [^ 1]. self abs > MaxValLn ifTrue: [self error: 'exp overflow']. "get first approximation by raising e to integer power" base _ E raisedToInteger: (self truncated). "now compute the correction with a short Taylor series" "fract will be 0..1, so correction will be 1..E" "in the worst case, convergance time is logarithmic with 1/Epsilon" fract _ self fractionPart. fract = 0.0 ifTrue: [ ^ base ]. "no correction required" correction _ 1.0 + fract. delta _ fract * fract / 2.0. div _ 2.0. [delta > Epsilon] whileTrue: [ correction _ correction + delta. div _ div + 1.0. delta _ delta * fract / div]. correction _ correction + delta. ^ base * correction! ! !MFloat methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:28'! floorLog: radix "Answer the floor of the log base radix of the receiver." ^ (self log: radix) floor ! ! !MFloat methodsFor: 'mathematical functions'! ln "Answer the natural logarithm of the receiver. Optional. See Object documentation whatIsAPrimitive." | expt n mant x div pow delta sum eps | <primitive: 58> "Taylor series" self <= 0.0 ifTrue: [self error: 'ln is only defined for x > 0.0']. "get a rough estimate from binary exponent" expt _ self exponent. n _ Ln2 * expt. mant _ self timesTwoPower: 0 - expt. "compute fine correction from mantinssa in Taylor series" "mant is in the range [0..2]" "we unroll the loop to avoid use of abs" x _ mant - 1.0. div _ 1.0. pow _ delta _ sum _ x. x _ x negated. "x <= 0" eps _ Epsilon * (n abs + 1.0). [delta > eps] whileTrue: [ "pass one: delta is positive" div _ div + 1.0. pow _ pow * x. delta _ pow / div. sum _ sum + delta. "pass two: delta is negative" div _ div + 1.0. pow _ pow * x. delta _ pow / div. sum _ sum + delta]. ^ n + sum "2.718284 ln 1.0"! ! !MFloat methodsFor: 'mathematical functions'! log "Answer the base 10 logarithm of the receiver." ^ self ln / Ln10! ! !MFloat methodsFor: 'mathematical functions' stamp: 'jm 5/14/1998 11:04'! raisedTo: aNumber "Answer the receiver raised to aNumber." 0.0 = aNumber ifTrue: [^ 1.0]. "special case for 0.0 raisedTo: 0.0" ^ (self ln * aNumber asFloat) exp ! ! !MFloat methodsFor: 'mathematical functions' stamp: 'tao 10/15/97 14:23'! reciprocalLogBase2 "optimized for self = 10, for use in conversion for printing" ^ self = 10.0 ifTrue: [Ln2 / Ln10] ifFalse: [Ln2 / self ln]! ! !MFloat methodsFor: 'mathematical functions'! sin "Answer the sine of the receiver taken as an angle in radians. Optional. See Object documentation whatIsAPrimitive." | sum delta self2 i | <primitive: 56> "Taylor series" "normalize to the range [0..Pi/2]" self < 0.0 ifTrue: [^ (0.0 - ((0.0 - self) sin))]. self > Twopi ifTrue: [^ (self \\ Twopi) sin]. self > Pi ifTrue: [^ (0.0 - (self - Pi) sin)]. self > Halfpi ifTrue: [^ (Pi - self) sin]. "unroll loop to avoid use of abs" sum _ delta _ self. self2 _ 0.0 - (self * self). i _ 2.0. [delta > Epsilon] whileTrue: [ "once" delta _ (delta * self2) / (i * (i + 1.0)). i _ i + 2.0. sum _ sum + delta. "twice" delta _ (delta * self2) / (i * (i + 1.0)). i _ i + 2.0. sum _ sum + delta]. ^ sum! ! !MFloat methodsFor: 'mathematical functions'! sqrt "Answer the square root of the receiver. Optional. See Object documentation whatIsAPrimitive." | exp guess eps delta | <primitive: 55> "Newton-Raphson" self <= 0.0 ifTrue: [ self = 0.0 ifTrue: [^ 0.0] ifFalse: [^ self error: 'sqrt is invalid for x < 0']]. "first guess is half the exponent" exp _ self exponent // 2. guess _ self timesTwoPower: (0 - exp). "get eps value" eps _ guess * Epsilon. eps _ eps * eps. delta _ (self - (guess * guess)) / (guess * 2.0). [(delta * delta) > eps] whileTrue: [ guess _ guess + delta. delta _ (self - (guess * guess)) / (guess * 2.0)]. ^ guess! ! !MFloat methodsFor: 'mathematical functions'! tan "Answer the tangent of the receiver taken as an angle in radians." ^ self sin / self cos! ! !MFloat methodsFor: 'mathematical functions'! timesTwoPower: anInteger "Primitive. Answer with the receiver multiplied by 2.0 raised to the power of the argument. Optional. See Object documentation whatIsAPrimitive." <primitive: 54> anInteger < -29 ifTrue: [^ self * (2.0 raisedToInteger: anInteger)]. anInteger < 0 ifTrue: [^ self / (1 bitShift: (0 - anInteger)) asFloat]. anInteger < 30 ifTrue: [^ self * (1 bitShift: anInteger) asFloat]. ^ self * (2.0 raisedToInteger: anInteger)! ! !MFloat methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'! < aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is less than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 43> ^ aNumber adaptToFloat: self andSend: #<! ! !MFloat methodsFor: 'comparing' stamp: 'di 11/6/1998 13:55'! <= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is less than or equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive." <primitive: 45> ^ aNumber adaptToFloat: self andSend: #<=! ! !MFloat methodsFor: 'comparing' stamp: 'di 11/6/1998 13:56'! = aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is equal to the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 47> aNumber isNumber ifFalse: [^ false]. ^ aNumber adaptToFloat: self andSend: #=! ! !MFloat methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'! > aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than the argument. Otherwise return false. Fail if the argument is not a Float. Essential. See Object documentation whatIsAPrimitive." <primitive: 44> ^ aNumber adaptToFloat: self andSend: #>! ! !MFloat methodsFor: 'comparing' stamp: 'di 11/6/1998 13:57'! >= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is greater than or equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive. " <primitive: 46> ^ aNumber adaptToFloat: self andSend: #>! ! !MFloat methodsFor: 'comparing' stamp: 'jm 4/28/1998 01:04'! hash "Hash is reimplemented because = is implemented. Both words of the float are used; 8 bits are removed from each end to clear most of the exponent regardless of the byte ordering. (The bitAnd:'s ensure that the intermediate results do not become a large integer.) Slower than the original version in the ratios 12:5 to 2:1 depending on values. (DNS, 11 May, 1997)" ^ (((self basicAt: 1) bitAnd: 16r00FFFF00) + ((self basicAt: 2) bitAnd: 16r00FFFF00)) bitShift: -8 ! ! !MFloat methodsFor: 'comparing'! ~= aNumber "Primitive. Compare the receiver with the argument and return true if the receiver is not equal to the argument. Otherwise return false. Fail if the argument is not a Float. Optional. See Object documentation whatIsAPrimitive." <primitive: 48> ^super ~= aNumber! ! !MFloat methodsFor: 'testing' stamp: 'jm 4/30/1998 13:50'! isInfinite "Return true if the receiver is positive or negative infinity." ^ self = Infinity or: [self = NegativeInfinity] ! ! !MFloat methodsFor: 'testing' stamp: 'tao 10/10/97 16:39'! isNaN "simple, byte-order independent test for Not-a-Number" ^ self ~= self! ! !MFloat methodsFor: 'testing' stamp: 'jm 4/28/1998 01:10'! sign "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0. Handle IEEE-754 negative-zero by reporting a sign of -1" self > 0 ifTrue: [^ 1]. (self < 0 or: [((self at: 1) bitShift: -31) = 1]) ifTrue: [^ -1]. ^ 0! ! !MFloat methodsFor: 'truncation and round off'! exponent "Primitive. Consider the receiver to be represented as a power of two multiplied by a mantissa (between one and two). Answer with the SmallInteger to whose power two is raised. Optional. See Object documentation whatIsAPrimitive." | positive | <primitive: 53> self >= 1.0 ifTrue: [^self floorLog: 2]. self > 0.0 ifTrue: [positive _ (1.0 / self) exponent. self = (1.0 / (1.0 timesTwoPower: positive)) ifTrue: [^positive negated] ifFalse: [^positive negated - 1]]. self = 0.0 ifTrue: [^-1]. ^self negated exponent! ! !MFloat methodsFor: 'truncation and round off'! fractionPart "Primitive. Answer a Float whose value is the difference between the receiver and the receiver's asInteger value. Optional. See Object documentation whatIsAPrimitive." <primitive: 52> ^self - self truncated asFloat! ! !MFloat methodsFor: 'truncation and round off'! rounded "Answer the integer nearest the receiver." self >= 0.0 ifTrue: [^(self + 0.5) truncated] ifFalse: [^(self - 0.5) truncated]! ! !MFloat methodsFor: 'truncation and round off' stamp: 'tao 4/19/98 13:14'! significand ^ self timesTwoPower: (self exponent negated)! ! !MFloat methodsFor: 'truncation and round off' stamp: 'jm 10/28/2003 12:59'! truncated "Answer with a SmallInteger equal to the value of the receiver without its fractional part. The primitive fails if the truncated value cannot be represented as a SmallInteger. In that case, the code below will compute a LargeInteger truncated value. Essential. See Object documentation whatIsAPrimitive. " <primitive: 51> (self isInfinite or: [self isNaN]) ifTrue: [self error: 'Cannot truncate this number']. self abs < 2.0e16 ifTrue: ["Fastest way when it may not be an integer" ^ (self quo: 1073741823.0) * 1073741823 + (self rem: 1073741823.0) truncated] ifFalse: [^ self error: 'not yet implemented']! ! !MFloat methodsFor: 'converting' stamp: 'jm 12/2/2003 21:40'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Float." ^ rcvr asFloat perform: selector with: self ! ! !MFloat methodsFor: 'converting'! asFloat "Answer the receiver itself." ^self! ! !MFloat methodsFor: 'converting'! degreesToRadians "Answer the receiver in radians. Assumes the receiver is in degrees." ^self * RadiansPerDegree! ! !MFloat methodsFor: 'converting'! radiansToDegrees "Answer the receiver in degrees. Assumes the receiver is in radians." ^self / RadiansPerDegree! ! !MFloat methodsFor: 'printing' stamp: 'jm 11/13/2002 16:31'! absPrintOn: aStream base: base "Print my value on a stream in the given base. Assumes that my value is strictly positive; negative numbers, zero, and NaNs have already been handled elsewhere. Based upon the algorithm outlined in: Robert G. Burger and R. Kent Dybvig Printing Floating Point Numbers Quickly and Accurately ACM SIGPLAN 1996 Conference on Programming Language Design and Implementation June 1996. This version performs all calculations with Floats instead of LargeIntegers, and loses about 3 lsbs of accuracy compared to an exact conversion." | significantBits fBase exp baseExpEstimate r s mPlus mMinus scale d tc1 tc2 fixedFormat decPointCount | self isInfinite ifTrue: [aStream nextPutAll: 'Infinity'. ^ self]. significantBits _ 50. "approximately 3 lsb's of accuracy loss during conversion" fBase _ base asFloat. exp _ self exponent. baseExpEstimate _ (exp * fBase reciprocalLogBase2 - 1.0e-10) ceiling. exp >= 0 ifTrue: [r _ self. s _ 1.0. mPlus _ 1.0 timesTwoPower: exp - significantBits. mMinus _ self significand ~= 1.0 ifTrue: [mPlus] ifFalse: [mPlus / 2.0]] ifFalse: [r _ self timesTwoPower: significantBits. s _ 1.0 timesTwoPower: significantBits. mMinus _ 1.0 timesTwoPower: (exp max: -1024). mPlus _ (exp = MinValLogBase2) | (self significand ~= 1.0) ifTrue: [mMinus] ifFalse: [mMinus * 2.0]]. baseExpEstimate >= 0 ifTrue: [s _ s * (fBase raisedToInteger: baseExpEstimate). exp = 1023 ifTrue: "scale down to prevent overflow to Infinity during conversion" [r _ r / fBase. s _ s / fBase. mPlus _ mPlus / fBase. mMinus _ mMinus / fBase]] ifFalse: [exp < -1023 ifTrue: "scale up to prevent denorm reciprocals overflowing to Infinity" [d _ (53 * fBase reciprocalLogBase2 - 1.0e-10) ceiling. scale _ fBase raisedToInteger: d. r _ r * scale. mPlus _ mPlus * scale. mMinus _ mMinus * scale. scale _ fBase raisedToInteger: (baseExpEstimate + d) negated] ifFalse: [scale _ fBase raisedToInteger: baseExpEstimate negated]. s _ s / scale]. (r + mPlus >= s) ifTrue: [baseExpEstimate _ baseExpEstimate + 1] ifFalse: [s _ s / fBase]. (fixedFormat _ baseExpEstimate between: -3 and: 6) ifTrue: [decPointCount _ baseExpEstimate. baseExpEstimate <= 0 ifTrue: [aStream nextPutAll: ('0.000000' truncateTo: 2 - baseExpEstimate)]] ifFalse: [decPointCount _ 1]. [d _ (r / s) truncated. r _ r - (d * s). (tc1 _ r <= mMinus) | (tc2 _ r + mPlus >= s)] whileFalse: [aStream nextPut: (MCharacter digitValue: d). r _ r * fBase. mPlus _ mPlus * fBase. mMinus _ mMinus * fBase. decPointCount _ decPointCount - 1. decPointCount = 0 ifTrue: [aStream nextPut: $.]]. tc2 ifTrue: [tc1 not | (tc1 & (r*2.0 >= s)) ifTrue: [d _ d + 1]]. aStream nextPut: (MCharacter digitValue: d). decPointCount > 0 ifTrue: [decPointCount - 1 to: 1 by: -1 do: [:i | aStream nextPut: $0]. aStream nextPutAll: '.0']. fixedFormat ifFalse: [aStream nextPut: $e. aStream nextPutAll: (baseExpEstimate - 1) printString]! ! !MFloat methodsFor: 'printing' stamp: 'tao 4/19/98 23:31'! printOn: aStream base: base "Handle sign, zero, and NaNs; all other values passed to absPrintOn:base:" self isNaN ifTrue: [aStream nextPutAll: 'NaN'. ^ self]. "check for NaN before sign" self > 0.0 ifTrue: [self absPrintOn: aStream base: base] ifFalse: [self sign = -1 ifTrue: [aStream nextPutAll: '-']. self = 0.0 ifTrue: [aStream nextPutAll: '0.0'. ^ self] ifFalse: [self negated absPrintOn: aStream base: base]]! ! !MFloat class methodsFor: 'class initialization' stamp: 'jm 4/30/1998 13:48'! initialize "Float initialize" "Constants from Computer Approximations, pp. 182-183: Pi = 3.14159265358979323846264338327950288 Pi/2 = 1.57079632679489661923132169163975144 Pi*2 = 6.28318530717958647692528676655900576 Pi/180 = 0.01745329251994329576923690768488612 2.0 ln = 0.69314718055994530941723212145817657 2.0 sqrt = 1.41421356237309504880168872420969808" Pi _ 3.14159265358979323846264338327950288. Halfpi _ Pi / 2.0. Twopi _ Pi * 2.0. RadiansPerDegree _ Pi / 180.0. Ln2 _ 0.69314718055994530941723212145817657. Ln10 _ 10.0 ln. Sqrt2 _ 1.41421356237309504880168872420969808. E _ 2.718281828459045235360287471353. Epsilon _ 0.000000000001. "Defines precision of mathematical functions" MaxVal _ 1.7976931348623159e308. MaxValLn _ 709.782712893384. MinValLogBase2 _ -1074. Infinity _ MaxVal * MaxVal. NegativeInfinity _ 0.0 - Infinity. NaN _ Infinity - Infinity. NegativeZero _ 1.0 / Infinity negated. ! ! !MFloat class methodsFor: 'instance creation' stamp: 'jm 11/26/2003 20:10'! readFrom: aStream "Answer a new Float as described on the stream, aStream." ^ (MNumber readFrom: aStream) asFloat ! ! !MFloat class methodsFor: 'constants'! pi "Answer the constant, Pi." ^Pi! ! !MForm methodsFor: 'initialization' stamp: 'jm 12/29/2003 11:18'! setWidth: w height: h depth: d | wordsPerLine | wordsPerLine _ ((w * d) + 31) // 32. bits _ MByteArray new: (4 * wordsPerLine * h). width _ w. height _ h. depth _ d. bitBlt _ MBitBlt new destForm: self; fillR: 255 g: 0 b: 0. "default color" ! ! !MForm methodsFor: 'accessing' stamp: 'jm 12/11/2003 08:21'! bits ^ bits ! ! !MForm methodsFor: 'accessing' stamp: 'jm 12/15/2003 22:39'! copyX: x y: y width: w height: h "Answer a new form containing given rectangular portion of this form." | result | result _ MForm basicNew setWidth: w height: h depth: depth. MBitBlt new sourceForm: self; destForm: result; sourceX: x y: y; width: w height: h; copyBits. ^ result ! ! !MForm methodsFor: 'accessing' stamp: 'jm 12/11/2003 08:21'! depth ^ depth ! ! !MForm methodsFor: 'accessing' stamp: 'jm 12/11/2003 08:21'! height ^ height ! ! !MForm methodsFor: 'accessing' stamp: 'jm 12/11/2003 08:21'! width ^ width ! ! !MForm methodsFor: 'drawing' stamp: 'jm 12/14/2003 17:56'! drawForm: aForm x: x y: y rule: anInteger "Fill the given rectangle with the current fill color." | oldFill | oldFill _ bitBlt fillWords. bitBlt sourceForm: aForm; destX: x y: y width: aForm width height: aForm height; rule: anInteger; copyBits. bitBlt sourceForm: nil. bitBlt fillWords: oldFill. ! ! !MForm methodsFor: 'drawing' stamp: 'jm 12/14/2003 17:57'! fillRectX: x y: y w: w h: h "Fill the given rectangle with the current fill color." bitBlt destX: x y: y width: w height: h; copyBits. ! ! !MForm methodsFor: 'drawing' stamp: 'jm 12/14/2003 17:57'! setColorR: r g: g b: b "Set the fill color for rectangle drawing operations." bitBlt fillR: r g: g b: b. ! ! !MForm methodsFor: 'display' stamp: 'jm 12/29/2003 21:35'! beDisplayDepth: d "Install myself as the Display. Drawing onto me will then cause the screen or window to be updated." | screenExtent | screenExtent _ self primScreenSize. self setWidth: (screenExtent instVarAt: 1) height: (screenExtent instVarAt: 2) depth: d. MSystem specialObjectsArray at: 15 put: self. "make this Form the Display" ! ! !MForm methodsFor: 'display' stamp: 'jm 12/29/2003 11:05'! primScreenSize "Answer the actual screen size. In MicroSqueak, this will be an Association object since MicroSqueak doesn't have Points." <primitive: 106> self primitiveFailed ! ! !MForm class methodsFor: 'instance creation' stamp: 'jm 12/11/2003 08:15'! width: w height: h depth: d ^ self basicNew setWidth: w height: h depth: d ! ! !MForm class methodsFor: 'constants' stamp: 'jm 12/29/2003 11:16'! over ^ 3 ! ! !MForm class methodsFor: 'constants' stamp: 'jm 12/29/2003 11:16'! paint ^ 25 ! ! I am used to send a MIDI controller value. ! !MIDIControllerMorph methodsFor: 'initialization' stamp: 'jm 9/28/1998 22:38'! initialize | slider | super initialize. orientation _ #vertical. centering _ #center. hResizing _ vResizing _ #shrinkWrap. self color: (Color r: 0.484 g: 0.613 b: 0.0). self borderWidth: 1. channel _ 0. controller _ 7. "channel volume" slider _ SimpleSliderMorph new target: self; actionSelector: #newSliderValue:; minVal: 0; maxVal: 127; extent: 128@10. self addMorphBack: slider. self addMorphBack: (StringMorph contents: 'Midi Controller'). self updateLabel. ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'! channel ^ channel ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'! channel: anInteger channel _ anInteger. lastValue _ nil. self updateLabel. ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:35'! controller ^ controller ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:40'! controller: anInteger controller _ anInteger. lastValue _ nil. self updateLabel. ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:54'! midiPort ^ midiPort ! ! !MIDIControllerMorph methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:55'! midiPort: anInteger midiPort _ anInteger. ! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/28/1998 22:47'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'set channel' action: #setChannel:. aCustomMenu add: 'set controller' action: #setController:. ! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:06'! controllerList "Answer a list of controller name, number pairs to be used in the menu." ^ #((1 modulation) (2 'breath control') (7 volume) (10 pan) (11 expression) (92 'tremolo depth') (93 'chorus depth') (94 'celeste depth') (95 'phaser depth')) ! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'jm 9/29/1998 09:09'! controllerName: controllerNumber "Answer a name for the given controller. If no name is available, use the form 'CC5' (CC is short for 'continuous controller')." self controllerList do: [:pair | pair first = controllerNumber ifTrue: [^ pair last]]. ^ 'CC', controllerNumber asString ! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'sma 6/5/2000 13:29'! setChannel: evt | menu | menu _ MenuMorph new. 1 to: 16 do: [:chan | menu add: chan printString target: self selector: #channel: argumentList: (Array with: chan - 1)]. menu popUpEvent: evt! ! !MIDIControllerMorph methodsFor: 'menu' stamp: 'sma 6/5/2000 13:29'! setController: evt | menu | menu _ MenuMorph new. self controllerList do: [:pair | menu add: (pair last) target: self selector: #controller: argumentList: (Array with: pair first)]. menu popUpEvent: evt! ! !MIDIControllerMorph methodsFor: 'other' stamp: 'jm 10/12/1998 16:02'! newSliderValue: newValue "Send a control command out the MIDI port." | val | midiPort ifNil: [^ self]. val _ newValue asInteger. lastValue = val ifTrue: [^ self]. lastValue _ val. midiPort midiCmd: 16rB0 channel: channel byte: controller byte: val. ! ! !MIDIControllerMorph methodsFor: 'other' stamp: 'jm 9/29/1998 09:10'! updateLabel | label | (label _ self findA: StringMorph) ifNil: [^ self]. label contents: (self controllerName: controller), ', ch: ', (channel + 1) printString. ! ! !MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 9/27/1998 21:44'! readHeaderChunk | chunkType chunkSize division | chunkType _ self readChunkType. chunkType = 'RIFF' ifTrue:[chunkType _ self riffSkipToMidiChunk]. chunkType = 'MThd' ifFalse: [self scanForMIDIHeader]. chunkSize _ self readChunkSize. fileType _ self next16BitWord. trackCount _ self next16BitWord. division _ self next16BitWord. (division anyMask: 16r8000) ifTrue: [self error: 'SMPTE time formats are not yet supported'] ifFalse: [ticksPerQuarter _ division]. maxNoteTicks _ 12 * 4 * ticksPerQuarter. "longest acceptable note; used to detect stuck notes" "sanity checks" ((chunkSize < 6) or: [chunkSize > 100]) ifTrue: [self error: 'unexpected MIDI header size ', chunkSize printString]. (#(0 1 2) includes: fileType) ifFalse: [self error: 'unknown MIDI file type ', fileType printString]. Transcript show: 'Reading Type ', fileType printString, ' MIDI File ('; show: trackCount printString, ' tracks, '; show: ticksPerQuarter printString, ' ticks per quarter note)'; cr. ! ! !MIDIFileReader methodsFor: 'chunk reading' stamp: 'jm 9/12/1998 19:08'! readMIDIFrom: aBinaryStream "Read one or more MIDI tracks from the given binary stream." stream _ aBinaryStream. tracks _ OrderedCollection new. trackInfo _ OrderedCollection new. self readHeaderChunk. trackCount timesRepeat: [self readTrackChunk]. stream atEnd ifFalse: [self report: 'data beyond final track']. fileType = 0 ifTrue: [self splitIntoTracks]. self guessMissingInstrumentNames. ! ! !MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/27/1998 22:15'! metaEventAt: ticks "Read a meta event. Event types appear roughly in order of expected frequency." | type length tempo | type _ trackStream next. length _ self readVarLengthIntFrom: trackStream. type = 16r51 ifTrue: [ "tempo" tempo _ 0. length timesRepeat: [tempo _ (tempo bitShift: 8) + trackStream next]. track add: (TempoEvent new tempo: tempo; time: ticks). ^ self]. type = 16r2F ifTrue: [ "end of track" length = 0 ifFalse: [self error: 'length of end-of-track chunk should be zero']. self endAllNotesAt: ticks. trackStream skip: length. ^ self]. type = 16r58 ifTrue: [ "time signature" length = 4 ifFalse: [self error: 'length of time signature chunk should be four']. trackStream skip: length. ^ self]. type = 16r59 ifTrue: [ "key signature" length = 2 ifFalse: [self error: 'length of key signature chunk should be two']. trackStream skip: length. ^ self]. ((type >= 1) and: [type <= 7]) ifTrue: [ "string" strings add: (trackStream next: length) asString. ^ self]. ( type = 16r21 or: "mystery; found in MIDI files but not in MIDI File 1.0 Spec" [(type = 16r7F) or: "sequencer specific meta event" [(type = 16r00) or: "sequence number" [(type = 16r20)]]]) "MIDI channel prefix" ifTrue: [ trackStream skip: length. ^ self]. type = 16r54 ifTrue: [ "SMPTE offset" self report: 'Ignoring SMPTE offset'. trackStream skip: length. ^ self]. "skip unrecognized meta event" self report: 'skipping unrecognized meta event: ', (type printStringBase: 16), ' (', length printString, ' bytes)'. trackStream skip: length. ! ! !MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:10'! readTrackContents: byteCount | info | strings _ OrderedCollection new. track _ OrderedCollection new. trackStream _ ReadStream on: (stream next: byteCount). activeEvents _ OrderedCollection new. self readTrackEvents. (tracks isEmpty and: [self isTempoTrack: track]) ifTrue: [tempoMap _ track asArray] ifFalse: [ "Note: Tracks without note events are currently not saved to eliminate clutter in the score player. In control applications, this can be easily changed by modifying the following test." (self trackContainsNotes: track) ifTrue: [ tracks add: track asArray. info _ WriteStream on: (String new: 100). strings do: [:s | info nextPutAll: s; cr]. trackInfo add: info contents]]. strings _ track _ trackStream _ activeEvents _ nil. ! ! !MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/10/1998 09:57'! readTrackEvents "Read the events of the current track." | cmd chan key vel ticks byte length evt | cmd _ #unknown. chan _ key _ vel _ 0. ticks _ 0. [trackStream atEnd] whileFalse: [ ticks _ ticks + (self readVarLengthIntFrom: trackStream). byte _ trackStream next. byte >= 16rF0 ifTrue: [ "meta or system exclusive event" byte = 16rFF ifTrue: [self metaEventAt: ticks]. ((byte = 16rF0) or: [byte = 16rF7]) ifTrue: [ "system exclusive data" length _ self readVarLengthIntFrom: trackStream. trackStream skip: length]. cmd _ #unknown] ifFalse: [ "channel message event" byte >= 16r80 ifTrue: [ "new command" cmd _ byte bitAnd: 16rF0. chan _ byte bitAnd: 16r0F. key _ trackStream next] ifFalse: [ "use running status" cmd == #unknown ifTrue: [self error: 'undefined running status; bad MIDI file?']. key _ byte]. ((cmd = 16rC0) or: [cmd = 16rD0]) ifFalse: [ "all but program change and channel pressure have two data bytes" vel _ trackStream next]. cmd = 16r80 ifTrue: [ "note off" self endNote: key chan: chan at: ticks]. cmd = 16r90 ifTrue: [ "note on" vel = 0 ifTrue: [self endNote: key chan: chan at: ticks] ifFalse: [self startNote: key vel: vel chan: chan at: ticks]]. "cmd = 16A0 -- polyphonic key pressure; skip" cmd = 16rB0 ifTrue: [ evt _ ControlChangeEvent new control: key value: vel channel: chan. evt time: ticks. track add: evt]. cmd = 16rC0 ifTrue: [ evt _ ProgramChangeEvent new program: key channel: chan. evt time: ticks. track add: evt]. "cmd = 16D0 -- channel aftertouch pressure; skip" cmd = 16rE0 ifTrue: [ evt _ PitchBendEvent new bend: key + (vel bitShift: 7) channel: chan. evt time: ticks. track add: evt] ]]. ! ! !MIDIFileReader methodsFor: 'track reading' stamp: 'jm 9/12/1998 17:15'! trackContainsNotes: eventList "Answer true if the given track contains at least one note event." eventList do: [:e | e isNoteEvent ifTrue: [^ true]]. ^ false ! ! !MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 20:00'! guessMissingInstrumentNames "Attempt to guess missing instrument names from the first program change in that track." | progChange instrIndex instrName | 1 to: tracks size do: [:i | (trackInfo at: i) isEmpty ifTrue: [ progChange _ (tracks at: i) detect: [:e | e isProgramChange] ifNone: [nil]. progChange ifNotNil: [ instrIndex _ progChange program + 1. instrName _ self class standardMIDIInstrumentNames at: instrIndex. trackInfo at: i put: instrName]]]. ! ! !MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 17:32'! readChunkType "Read a chunk ID string from the next 4 bytes." "Assume: Stream has at least four bytes left." | s | s _ String new: 4. 1 to: 4 do: [:i | s at: i put: (stream next) asCharacter]. ^ s ! ! !MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 19:19'! scanForMIDIHeader "Scan the first part of this file in search of the MIDI header string 'MThd'. Report an error if it is not found. Otherwise, leave the input stream positioned to the first byte after this string." | asciiM p lastSearchPosition byte restOfHeader | asciiM _ $M asciiValue. stream skip: -3. p _ stream position. lastSearchPosition _ p + 10000. "search only the first 10000 bytes of the file" [p < lastSearchPosition and: [stream atEnd not]] whileTrue: [ [(byte _ stream next) ~= asciiM and: [byte ~~ nil]] whileTrue. "find the next 'M' or file end" restOfHeader _ (stream next: 3) asString. restOfHeader = 'Thd' ifTrue: [^ self] ifFalse: [restOfHeader size = 3 ifTrue: [stream skip: -3]]. p _ stream position]. self error: 'MIDI header chunk not found'. ! ! !MIDIFileReader methodsFor: 'private' stamp: 'jm 9/12/1998 20:10'! splitIntoTracks "Split a type zero MIDI file into separate tracks by channel number." | newTempoMap newTracks | tracks size = 1 ifFalse: [self error: 'expected exactly one track in type 0 file']. tempoMap ifNotNil: [self error: 'did not expect a tempo map in type 0 file']. newTempoMap _ OrderedCollection new. newTracks _ (1 to: 16) collect: [:i | OrderedCollection new]. tracks first do: [:e | e isTempoEvent ifTrue: [newTempoMap addLast: e] ifFalse: [(newTracks at: e channel + 1) addLast: e]]. newTempoMap size > 0 ifTrue: [tempoMap _ newTempoMap asArray]. newTracks _ newTracks select: [:t | self trackContainsNotes: t]. tracks _ newTracks collect: [:t | t asArray]. trackInfo _ trackInfo, ((2 to: tracks size) collect: [:i | '']). ! ! !MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'! playStream: binaryStream ScorePlayerMorph openOn: (self scoreFromStream: binaryStream) title: 'a MIDI stream' ! ! !MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 5/29/1998 17:12'! playURLNamed: urlString | titleString | titleString _ urlString copyFrom: (urlString findLast: [:c | c=$/]) + 1 to: urlString size. ScorePlayerMorph openOn: (self scoreFromURL: urlString) title: titleString. ! ! !MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'ls 8/8/1998 03:14'! scoreFromStream: binaryStream | score | score _ (self new readMIDIFrom: binaryStream) asScore. ^ score ! ! !MIDIFileReader class methodsFor: 'as yet unclassified' stamp: 'jm 9/12/1998 19:57'! standardMIDIInstrumentNames "Answer an array of Standard MIDI instrument names." ^ #( 'Grand Piano' 'Bright Piano' 'Electric Grand Piano' 'Honky-tonk Piano' 'Electric Piano 1' 'Electric Piano 2' 'Harpsichord' 'Clavichord' 'Celesta' 'Glockenspiel' 'Music Box' 'Vibraphone' 'Marimba' 'Xylophone' 'Tubular Bells' 'Duclimer' 'Drawbar Organ' 'Percussive Organ' 'Rock Organ' 'Church Organ' 'Reed Organ' 'Accordion' 'Harmonica' 'Tango Accordion' 'Nylon Guitar' 'Steel Guitar' 'Electric Guitar 1' 'Electric Guitar 2' 'Electric Guitar 3' 'Overdrive Guitar' 'Distorted Guitar' 'Guitar Harmonics' 'Acoustic Bass' 'Electric Bass 1' 'Electric Bass 2' 'Fretless Bass' 'Slap Bass 1' 'Slap Bass 2' 'Synth Bass 1' 'Synth Bass 2' 'Violin' 'Viola' 'Cello' 'Contrabass' 'Tremolo Strings' 'Pizzicato Strings' 'Orchestral Harp' 'Timpani' 'String Ensemble 1' 'String Ensemble 2' 'Synth Strings 1' 'Synth Strings 2' 'Choir Ahhs' 'Choir Oohs' 'Synth Voice' 'Orchestra Hit' 'Trumpet' 'Trombone' 'Tuba' 'Muted Trumpet' 'French Horn' 'Brass Section' 'Synth Brass 1' 'Synth Brass 2' 'Soprano Sax' 'Alto Sax' 'Tenor Sax' 'Baritone Sax' 'Oboe' 'English Horn' 'Bassoon' 'Clarinet' 'Piccolo' 'Flute' 'Recorder' 'Pan Flute' 'Blown Bottle' 'Shakuhachi' 'Whistle' 'Ocarina' 'Lead 1 (square)' 'Lead 2 (sawtooth)' 'Lead 3 (calliope)' 'Lead 4 (chiff)' 'Lead 5 (charang)' 'Lead 6 (voice)' 'Lead 7 (fifths)' 'Lead 8 (bass+lead)' 'Pad 1 (new age)' 'Pad 2 (warm)' 'Pad 3 (polysynth)' 'Pad 4 (choir)' 'Pad 5 (bowed)' 'Pad 6 (metallic)' 'Pad 7 (halo)' 'Pad 8 (sweep)' 'FX 1 (rain)' 'FX 2 (soundtrack)' 'FX 3 (crystals)' 'FX 4 (atmosphere)' 'FX 5 (brightness)' 'FX 6 (goblins)' 'FX 7 (echoes)' 'FX 8 (sci-fi)' 'Sitar' 'Banjo' 'Shamisen' 'Koto' 'Kalimba' 'Bagpipe' 'Fiddle' 'Shanai' 'Tinkle Bell' 'Agogo' 'Steel Drum' 'Woodblock' 'Taiko Drum' 'Melodic Tom' 'Synth Drum' 'Reverse Cymbal' 'Guitar Fret Noise' 'Breath Noise' 'Seashore' 'Bird Tweet' 'Telephone Ring' 'Helicopter' 'Applause' 'Gunshot') ! ! I am a parser for a MIDI data stream. I support: real-time MIDI recording, overdubbing (recording while playing), monitoring incoming MIDI, and interactive MIDI performances. Note: MIDI controllers such as pitch benders and breath controllers generate large volumes of data which consume processor time. In cases where this information is not of interest to the program using it, it is best to filter it out as soon as possible. I support various options for doing this filtering, including filtering by MIDI channel and/or by command type. ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:39'! ignoreChannel: channel "Don't record any events arriving on the given MIDI channel (in the range 1-16)." ((channel isInteger not) | (channel < 1) | (channel > 16)) ifTrue: [^ self error: 'bad MIDI channel number', channel printString]. "two-arg channel messages" #(128 144 160 176 224) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreTwo:]. "one-arg channel messages" #(192 208) do: [:i | cmdActionTable at: (i bitOr: channel - 1) put: #ignoreOne:]. ! ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:40'! ignoreCommand: midiCmd "Don't record the given MIDI command on any channel." | cmd sel | ((midiCmd isInteger not) | (midiCmd < 128) | (midiCmd > 255)) ifTrue: [^ self error: 'bad MIDI command']. midiCmd < 240 ifTrue: [ "channel commands; ignore on all channels" cmd _ midiCmd bitAnd: 2r11110000. sel _ (#(128 144 160 176 224) includes: cmd) ifTrue: [#ignoreTwo:] ifFalse: [#ignoreOne:]. 1 to: 16 do: [:ch | cmdActionTable at: (cmd bitOr: ch - 1) put: sel]. ^ self]. (#(240 241 244 245 247 249 253) includes: midiCmd) ifTrue: [ ^ self error: 'You can''t ignore the undefined MIDI command: ', midiCmd printString]. midiCmd = 242 ifTrue: [ "two-arg command" cmdActionTable at: midiCmd put: #ignoreTwo:. ^ self]. midiCmd = 243 ifTrue: [ "one-arg command" cmdActionTable at: midiCmd put: #ignoreOne:. ^ self]. (#(246 248 250 251 252 254 255) includes: midiCmd) ifTrue: [ "zero-arg command" cmdActionTable at: midiCmd put: #ignore. ^ self]. "we should not get here" self error: 'implementation error'. ! ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:38'! ignoreSysEx: aBoolean "If the argument is true, then ignore incoming system exclusive message." ignoreSysEx _ aBoolean. ! ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:46'! ignoreTuneAndRealTimeCommands "Ignore tuning requests and real-time commands." cmdActionTable at: 246 put: #ignoreZero:. "tune request" cmdActionTable at: 248 put: #ignoreZero:. "timing clock" cmdActionTable at: 250 put: #ignoreZero:. "start" cmdActionTable at: 251 put: #ignoreZero:. "continue" cmdActionTable at: 252 put: #ignoreZero:. "stop/Clock" cmdActionTable at: 254 put: #ignoreZero:. "active sensing" cmdActionTable at: 255 put: #ignoreZero:. "system reset" ! ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/8/1998 20:37'! noFiltering "Revert to accepting all MIDI commands on all channels. This undoes any earlier request to filter the incoming MIDI stream." cmdActionTable _ DefaultMidiTable deepCopy. ignoreSysEx _ false. ! ! !MIDIInputParser methodsFor: 'midi filtering' stamp: 'jm 10/9/1998 07:50'! recordOnlyChannels: channelList "Record only MIDI data arriving on the given list of channel numbers (in the range 1-16)." channelList do: [:ch | ((ch isInteger not) | (ch < 1) | (ch > 16)) ifTrue: [^ self error: 'bad Midi channel specification: ', ch printString]]. 1 to: 16 do: [:ch | (channelList includes: ch) ifFalse: [self ignoreChannel: ch]]. ! ! !MIDIInputParser methodsFor: 'recording' stamp: 'jm 1/6/1999 08:24'! clearBuffers "Clear the MIDI record buffers. This should be called at the start of recording or real-time MIDI processing." received _ received species new: 5000. rawDataBuffer _ ByteArray new: 1000. sysExBuffer _ WriteStream on: (ByteArray new: 100). midiPort ifNotNil: [midiPort ensureOpen; flushInput]. startTime _ Time millisecondClockValue. state _ #idle. ! ! !MIDIInputParser methodsFor: 'recording' stamp: 'jm 10/8/1998 21:06'! processMIDIData "Process all MIDI data that has arrived since the last time this method was executed. This method should be called frequently to process, filter, and timestamp MIDI data as it arrives." | bytesRead | [(bytesRead _ midiPort readInto: rawDataBuffer) > 0] whileTrue: [ timeNow _ (midiPort bufferTimeStampFrom: rawDataBuffer) - startTime. 5 to: bytesRead do: [:i | self processByte: (rawDataBuffer at: i)]]. ! ! !MIDIInputParser methodsFor: 'recording' stamp: 'jm 10/8/1998 20:24'! received "Answer my current collection of all MIDI commands received. Items in this list have the form (<time><cmd byte>[<arg1>[<arg2>]]). Note that the real-time processing facility, midiDo:, removes items from this list as it processes them." ^ received ! ! !MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/9/1998 07:53'! midiDo: aBlock "Poll the incoming MIDI stream in real time and call the given block for each complete command that has been received. The block takes one argument, which is an array of the form (<time><cmd byte>[<arg1>[<arg2>]]). The number of arguments depends on the command byte. For system exclusive commands, the argument is a ByteArray containing the system exclusive message." self processMIDIData. [received isEmpty] whileFalse: [aBlock value: received removeFirst]. ! ! !MIDIInputParser methodsFor: 'real-time processing' stamp: 'jm 10/8/1998 21:21'! midiDoUntilMouseDown: midiActionBlock "Process the incoming MIDI stream in real time by calling midiActionBlock for each MIDI event. This block takes three arguments: the MIDI command byte and two argument bytes. One or both argument bytes may be nil, depending on the MIDI command. If not nil, evaluatue idleBlock regularly whether MIDI data is available or not. Pressing any mouse button terminates the interaction." | time cmd arg1 arg2 | self clearBuffers. [Sensor anyButtonPressed] whileFalse: [ self midiDo: [:item | time _ item at: 1. cmd _ item at: 2. arg1 _ arg2 _ nil. item size > 2 ifTrue: [ arg1 _ item at: 3. item size > 3 ifTrue: [arg2 _ item at: 4]]. midiActionBlock value: cmd value: arg1 value: arg2]]. ! ! !MIDIInputParser methodsFor: 'midi monitor' stamp: 'jm 10/8/1998 21:22'! monitor "Print MIDI messages to the transcript until any mouse button is pressed." self midiDoUntilMouseDown: [:cmd :arg1 :arg2 | self printCmd: cmd with: arg1 with: arg2]. ! ! !MIDIInputParser methodsFor: 'midi monitor' stamp: 'jm 10/9/1998 10:19'! printCmd: cmdByte with: arg1 with: arg2 "Print the given MIDI command." | cmd ch bend | cmdByte < 240 ifTrue: [ "channel message" cmd _ cmdByte bitAnd: 2r11110000. ch _ (cmdByte bitAnd: 2r00001111) + 1] ifFalse: [cmd _ cmdByte]. "system message" cmd = 128 ifTrue: [ ^ Transcript show: ('key up ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr]. cmd = 144 ifTrue: [ ^ Transcript show: ('key down: ', arg1 printString, ' vel: ', arg2 printString, ' chan: ', ch printString); cr]. cmd = 160 ifTrue: [ ^ Transcript show: ('key pressure: ', arg1 printString, ' val: ', arg2 printString, ' chan: ', ch printString); cr]. cmd = 176 ifTrue: [ ^ Transcript show: ('CC', arg1 printString, ': val: ', arg2 printString, ' chan: ', ch printString); cr]. cmd = 192 ifTrue: [ ^ Transcript show: ('prog: ', (arg1 + 1) printString, ' chan: ', ch printString); cr]. cmd = 208 ifTrue: [ ^ Transcript show: ('channel pressure ', arg1 printString, ' chan: ', ch printString); cr]. cmd = 224 ifTrue: [ bend _ ((arg2 bitShift: 7) + arg1) - 8192. ^ Transcript show: ('bend: ', bend printString, ' chan: ', ch printString); cr]. cmd = 240 ifTrue: [ ^ Transcript show: ('system exclusive: ', (arg1 at: 1) printString, ' (', arg1 size printString, ' bytes)'); cr]. Transcript show: 'cmd: ', cmd printString, ' arg1: ', arg1 printString, ' arg2: ', arg2 printString; cr. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 18:34'! endSysExclusive: cmdByte "Error!! Received 'end system exclusive' command when not receiving system exclusive data." self error: 'unexpected ''End of System Exclusive'' command'. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! ignoreOne: cmdByte "Ignore a one argument command." lastCmdByte _ cmdByte. lastSelector _ #ignoreOne:. state _ #ignore1. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! ignoreTwo: cmdByte "Ignore a two argument command." lastCmdByte _ cmdByte. lastSelector _ #ignoreTwo:. state _ #ignore2. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:45'! ignoreZero: cmdByte "Ignore a zero argument command, such as tune request or a real-time message. Stay in the current and don't change active status. Note that real-time messages can arrive between data bytes without disruption." "do nothing" ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 09:36'! processByte: aByte "Process the given incoming MIDI byte and record completed commands." "Details: Because this must be fast, it has been hand-tuned. Be careful!!" aByte > 247 ifTrue: [ "real-time message; can arrive at any time" ^ self perform: (cmdActionTable at: aByte) with: aByte]. #idle = state ifTrue: [ aByte >= 128 ifTrue: [ "command byte in idle state: start new command" ^ self perform: (cmdActionTable at: aByte) with: aByte] ifFalse: [ "data byte in idle state: use running status if possible" lastCmdByte ifNil: [^ self]. "running status unknown; skip byte" "process this data as if it had the last command byte in front of it" self perform: lastSelector with: lastCmdByte. "the previous line put us into a new state; we now 'fall through' to process the data byte given this new state."]]. #ignore1 = state ifTrue: [^ state _ #idle]. #ignore2 = state ifTrue: [^ state _ #ignore1]. #want1of2 = state ifTrue: [ argByte1 _ aByte. ^ state _ #want2of2]. #want2of2 = state ifTrue: [ argByte2 _ aByte. received addLast: (Array with: timeNow with: lastCmdByte with: argByte1 with: argByte2). ^ state _ #idle]. #want1only = state ifTrue: [ argByte1 _ aByte. received addLast: (Array with: timeNow with: lastCmdByte with: argByte1). ^ state _ #idle]. #sysExclusive = state ifTrue: [ aByte < 128 ifTrue: [ "record a system exclusive data byte" ignoreSysEx ifFalse: [sysExBuffer nextPut: aByte]. ^ self] ifFalse: [ aByte < 248 ifTrue: [ "a system exclusive message is terminated by any non-real-time command byte" ignoreSysEx ifFalse: [ received addLast: (Array with: timeNow with: lastCmdByte with: sysExBuffer contents)]. state _ #idle. aByte = 247 ifTrue: [^ self] "endSysExclusive command, nothing left to do" ifFalse: [^ self processByte: aByte]]]]. "no endSysExclusive; just start the next command" ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! recordOne: cmdByte "Record a one argument command at the current time." lastCmdByte _ cmdByte. lastSelector _ #recordOne:. state _ #want1only. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 19:24'! recordTwo: cmdByte "Record a two argument command at the current time." lastCmdByte _ cmdByte. lastSelector _ #recordTwo:. state _ #want1of2. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 07:43'! recordZero: cmdByte "Record a zero-byte message, such as tune request or a real-time message. Don't change active status. Note that real-time messages can arrive between data bytes without disruption." received addLast: (Array with: timeNow with: cmdByte). ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/9/1998 09:38'! startSysExclusive: cmdByte "The beginning of a variable length 'system exclusive' command." sysExBuffer resetContents. lastCmdByte _ nil. "system exclusive commands clear running status" lastSelector _ nil. state _ #sysExclusive. ! ! !MIDIInputParser methodsFor: 'private-state machine' stamp: 'jm 10/8/1998 17:12'! undefined: cmdByte "We have received an unexpected MIDI byte (e.g., a data byte when we were expecting a command). This should never happen." self error: 'unexpected MIDI byte ', cmdByte printString. ! ! !MIDIInputParser methodsFor: 'private-other' stamp: 'jm 10/9/1998 07:56'! setMIDIPort: aMIDIPort "Initialize this instance for recording from the given MIDI port. Tune and real-time commands are filtered out by default; the client can send noFiltering to receive these messages." midiPort _ aMIDIPort. received _ OrderedCollection new. self noFiltering. "initializes cmdActionTable" self ignoreTuneAndRealTimeCommands. ! ! !MIDIInputParser methodsFor: 'accessing' stamp: 'jm 1/6/1999 08:25'! midiPort ^ midiPort ! ! !MIDIInputParser methodsFor: 'accessing' stamp: 'jm 1/6/1999 08:24'! midiPort: aMIDIPort "Use the given MIDI port." midiPort _ aMIDIPort. self clearBuffers. ! ! !MIDIInputParser class methodsFor: 'class initialization' stamp: 'jm 10/9/1998 07:35'! initialize "Build the default MIDI command-byte action table. This table maps MIDI command bytes to the action to be performed when that is received. Note that MIDI data bytes (bytes whose value is < 128) are never used to index into this table." "MIDIInputParser initialize" DefaultMidiTable _ Array new: 255 withAll: #undefined:. 128 to: 143 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "key off" 144 to: 159 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "key on" 160 to: 175 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "polyphonic after-touch" 176 to: 191 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "control change" 192 to: 207 do: [:i | DefaultMidiTable at: i put: #recordOne:]. "program change" 208 to: 223 do: [:i | DefaultMidiTable at: i put: #recordOne:]. "channel after-touch" 224 to: 239 do: [:i | DefaultMidiTable at: i put: #recordTwo:]. "pitch bend" DefaultMidiTable at: 240 put: #startSysExclusive:. "start a system exclusive block" DefaultMidiTable at: 241 put: #recordOne:. "MIDI time code quarter frame" DefaultMidiTable at: 242 put: #recordTwo:. "song position select" DefaultMidiTable at: 243 put: #recordOne:. "song select" DefaultMidiTable at: 244 put: #undefined:. DefaultMidiTable at: 245 put: #undefined:. DefaultMidiTable at: 246 put: #recordZero:. "tune request" DefaultMidiTable at: 247 put: #endSysExclusive:. "end a system exclusive block" DefaultMidiTable at: 248 put: #recordZero:. "timing clock" DefaultMidiTable at: 249 put: #undefined:. DefaultMidiTable at: 250 put: #recordZero:. "start" DefaultMidiTable at: 251 put: #recordZero:. "continue" DefaultMidiTable at: 252 put: #recordZero:. "stop/Clock" DefaultMidiTable at: 253 put: #undefined:. DefaultMidiTable at: 254 put: #recordZero:. "active sensing" DefaultMidiTable at: 255 put: #recordZero:. "system reset" ! ! !MIDIInputParser class methodsFor: 'instance creation' stamp: 'jm 10/8/1998 20:29'! on: aSimpleMIDIPort "Answer a new MIDI parser on the given port." ^ super new setMIDIPort: aSimpleMIDIPort ! ! A MIDIScore is a container for a number of MIDI tracks as well as an ambient track for such things as sounds, book page triggers and other related events.! !MIDIScore methodsFor: 'accessing' stamp: 'di 6/15/1999 11:35'! durationInTicks | t | t _ 0. tracks do: [:track | track do: [:n | (n isNoteEvent) ifTrue: [t _ t max: n endTime]]]. ^ t ! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/20/1999 00:08'! appendEvent: noteEvent fullDuration: fullDuration at: selection "It is assumed that the noteEvent already has the proper time" | track noteLoc | track _ tracks at: selection first. noteLoc _ selection third + 1. noteEvent midiKey = -1 ifTrue: [noteLoc _ noteLoc - 1] ifFalse: ["If not a rest..." track _ track copyReplaceFrom: noteLoc to: noteLoc - 1 with: (Array with: noteEvent)]. track size >= (noteLoc + 1) ifTrue: ["Adjust times of following events" noteLoc + 1 to: track size do: [:i | (track at: i) adjustTimeBy: fullDuration]]. tracks at: selection first put: track! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 15:12'! cutSelection: selection | track selStartTime delta | track _ tracks at: selection first. selStartTime _ (track at: selection second) time. track _ track copyReplaceFrom: selection second to: selection third with: Array new. track size >= selection second ifTrue: ["Adjust times of following events" delta _ selStartTime - (track at: selection second) time. selection second to: track size do: [:i | (track at: i) adjustTimeBy: delta]]. tracks at: selection first put: track! ! !MIDIScore methodsFor: 'editing' stamp: 'jm 9/10/1998 17:22'! eventForTrack: trackIndex after: eventIndex ticks: scoreTick | track evt | track _ tracks at: trackIndex. eventIndex > track size ifTrue: [^ nil]. evt _ track at: eventIndex. evt time > scoreTick ifTrue: [^ nil]. ^ evt ! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 16:06'! gridToNextQuarterNote: tickTime ^ self gridToQuarterNote: tickTime + ticksPerQuarterNote! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 14:55'! gridToQuarterNote: tickTime ^ tickTime truncateTo: ticksPerQuarterNote! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/17/1999 16:14'! gridTrack: trackIndex toQuarter: quarterDelta at: indexInTrack | track selStartTime delta | track _ tracks at: trackIndex. selStartTime _ (track at: indexInTrack) time. delta _ (self gridToQuarterNote: selStartTime + (quarterDelta*ticksPerQuarterNote)) - selStartTime. indexInTrack to: track size do: [:i | (track at: i) adjustTimeBy: delta]. ! ! !MIDIScore methodsFor: 'editing' stamp: 'di 6/21/1999 10:56'! insertEvents: events at: selection | track selStartTime delta | track _ tracks at: selection first. selection second = 0 ifTrue: [selStartTime _ 0. selection at: 2 put: 1] ifFalse: [selStartTime _ (track at: selection second) time]. track _ track copyReplaceFrom: selection second to: selection second - 1 with: (events collect: [:e | e copy]). track size >= (selection second + events size) ifTrue: ["Adjust times of following events" delta _ selStartTime - (track at: selection second) time. selection second to: selection second + events size - 1 do: [:i | (track at: i) adjustTimeBy: delta]. delta _ (self gridToNextQuarterNote: (track at: selection second + events size - 1) endTime) - (track at: selection second + events size) time. selection second + events size to: track size do: [:i | (track at: i) adjustTimeBy: delta]. ]. tracks at: selection first put: track! ! !MIDIScore methodsFor: 'editing' stamp: 'jm 8/6/1998 21:16'! jitterStartAndEndTimesBy: mSecs | r range halfRange oldEnd newEnd newStart | r _ Random new. range _ 2.0 * mSecs. halfRange _ mSecs. tracks do: [:t | t do: [:e | e isNoteEvent ifTrue: [ oldEnd _ e time + e duration. newEnd _ oldEnd + ((r next * range) asInteger - halfRange). newStart _ e time + ((r next * range) asInteger - halfRange). e time: newStart. e duration: (newEnd - newStart)]]]. ! ! I implement a simple real-time MIDI synthesizer on platforms that support MIDI input. I work best on platforms that allow the sound buffer to be made very short--under 50 milliseconds is good and under 20 milliseconds is preferred (see below). The buffer size is changed by modifying the class initialization method of SoundPlayer and executing the do-it there to re-start the sound player. Each instance of me takes input from a single MIDI input port. Multiple instances of me can be used to handle multiple MIDI input ports. I distribute incoming commands among my sixteen MIDISynthChannel objects. Most of the interpretation of the MIDI commands is done by these channel objects. Buffer size notes: At the moment, most fast PowerPC Macintosh computers can probably work with buffer sizes down to 50 milliseconds, and the Powerbook G3 works down to about 15 milliseconds. You will need to experiment to discover the minimum buffer size that does not result in clicking during sound output. (Hint: Be sure to turn off power cycling on your Powerbook. Other applications and extensions can steal cycles from Squeak, causing intermittent clicking. Experimentation may be necessary to find a configuration that works for you.) ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 22:16'! channel: i ^ channels at: i ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:50'! closeMIDIPort midiParser midiPort ifNil: [^ self]. midiParser midiPort close. midiParser midiPort: nil. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:29'! initialize midiParser _ MIDIInputParser on: nil. channels _ (1 to: 16) collect: [:ch | MIDISynthChannel new initialize]. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:13'! instrumentForChannel: channelIndex ^ (channels at: channelIndex) instrument ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:14'! instrumentForChannel: channelIndex put: aSoundProto (channels at: channelIndex) instrument: aSoundProto. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:27'! isOn ^ process notNil ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 21:52'! midiParser ^ midiParser ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 08:26'! midiPort ^ midiParser midiPort ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:32'! midiPort: aMIDIPortOrNil midiParser midiPort: aMIDIPortOrNil. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/13/1998 12:09'! midiTrackingLoop midiParser clearBuffers. [true] whileTrue: [ self processMIDI ifFalse: [(Delay forMilliseconds: 5) wait]]. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 20:12'! mutedForChannel: channelIndex put: aBoolean ^ (channels at: channelIndex) muted: aBoolean ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'! panForChannel: channelIndex ^ (channels at: channelIndex) pan ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 19:45'! panForChannel: channelIndex put: newPan (channels at: channelIndex) pan: newPan. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 14:13'! processMIDI "Process some MIDI commands. Answer true if any commands were processed." | didSomething cmdByte byte1 byte2 cmd chan | didSomething _ false. midiParser midiDo: [:item | didSomething _ true. cmdByte _ item at: 2. byte1 _ byte2 _ nil. item size > 2 ifTrue: [ byte1 _ item at: 3. item size > 3 ifTrue: [byte2 _ item at: 4]]. cmdByte < 240 ifTrue: [ "channel message" cmd _ cmdByte bitAnd: 2r11110000. chan _ (cmdByte bitAnd: 2r00001111) + 1. (channels at: chan) doChannelCmd: cmd byte1: byte1 byte2: byte2] ifFalse: [ "system message" "process system messages here" ]]. ^ didSomething ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 10/14/1998 14:14'! processMIDIUntilMouseDown "Used for debugging. Do MIDI processing until the mouse is pressed." midiParser clearBuffers. [Sensor anyButtonPressed] whileFalse: [self processMIDI]. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:36'! setAllChannelMasterVolumes: aNumber | vol | vol _ (aNumber asFloat min: 1.0) max: 0.0. channels do: [:ch | ch masterVolume: vol]. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/13/1999 08:16'! startMIDITracking midiParser ifNil: [^ self]. midiParser midiPort ifNil: [^ self]. midiParser midiPort ensureOpen. self stopMIDITracking. SoundPlayer useShortBuffer. process _ [self midiTrackingLoop] newProcess. process priority: Processor userInterruptPriority. process resume. ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 10:34'! stopMIDITracking process ifNotNil: [ process terminate. process _ nil]. SoundPlayer shutDown; initialize. "revert to normal buffer size" ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'! volumeForChannel: channelIndex ^ (channels at: channelIndex) masterVolume ! ! !MIDISynth methodsFor: 'as yet unclassified' stamp: 'jm 1/6/1999 16:40'! volumeForChannel: channelIndex put: newVolume (channels at: channelIndex) masterVolume: newVolume. ! ! !MIDISynth class methodsFor: 'examples' stamp: 'jm 1/6/1999 16:39'! example "Here's one way to run the MIDI synth. It will get a nice Morphic UI later. Click the mouse to stop running it. (Mac users note: be sure you have MIDI interface adaptor plugged in, or Squeak will hang waiting for the external clock signal.)." "MIDISynth example" | portNum synth | portNum _ SimpleMIDIPort inputPortNumFromUser. portNum ifNil: [^ self]. SoundPlayer useShortBuffer. synth _ MIDISynth new midiPort: (SimpleMIDIPort openOnPortNumber: portNum). synth midiParser ignoreCommand: 224. "filter out pitch bends" 1 to: 16 do: [:i | (synth channel: i) instrument: (AbstractSound soundNamed: 'oboe1')]. 1 to: 16 do: [:ch | synth volumeForChannel: ch put: 0.2]. synth processMIDIUntilMouseDown. SoundPlayer shutDown; initialize. "revert to normal buffer size" ! ! I implement one polyphonic channel of a 16-channel MIDI synthesizer. Many MIDI commands effect all the notes played on a particular channel, so I record the state for a single channel, including a list of notes currently playing. This initial implementation is extremely spartan, having just enough functionality to play notes. Things that are not implemented include: 1. program changes 2. sustain pedal 3. aftertouch (either kind) 4. most controllers 5. portamento 6. mono-mode ! !MIDISynthChannel methodsFor: 'initialization' stamp: 'jm 1/6/1999 20:10'! initialize instrument _ FMSound default. muted _ false. masterVolume _ 0.5. channelVolume _ 1.0. pan _ 0.5. pitchBend _ 0.0. activeSounds _ OrderedCollection new. ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:45'! instrument ^ instrument ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:45'! instrument: aSound instrument _ aSound. ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 09:47'! masterVolume ^ masterVolume ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 10/13/1998 11:49'! masterVolume: aNumber "Set the master volume the the given value (0.0 to 1.0)." masterVolume _ aNumber asFloat. ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 20:10'! muted ^ muted ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 20:11'! muted: aBoolean muted _ aBoolean. ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 19:43'! pan ^ pan ! ! !MIDISynthChannel methodsFor: 'accessing' stamp: 'jm 1/6/1999 19:43'! pan: aNumber "Set the left-right pan to the given value (0.0 to 1.0)." pan _ aNumber asFloat. ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 15:40'! channelPressure: newPressure "Handle a channel pressure (channel aftertouch) change." self newVolume: newPressure. ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:48'! control: control value: newValue "Handle a continuous controller change." control = 2 ifTrue: [self newVolume: newValue]. "breath controller" ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:44'! doChannelCmd: cmdByte byte1: byte1 byte2: byte2 "Dispatch a channel command with the given arguments." "Details: Cases appear in order of expected frequency, most frequent cases first." cmdByte = 144 ifTrue: [ byte2 = 0 ifTrue: [^ self keyUp: byte1 vel: 0] ifFalse: [^ self keyDown: byte1 vel: byte2]]. cmdByte = 128 ifTrue: [^ self keyUp: byte1 vel: byte2]. cmdByte = 224 ifTrue: [^ self pitchBend: ((byte2 bitShift: 7) + byte1) - 8192]. cmdByte = 176 ifTrue: [^ self control: byte1 value: byte2]. cmdByte = 208 ifTrue: [^ self channelPressure: byte1]. cmdByte = 160 ifTrue: [^ self key: byte1 pressure: byte2]. cmdByte = 192 ifTrue: [^ self programChange: byte1]. ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:49'! key: key pressure: press "Handle a key pressure (polyphonic aftertouch) change. Rarely implemented." "Do nothing for now." ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 1/10/1999 08:42'! keyDown: key vel: vel "Handle a key down event with non-zero velocity." | pitch snd | muted ifTrue: [^ self]. pitch _ AbstractSound pitchForMIDIKey: key. snd _ instrument soundForPitch: pitch dur: 10000.0 "sustain a long time, or until turned off" loudness: masterVolume * channelVolume * (self convertVelocity: vel). snd _ (MixedSound new add: snd pan: pan) reset. SoundPlayer resumePlaying: snd quickStart: false. activeSounds add: (Array with: key with: snd with: pitch). ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:49'! keyUp: key vel: vel "Handle a key up event." | snd | activeSounds copy do: [:entry | (entry at: 1) = key ifTrue: [ snd _ entry at: 2. snd stopGracefully. activeSounds remove: entry]]. ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 1/11/1999 11:32'! pitchBend: bend "Handle a pitch-bend change." self adjustPitch: bend. ! ! !MIDISynthChannel methodsFor: 'midi dispatching' stamp: 'jm 10/14/1998 13:50'! programChange: newProgram "Handle a program (instrument) change." "Do nothing for now." ! ! !MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 21:45'! adjustPitch: bend "Handle a pitch-bend change." | snd pitchAdj centerPitch | pitchBend _ bend. pitchAdj _ 2.0 raisedTo: (bend asFloat / 8192.0) / 6.0. activeSounds copy do: [:entry | snd _ entry at: 2. centerPitch _ entry at: 3. snd pitch: pitchAdj * centerPitch. snd internalizeModulationAndRatio]. ! ! !MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 15:43'! convertVelocity: valueByte "Map a value in the range 0..127 to a volume in the range 0.0..1.0." "Details: A quadratic function seems to give a good keyboard feel." | r | r _ (valueByte * valueByte) / 12000.0. r > 1.0 ifTrue: [^ 1.0]. r < 0.08 ifTrue: [^ 0.08]. ^ r ! ! !MIDISynthChannel methodsFor: 'other' stamp: 'jm 10/14/1998 15:41'! newVolume: valueByte "Set the channel volume to the level given by the given number in the range 0..127." | snd newVolume | channelVolume _ valueByte asFloat / 127.0. newVolume _ masterVolume * channelVolume. activeSounds do: [:entry | snd _ entry at: 2. snd adjustVolumeTo: newVolume overMSecs: 10]. ! ! I represent a MIME object, along with its type and its URL (if any). ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:49'! content "Answer the receiver's raw data." ^ content! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'! contentType "Answer the MIME contents type." ^ self mainType , '/' , self subType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'! mainType ^ mainType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:47'! subType ^ subType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'! type "Deprecated. Use contentType instead." ^ self contentType! ! !MIMEDocument methodsFor: 'accessing' stamp: 'sma 4/28/2000 14:48'! url "Answer the URL the receiver was downloaded from. It may legitimately be nil." ^ url! ! !MIMEDocument methodsFor: 'printing' stamp: 'ls 7/23/1998 20:12'! printOn: aStream aStream nextPutAll: self class name; nextPutAll: ' ('; nextPutAll: self contentType; nextPutAll: ', '; nextPutAll: self content size printString; nextPutAll: ' bytes)'.! ! !MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:11'! privateContent: aString content _ aString! ! !MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'! privateMainType: aString mainType _ aString! ! !MIMEDocument methodsFor: 'private' stamp: 'ls 7/23/1998 20:06'! privateSubType: aString subType _ aString! ! !MIMEDocument methodsFor: 'private' stamp: 'ls 8/12/1998 00:25'! privateUrl: aUrl url _ aUrl! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'jm 5/12/2003 21:08'! contentType: aString content: content url: aUrl "Create an instance of me with the given content-type and content" "MIMEDocument contentType: 'text/plain' content: 'This is a test' url: nil" | ans idx | ans _ self new. ans privateContent: content. "parse the content-type" (aString isNil or: [ idx _ aString indexOf: $/. idx = 0]) ifTrue: [ ans privateMainType: 'application'. ans privateSubType: 'octet-stream' ] ifFalse: [ ans privateMainType: (aString copyFrom: 1 to: idx-1). ans privateSubType: (aString copyFrom: idx+1 to: aString size) ]. ans privateUrl: aUrl. ^ans ! ! I differ from a normal Dictionary the way IdentitySet differs from a normal Set--I use identityHash and == to hash and compare keys. Thus, keys that are = to each other can be used for separate dictionary entries as long as they are distinct objects. ! !MIdentityDictionary methodsFor: 'private' stamp: 'jm 12/8/2003 23:50'! keys "Answer an array of the receiver's keys." | result | result _ OrderedCollection new: self size. self keysDo: [:key | result add: key]. ^ result asArray ! ! !MIdentityDictionary methodsFor: 'private' stamp: 'jm 2/18/98 13:18'! 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." | finish hash start element | finish _ array size. finish > 4096 ifTrue: [hash _ anObject identityHash * (finish // 4096)] ifFalse: [hash _ anObject identityHash]. start _ (hash \\ array size) + 1. "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"! ! I am similar to a normal Set, except that I use the object's identityHash and == to test for equality. Thus, I can contain multiple instance of objects that are equal to each other. For example if you add 'foo' and 'foo' copy to a normal Set, that Set would keep only one copy of 'foo', since 'foo' = 'foo' copy. An IdentitySet would store both the original string and its copy because they are distinct objects (i.e., they are not == to each other). ! !MIdentitySet methodsFor: 'private' stamp: 'jm 2/18/98 13:19'! 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." | finish hash start element | finish _ array size. finish > 4096 ifTrue: [hash _ anObject identityHash * (finish // 4096)] ifFalse: [hash _ anObject identityHash]. start _ (hash \\ array size) + 1. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ array at: index) == nil or: [element == anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [element == anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! MInteger comment: 'I am a common abstract superclass for all Integer implementations. My implementation subclasses are SmallInteger, LargePositiveInteger, and LargeNegativeInteger. Integer division consists of: / exact division, answers a fraction if result is not a whole integer // answers an Integer, rounded towards negative infinity \\ is modulo rounded towards negative infinity quo: truncated division, rounded towards zero'! !MInteger methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! * aNumber "Refer to the comment in Number * " aNumber isInteger ifTrue: [^ self digitMultiply: aNumber neg: self negative ~~ aNumber negative]. ^ aNumber adaptToInteger: self andSend: #*! ! !MInteger methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! + aNumber "Refer to the comment in Number + " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ (self digitAdd: aNumber) normalize] ifFalse: [^ self digitSubtract: aNumber]]. ^ aNumber adaptToInteger: self andSend: #+! ! !MInteger methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! - aNumber "Refer to the comment in Number - " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ self digitSubtract: aNumber] ifFalse: [^ (self digitAdd: aNumber) normalize]]. ^ aNumber adaptToInteger: self andSend: #-! ! !MInteger methodsFor: 'arithmetic' stamp: 'jm 11/11/2002 20:11'! / aNumber "Refer to the comment in Number / " | quoRem | aNumber isInteger ifTrue: [ quoRem _ self digitDiv: aNumber abs neg: self negative ~~ aNumber negative. (quoRem at: 2) = 0 ifTrue: [^ (quoRem at: 1) normalize] ifFalse: [^ self asFloat / aNumber asFloat]]. ^ aNumber adaptToInteger: self andSend: #/ ! ! !MInteger methodsFor: 'arithmetic'! // aNumber | q | aNumber = 0 ifTrue: [^self error: 'division by 0']. self = 0 ifTrue: [^0]. q _ self quo: aNumber "Refer to the comment in Number|//.". (q negative ifTrue: [q * aNumber ~= self] ifFalse: [q = 0 and: [self negative ~= aNumber negative]]) ifTrue: [^q - 1"Truncate towards minus infinity"] ifFalse: [^q]! ! !MInteger methodsFor: 'arithmetic' stamp: 'jm 10/27/2003 07:39'! quo: aNumber "Refer to the comment in Number quo: " | ng quo | aNumber isInteger ifTrue: [ng _ self negative == aNumber negative == false. quo _ (self digitDiv: (aNumber isSmallInteger ifTrue: [aNumber abs] ifFalse: [aNumber]) neg: ng) at: 1. ^ quo normalize]. ^ aNumber adaptToInteger: self andSend: #quo:! ! !MInteger methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! < aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^ (self digitCompare: aNumber) > 0] ifFalse: [^ (self digitCompare: aNumber) < 0]] ifFalse: [^ self negative]]. ^ aNumber adaptToInteger: self andSend: #<! ! !MInteger methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! = aNumber aNumber isNumber ifFalse: [^ false]. aNumber isInteger ifTrue: [aNumber negative == self negative ifTrue: [^ (self digitCompare: aNumber) = 0] ifFalse: [^ false]]. ^ aNumber adaptToInteger: self andSend: #=! ! !MInteger methodsFor: 'comparing' stamp: 'di 11/6/1998 14:00'! > aNumber aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [self negative ifTrue: [^(self digitCompare: aNumber) < 0] ifFalse: [^(self digitCompare: aNumber) > 0]] ifFalse: [^ aNumber negative]]. ^ aNumber adaptToInteger: self andSend: #>! ! !MInteger methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^(self lastDigit bitShift: 8) + (self digitAt: 1)! ! !MInteger methodsFor: 'testing'! isInteger "True for all subclasses of Integer." ^ true! ! !MInteger methodsFor: 'truncation and round off'! ceiling "Refer to the comment in Number|ceiling."! ! !MInteger methodsFor: 'truncation and round off'! floor "Refer to the comment in Number|floor."! ! !MInteger methodsFor: 'truncation and round off'! normalize "SmallInts OK; LgInts override" ^ self! ! !MInteger methodsFor: 'truncation and round off'! rounded "Refer to the comment in Number|rounded."! ! !MInteger methodsFor: 'truncation and round off'! truncated "Refer to the comment in Number|truncated."! ! !MInteger methodsFor: 'enumerating'! timesRepeat: aBlock "Evaluate the argument, aBlock, the number of times represented by the receiver." | count | count _ 1. [count <= self] whileTrue: [aBlock value. count _ count + 1]! ! !MInteger methodsFor: 'bit manipulation'! bitAnd: n "Answer an Integer whose bits are the logical AND of the receiver's bits and those of the argument, n." | norm | norm _ n normalize. ^ self digitLogic: norm op: #bitAnd: length: (self digitLength max: norm digitLength)! ! !MInteger methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:32'! bitClear: aMask "Answer an Integer equal to the receiver, except with all bits cleared that are set in aMask." ^ (self bitOr: aMask) - aMask! ! !MInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'! bitInvert "Answer an Integer whose bits are the logical negation of the receiver's bits. Numbers are interpreted as having 2's-complement representation." ^ -1 - self! ! !MInteger methodsFor: 'bit manipulation'! bitOr: n "Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument, n." | norm | norm _ n normalize. ^self digitLogic: norm op: #bitOr: length: (self digitLength max: norm digitLength)! ! !MInteger methodsFor: 'bit manipulation'! bitShift: shiftCount "Answer an Integer whose value (in twos-complement representation) is the receiver's value (in twos-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts." | rShift | shiftCount >= 0 ifTrue: [^ self digitLshift: shiftCount]. rShift _ 0 - shiftCount. ^ (self digitRshift: (rShift bitAnd: 7) bytes: (rShift bitShift: -3) lookfirst: self digitLength) normalize! ! !MInteger methodsFor: 'bit manipulation'! bitXor: n "Answer an Integer whose bits are the logical XOR of the receiver's bits and those of the argument, n." | norm | norm _ n normalize. ^self digitLogic: norm op: #bitXor: length: (self digitLength max: norm digitLength)! ! !MInteger methodsFor: 'converting' stamp: 'jm 11/23/2003 13:12'! asCharacter "Answer the Character whose value is the receiver." ^ MCharacter asciiValue: self ! ! !MInteger methodsFor: 'converting' stamp: 'jm 12/31/2003 10:12'! asFloat "Answer a Float that represents the value of the receiver. Optimized to process only the significant digits of a LargeInteger. SqR: 11/30/1998 21:11" | sum firstByte shift | shift _ 0. sum _ 0. firstByte _ self size - 7 max: 1. firstByte to: self size do: [:byteIndex | sum _ ((self digitAt: byteIndex) asFloat timesTwoPower: shift) + sum. shift _ shift + 8]. ^ sum * self sign asFloat timesTwoPower: firstByte - 1 * 8 ! ! !MInteger methodsFor: 'converting'! asInteger "Answer with the receiver itself." ^self ! ! !MInteger methodsFor: 'benchmarks' stamp: 'jm 11/20/1998 07:06'! benchFib "Handy send-heavy benchmark" "(result // seconds to run) = approx calls per second" " | r t | t _ Time millisecondsToRun: [r _ 26 benchFib]. (r * 1000) // t" "138000 on a Mac 8100/100" ^ self < 2 ifTrue: [1] ifFalse: [(self-1) benchFib + (self-2) benchFib + 1] ! ! !MInteger methodsFor: 'benchmarks' stamp: 'jm 12/31/2003 12:50'! benchmark "Handy bytecode-heavy benchmark" "(500000 // time to run) = approx bytecodes per second" "5000000 // (Time millisecondsToRun: [10 benchmark]) * 1000" "3059000 on a Mac 8100/100" | size flags prime k count | size _ 8190. 1 to: self do: [:iter | count _ 0. flags _ (1 to: size) collect: [:i | true]. 1 to: size do: [:i | (flags at: i) ifTrue: [prime _ i+1. k _ i + prime. [k <= size] whileTrue: [flags at: k put: false. k _ k + prime]. count _ count + 1]]]. ^ count! ! !MInteger methodsFor: 'printing' stamp: 'jm 10/26/2003 13:29'! printOn: aStream base: b "Print a representation of the receiver on the stream, aStream, in base, b, where 2<=b<=16." | digits source dest i j pos t rem | b = 10 ifFalse: [b printOn: aStream. aStream nextPut: $r]. i _ self digitLength. "Estimate size of result, conservatively" digits _ MArray new: i * 8. pos _ 0. dest _ i <= 1 ifTrue: [self] ifFalse: [MLargePositiveInteger new: i]. source _ self. [i >= 1] whileTrue: [rem _ 0. j _ i. [j > 0] whileTrue: [t _ (rem bitShift: 8) + (source digitAt: j). dest digitAt: j put: t // b. rem _ t \\ b. j _ j - 1]. pos _ pos + 1. digits at: pos put: rem. source _ dest. (source digitAt: i) = 0 ifTrue: [i _ i - 1]]. "(dest digitAt: 1) printOn: aStream base: b." [pos > 0] whileTrue: [aStream nextPut: (MCharacter digitValue: (digits at: pos)). pos _ pos - 1]! ! !MInteger methodsFor: 'system primitives'! lastDigit "Answer the last digit of the integer." ^self digitAt: self digitLength! ! !MInteger methodsFor: 'system primitives'! replaceFrom: start to: stop with: replacement startingAt: repStart | j | "Catches failure if LgInt replace primitive fails" j _ repStart. start to: stop do: [:i | self digitAt: i put: (replacement digitAt: j). j _ j+1]! ! !MInteger methodsFor: 'private'! copyto: x | stop | stop _ self digitLength min: x digitLength. ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitAdd: arg | len arglen accum sum | accum _ 0. (len _ self digitLength) < (arglen _ arg digitLength) ifTrue: [len _ arglen]. "Open code max: for speed" sum _ MInteger new: len neg: self negative. 1 to: len do: [:i | accum _ (accum bitShift: -8) + (self digitAt: i) + (arg digitAt: i). sum digitAt: i put: (accum bitAnd: 255)]. accum > 255 ifTrue: [sum _ sum growby: 1. sum at: sum digitLength put: (accum bitShift: -8)]. ^sum! ! !MInteger methodsFor: 'private'! digitCompare: arg "Compare the magnitude of self with that of arg. Return a code of 1, 0, -1 for self >, = , < arg" | len arglen argDigit selfDigit | len _ self digitLength. (arglen _ arg digitLength) ~= len ifTrue: [arglen > len ifTrue: [^-1] ifFalse: [^1]]. [len > 0] whileTrue: [(argDigit _ arg digitAt: len) ~= (selfDigit _ self digitAt: len) ifTrue: [argDigit < selfDigit ifTrue: [^1] ifFalse: [^-1]]. len _ len - 1]. ^0! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitDiv: arg neg: ng "Answer with an array of (quotient, remainder)." | quo rem ql d div dh dnh dl qhi qlo j l hi lo r3 a t | arg = 0 ifTrue: [^ self error: 'division by 0']. l _ self digitLength - arg digitLength + 1. l <= 0 ifTrue: [^MArray with: 0 with: self]. d _ 8 - arg lastDigit highBit. div _ arg digitLshift: d. div _ div growto: div digitLength + 1. "shifts so high order word is >=128" rem _ self digitLshift: d. rem digitLength = self digitLength ifTrue: [rem _ rem growto: self digitLength + 1]. "makes a copy and shifts" quo _ MInteger new: l neg: ng. dl _ div digitLength - 1. "Last actual byte of data" ql _ l. dh _ div digitAt: dl. dnh _ dl = 1 ifTrue: [0] ifFalse: [div digitAt: dl - 1]. 1 to: ql do: [:k | "maintain quo*arg+rem=self" "Estimate rem/div by dividing the leading to bytes of rem by dh." "The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles." j _ rem digitLength + 1 - k. "r1 _ rem digitAt: j." (rem digitAt: j) = dh ifTrue: [qhi _ qlo _ 15"i.e. q=255"] ifFalse: ["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh. Note that r1,r2 are bytes, not nibbles. Be careful not to generate intermediate results exceeding 13 bits." "r2 _ (rem digitAt: j - 1)." t _ ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4). qhi _ t // dh. t _ (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15). qlo _ t // dh. t _ t \\ dh. "Next compute (hi,lo) _ q*dnh" hi _ qhi * dnh. lo _ qlo * dnh + ((hi bitAnd: 15) bitShift: 4). hi _ (hi bitShift: -4) + (lo bitShift: -8). lo _ lo bitAnd: 255. "Correct overestimate of q. Max of 2 iterations through loop -- see Knuth vol. 2" r3 _ j < 3 ifTrue: [0] ifFalse: [rem digitAt: j - 2]. [(t < hi or: [t = hi and: [r3 < lo]]) and: ["i.e. (t,r3) < (hi,lo)" qlo _ qlo - 1. lo _ lo - dnh. lo < 0 ifTrue: [hi _ hi - 1. lo _ lo + 256]. hi >= dh]] whileTrue: [hi _ hi - dh]. qlo < 0 ifTrue: [qhi _ qhi - 1. qlo _ qlo + 16]]. "Subtract q*div from rem" l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | hi _ (div digitAt: i) * qhi. lo _ a + (rem digitAt: l) - ((hi bitAnd: 15) bitShift: 4) - ((div digitAt: i) * qlo). rem digitAt: l put: lo - (lo // 256 * 256) "sign-tolerant form of (lo bitAnd: 255)". a _ (lo // 256) - (hi bitShift: -4). l _ l + 1]. a < 0 ifTrue: ["Add div back into rem, decrease q by 1" qlo _ qlo - 1. l _ j - dl. a _ 0. 1 to: div digitLength do: [:i | a _ (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i). rem digitAt: l put: (a bitAnd: 255). l _ l + 1]]. quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo]. rem _ rem digitRshift: d bytes: 0 lookfirst: dl. ^ MArray with: quo with: rem ! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitLogic: arg op: op length: len | result neg1 neg2 rneg z1 z2 rz b1 b2 b | neg1 _ self negative. neg2 _ arg negative. rneg _ ((neg1 ifTrue: [-1] ifFalse: [0]) perform: op with: (neg2 ifTrue: [-1] ifFalse: [0])) < 0. result _ MInteger new: len neg: rneg. rz _ z1 _ z2 _ true. 1 to: result digitLength do: [:i | b1 _ self digitAt: i. neg1 ifTrue: [b1 _ z1 ifTrue: [b1 = 0 ifTrue: [0] ifFalse: [z1 _ false. 256 - b1]] ifFalse: [255 - b1]]. b2 _ arg digitAt: i. neg2 ifTrue: [b2 _ z2 ifTrue: [b2 = 0 ifTrue: [0] ifFalse: [z2 _ false. 256 - b2]] ifFalse: [255 - b2]]. b _ b1 perform: op with: b2. b = 0 ifTrue: [result digitAt: i put: 0] ifFalse: [result digitAt: i put: (rneg ifTrue: [rz ifTrue: [rz _ false. 256 - b] ifFalse: [255 - b]] ifFalse: [b])]]. ^ result normalize! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitLshift: shiftCount | carry rShift mask len result digit byteShift bitShift highBit | (highBit _ self highBit) = 0 ifTrue: [^ 0]. len _ highBit + shiftCount + 7 // 8. result _ MInteger new: len neg: self negative. byteShift _ shiftCount // 8. bitShift _ shiftCount \\ 8. bitShift = 0 ifTrue: ["Fast version for byte-aligned shifts" ^ result replaceFrom: byteShift+1 to: len with: self startingAt: 1]. carry _ 0. rShift _ bitShift - 8. mask _ 255 bitShift: 0 - bitShift. 1 to: byteShift do: [:i | result digitAt: i put: 0]. 1 to: len - byteShift do: [:i | digit _ self digitAt: i. result digitAt: i + byteShift put: (((digit bitAnd: mask) bitShift: bitShift) bitOr: carry). carry _ digit bitShift: rShift]. ^ result! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitMultiply: arg neg: ng | prod prodLen carry digit k ab | (arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^ 0]. prodLen _ self digitLength + arg digitLength. prod _ MInteger new: prodLen neg: ng. "prod starts out all zero" 1 to: self digitLength do: [:i | (digit _ self digitAt: i) ~= 0 ifTrue: [k _ i. carry _ 0. "Loop invariant: 0<=carry<=0377, k=i+j-1" 1 to: arg digitLength do: [:j | ab _ ((arg digitAt: j) * digit) + carry + (prod digitAt: k). carry _ ab bitShift: -8. prod digitAt: k put: (ab bitAnd: 255). k _ k + 1]. prod digitAt: k put: carry]]. ^ prod normalize! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitRshift: anInteger bytes: b lookfirst: a "Shift right 8*b+anInteger bits, 0<=n<8. Discard all digits beyond a, and all zeroes at or below a." | n x r f m digit count i | n _ 0 - anInteger. x _ 0. f _ n + 8. i _ a. m _ 255 bitShift: 0 - f. digit _ self digitAt: i. [((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue: [x _ digit bitShift: f "Can't exceed 8 bits". i _ i - 1. digit _ self digitAt: i]. i <= b ifTrue: [^MInteger new: 0 neg: self negative]. "All bits lost" r _ MInteger new: i - b neg: self negative. count _ i. x _ (self digitAt: b + 1) bitShift: n. b + 1 to: count do: [:j | digit _ self digitAt: j + 1. r digitAt: j - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) "Avoid values > 8 bits". x _ digit bitShift: n]. ^r! ! !MInteger methodsFor: 'private' stamp: 'jm 11/13/2002 16:57'! digitSubtract: arg | smaller larger z sum sl al ng | sl _ self digitLength. al _ arg digitLength. (sl = al ifTrue: [[(self digitAt: sl) = (arg digitAt: sl) and: [sl > 1]] whileTrue: [sl _ sl - 1]. al _ sl. (self digitAt: sl) < (arg digitAt: sl)] ifFalse: [sl < al]) ifTrue: [larger _ arg. smaller _ self. ng _ self negative == false. sl _ al] ifFalse: [larger _ self. smaller _ arg. ng _ self negative]. sum _ MInteger new: sl neg: ng. z _ 0. "Loop invariant is -1<=z<=1" 1 to: sl do: [:i | z _ z + (larger digitAt: i) - (smaller digitAt: i). sum digitAt: i put: z - (z // 256 * 256) "sign-tolerant form of (z bitAnd: 255)". z _ z // 256]. ^ sum normalize! ! !MInteger methodsFor: 'private'! growby: n ^self growto: self digitLength + n! ! !MInteger methodsFor: 'private'! growto: n ^self copyto: (self species new: n)! ! !MInteger class methodsFor: 'instance creation' stamp: 'jm 11/13/2002 17:01'! new: length neg: neg "Answer an instance of a large integer with the given size and sign." neg ifTrue: [^ MLargeNegativeInteger new: length] ifFalse: [^ MLargePositiveInteger new: length]. ! ! !MInteger class methodsFor: 'instance creation'! readFrom: aStream "Answer a new Integer as described on the stream, aStream. Embedded radix specifiers not allowed - use Number readFrom: for that." ^self readFrom: aStream base: 10! ! !MInteger class methodsFor: 'instance creation'! readFrom: aStream base: base "Answer an instance of one of my concrete subclasses. Initial minus sign accepted, and bases > 10 use letters A-Z. Embedded radix specifiers not allowed--use Number readFrom: for that. Answer zero (not an error) if there are no digits." | digit value neg | neg _ aStream peekFor: $-. value _ 0. [aStream atEnd] whileFalse: [digit _ aStream next digitValue. (digit < 0 or: [digit >= base]) ifTrue: [aStream skip: -1. neg ifTrue: [^ value negated]. ^ value] ifFalse: [value _ value * base + digit]]. neg ifTrue: [^ value negated]. ^ value! ! I represent a finite sequence of numbers. ! !MInterval methodsFor: 'accessing'! at: anInteger "Answer the anInteger'th element." (anInteger >= 1 and: [anInteger <= self size]) ifTrue: [^start + (step * (anInteger - 1))] ifFalse: [self errorSubscriptBounds: anInteger]! ! !MInterval methodsFor: 'accessing'! at: anInteger put: anObject "Storing into an Interval is not allowed." self error: 'you can not store into an interval'! ! !MInterval methodsFor: 'accessing'! first "Refer to the comment in SequenceableCollection|first." ^start! ! !MInterval methodsFor: 'accessing' stamp: 'di 11/10/97 12:22'! includes: aNumber ^ aNumber between: self first and: self last! ! !MInterval methodsFor: 'accessing'! increment "Answer the receiver's interval increment." ^step! ! !MInterval methodsFor: 'accessing'! last "Refer to the comment in SequenceableCollection|last." ^stop - (stop - start \\ step)! ! !MInterval methodsFor: 'accessing'! size step < 0 ifTrue: [start < stop ifTrue: [^0] ifFalse: [^stop - start // step + 1]] ifFalse: [stop < start ifTrue: [^0] ifFalse: [^stop - start // step + 1]]! ! !MInterval methodsFor: 'comparing'! = anInterval "Answer true if my species and anInterval species are equal, and if our starts, steps and sizes are equal." self species == anInterval species ifTrue: [^start = anInterval first and: [step = anInterval increment and: [self size = anInterval size]]] ifFalse: [^false]! ! !MInterval methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^(((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) bitOr: self size! ! !MInterval methodsFor: 'adding' stamp: 'jm 10/27/2003 06:08'! add: newObject "Adding to an Interval is not allowed." self shouldNotImplement. ! ! !MInterval methodsFor: 'removing'! remove: newObject "Removing from an Interval is not allowed." self error: 'elements cannot be removed from an Interval'! ! !MInterval methodsFor: 'enumerating'! collect: aBlock | nextValue result | result _ self species new: self size. nextValue _ start. 1 to: result size do: [:i | result at: i put: (aBlock value: nextValue). nextValue _ nextValue + step]. ^ result! ! !MInterval methodsFor: 'enumerating'! do: aBlock | aValue | aValue _ start. step < 0 ifTrue: [[stop <= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue + step]] ifFalse: [[stop >= aValue] whileTrue: [aBlock value: aValue. aValue _ aValue + step]]! ! !MInterval methodsFor: 'printing'! printOn: aStream aStream nextPut: $(. start printOn: aStream. aStream nextPutAll: ' to: '. stop printOn: aStream. step ~= 1 ifTrue: [aStream nextPutAll: ' by: '. step printOn: aStream]. aStream nextPut: $)! ! !MInterval methodsFor: 'private'! setFrom: startInteger to: stopInteger by: stepInteger start _ startInteger. stop _ stopInteger. step _ stepInteger! ! !MInterval methodsFor: 'private' stamp: 'jm 11/13/2002 16:52'! species ^ MArray ! ! !MInterval class methodsFor: 'instance creation' stamp: 'jm 10/29/2003 11:52'! from: startInteger to: stopInteger "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of 1." ^ self basicNew setFrom: startInteger to: stopInteger by: 1 ! ! !MInterval class methodsFor: 'instance creation' stamp: 'jm 10/29/2003 11:52'! from: startInteger to: stopInteger by: stepInteger "Answer an instance of me, starting at startNumber, ending at stopNumber, and with an interval increment of stepNumber." ^self basicNew setFrom: startInteger to: stopInteger by: stepInteger! ! I am just like LargePositiveInteger, but representing a negative number. ! !MLargeNegativeInteger methodsFor: 'arithmetic'! abs ^ self negated! ! !MLargeNegativeInteger methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:01'! negated ^ self copyto: (MLargePositiveInteger new: self digitLength) ! ! !MLargeNegativeInteger methodsFor: 'converting' stamp: 'jm 11/13/2002 17:22'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen minVal | "First establish len = significant length" len _ oldLen _ self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len _ len - 1]. "Now check if in SmallInteger range" sLen _ 4 "SmallInteger minVal digitLength". len <= sLen ifTrue: [minVal _ MSmallInteger minVal. (len < sLen or: [(self digitAt: sLen) < minVal lastDigit]) ifTrue: ["If high digit less, then can be small" val _ 0. len to: 1 by: -1 do: [:i | val _ (val *256) - (self digitAt: i)]. ^ val]. 1 to: sLen do: "If all digits same, then = minVal" [:i | (self digitAt: i) = (minVal digitAt: i) ifFalse: ["Not so; return self shortened" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]]]. ^ minVal]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! !MLargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ true! ! !MLargeNegativeInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! sign "Optimization. Answer -1 since receiver is less than 0." ^ -1 ! ! !MLargeNegativeInteger methodsFor: 'printing'! printOn: aStream base: b "Refer to the comment in Integer|printOn:base:." aStream nextPut: $-. super printOn: aStream base: b! ! I represent positive integers of more than 30 bits (ie, >= 1073741824). These values are beyond the range of SmallInteger, and are encoded here as an array of 8-bit digits. Care must be taken, when new values are computed, that any result that COULD BE a SmallInteger IS a SmallInteger (see normalize). Note that the bit manipulation primitives, bitAnd:, bitShift:, etc., = and ~= run without failure (and therefore fast) if the value fits in 32 bits. This is a great help to the simulator.! !MLargePositiveInteger methodsFor: 'arithmetic'! * anInteger "Primitive. Multiply the receiver by the argument and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " <primitive: 29> ^super * anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! + anInteger "Primitive. Add the receiver to the argument and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 21> ^super + anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! - anInteger "Primitive. Subtract the argument from the receiver and answer with an Integer result. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 22> ^super - anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! / anInteger "Primitive. Divide the receiver by the argument and answer with the result if the division is exact. Fail if the result is not a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " <primitive: 30> ^super / anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! // anInteger "Primitive. Divide the receiver by the argument and return the result. Round the result down towards negative infinity to make it a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive. " <primitive: 32> ^super // anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! \\ anInteger "Primitive. Take the receiver modulo the argument. The result is the remainder rounded towards negative infinity, of the receiver divided by the argument. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 31> ^super \\ anInteger! ! !MLargePositiveInteger methodsFor: 'arithmetic'! abs! ! !MLargePositiveInteger methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:36'! negated ^ (self copyto: (MLargeNegativeInteger new: self digitLength)) normalize "Need to normalize to catch SmallInteger minVal" ! ! !MLargePositiveInteger methodsFor: 'arithmetic'! quo: anInteger "Primitive. Divide the receiver by the argument and return the result. Round the result down towards zero to make it a whole integer. Fail if the argument is 0. Fail if either the argument or the result is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 33> ^super quo: anInteger! ! !MLargePositiveInteger methodsFor: 'bit manipulation'! bitAnd: anInteger "Primitive. Answer an Integer whose bits are the logical AND of the receiver's bits and those of the argument. Fail if the receiver or argument is greater than 32 bits. See Object documentation whatIsAPrimitive." <primitive: 14> ^ super bitAnd: anInteger! ! !MLargePositiveInteger methodsFor: 'bit manipulation'! bitOr: anInteger "Primitive. Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument. Fail if the receiver or argument is greater than 32 bits. See Object documentation whatIsAPrimitive." <primitive: 15> ^ super bitOr: anInteger! ! !MLargePositiveInteger methodsFor: 'bit manipulation'! bitShift: anInteger "Primitive. Answer an Integer whose value (in twos-complement representation) is the receiver's value (in twos-complement representation) shifted left by the number of bits indicated by the argument. Negative arguments shift right. Zeros are shifted in from the right in left shifts. The sign bit is extended in right shifts. Fail if the receiver or result is greater than 32 bits. See Object documentation whatIsAPrimitive." <primitive: 17> ^super bitShift: anInteger! ! !MLargePositiveInteger methodsFor: 'bit manipulation'! bitXor: anInteger "Primitive. Answer an Integer whose bits are the logical XOR of the receiver's bits and those of the argument. Fail if the receiver or argument is greater than 32 bits. See Object documentation whatIsAPrimitive." <primitive: 16> ^ super bitXor: anInteger! ! !MLargePositiveInteger methodsFor: 'bit manipulation' stamp: 'di 5/19/1998 20:23'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. This method is allowed (and needed) for LargeNegativeIntegers as well, since Squeak's LargeIntegers are sign/magnitude." | realLength lastDigit | realLength _ self digitLength. [(lastDigit _ self digitAt: realLength) = 0] whileTrue: [(realLength _ realLength - 1) = 0 ifTrue: [^ 0]]. ^ lastDigit highBit + (8 * (realLength - 1)) ! ! !MLargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ false! ! !MLargePositiveInteger methodsFor: 'testing' stamp: 'jm 3/27/98 06:19'! sign "Optimization. Answer 1 since receiver is greater than 0." ^ 1 ! ! !MLargePositiveInteger methodsFor: 'comparing'! < anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is less than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 23> ^super < anInteger! ! !MLargePositiveInteger methodsFor: 'comparing'! <= anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is less than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 25> ^super <= anInteger! ! !MLargePositiveInteger methodsFor: 'comparing'! = anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is equal to the argument. Otherwise answer false. Fail if the receiver or argument is negative or greater than 32 bits. Optional. See Object documentation whatIsAPrimitive." <primitive: 7> ^ super = anInteger! ! !MLargePositiveInteger methodsFor: 'comparing'! > anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 24> ^super > anInteger! ! !MLargePositiveInteger methodsFor: 'comparing'! >= anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger or a LargePositiveInteger less than 2-to-the-30th (1073741824). Optional. See Object documentation whatIsAPrimitive." <primitive: 26> ^super >= anInteger! ! !MLargePositiveInteger methodsFor: 'comparing'! ~= anInteger "Primitive. Compare the receiver with the argument and answer true if the receiver is equal to the argument. Otherwise answer false. Fail if the receiver or argument is negative or greater than 32 bits. Optional. See Object documentation whatIsAPrimitive." <primitive: 8> ^ super ~= anInteger! ! !MLargePositiveInteger methodsFor: 'converting' stamp: 'jm 11/13/2002 17:22'! normalize "Check for leading zeroes and return shortened copy if so" | sLen val len oldLen | "First establish len = significant length" len _ oldLen _ self digitLength. [len = 0 ifTrue: [^0]. (self digitAt: len) = 0] whileTrue: [len _ len - 1]. "Now check if in SmallInteger range" sLen _ MSmallInteger maxVal digitLength. (len <= sLen and: [(self digitAt: sLen) <= (MSmallInteger maxVal digitAt: sLen)]) ifTrue: ["If so, return its SmallInt value" val _ 0. len to: 1 by: -1 do: [:i | val _ (val *256) + (self digitAt: i)]. ^ val]. "Return self, or a shortened copy" len < oldLen ifTrue: [^ self growto: len] ifFalse: [^ self]! ! !MLargePositiveInteger methodsFor: 'system primitives'! digitAt: index "Primitive. Answer the value of an indexable field in the receiver. Fail if the argument (the index) is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." <primitive: 60> self digitLength < index ifTrue: [^0] ifFalse: [^super at: index]! ! !MLargePositiveInteger methodsFor: 'system primitives'! digitAt: index put: value "Primitive. Store the second argument (value) in the indexable field of the receiver indicated by index. Fail if the value is negative or is larger than 255. Fail if the index is not an Integer or is out of bounds. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." <primitive: 61> ^super at: index put: value! ! !MLargePositiveInteger methodsFor: 'system primitives'! digitLength "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." <primitive: 62> self primitiveFailed! ! !MLargePositiveInteger methodsFor: 'system primitives'! 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." <primitive: 105> ^ super replaceFrom: start to: stop with: replacement startingAt: repStart! ! I hold shared behavior for objects that measure something linear such numbers, dates, and times. I support comparisons via <, =, and >, as well as min/max. ! !MMagnitude methodsFor: 'comparing'! < aMagnitude "Answer whether the receiver is less than the argument." ^self subclassResponsibility! ! !MMagnitude methodsFor: 'comparing'! <= aMagnitude "Answer whether the receiver is less than or equal to the argument." ^(self > aMagnitude) not! ! !MMagnitude methodsFor: 'comparing'! = aMagnitude "Compare the receiver with the argument and answer with true if the receiver is equal to the argument. Otherwise answer false." ^self subclassResponsibility! ! !MMagnitude methodsFor: 'comparing'! > aMagnitude "Answer whether the receiver is greater than the argument." ^aMagnitude < self! ! !MMagnitude methodsFor: 'comparing'! >= aMagnitude "Answer whether the receiver is greater than or equal to the argument." ^(self < aMagnitude) not! ! !MMagnitude methodsFor: 'comparing'! between: min and: max "Answer whether the receiver is less than or equal to the argument, max, and greater than or equal to the argument, min." ^self >= min and: [self <= max]! ! !MMagnitude methodsFor: 'comparing'! hash "Hash must be redefined whenever = is redefined." ^self subclassResponsibility! ! !MMagnitude methodsFor: 'testing'! max: aMagnitude "Answer the receiver or the argument, whichever has the greater magnitude." self > aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! !MMagnitude methodsFor: 'testing'! min: aMagnitude "Answer the receiver or the argument, whichever has the lesser magnitude." self < aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! When a message is not understood by its receiver, the virtual machine creates an instance of me to record the selector and arguments of the message and sends the receiver #doesNotUnderstand: with this Message object as the argument. The allows objects to respond the message in some other way if they so choose. ! !MMessage methodsFor: 'accessing' stamp: 'jm 10/28/2003 09:18'! arguments "Answer the message arguments array." ^ arguments ! ! !MMessage methodsFor: 'accessing' stamp: 'jm 10/28/2003 09:19'! lookupClass "Answer the message lookupClass." ^ lookupClass ! ! !MMessage methodsFor: 'accessing' stamp: 'jm 10/28/2003 09:15'! selector "Answer the message selector." ^ selector ! ! !MMessage methodsFor: 'sending' stamp: 'jm 10/28/2003 09:18'! sentTo: anObject "Answer the result of sending this message to the given object." lookupClass == nil ifTrue: [^ anObject perform: selector withArguments: arguments] ifFalse: [^ anObject perform: selector withArguments: arguments inSuperclass: lookupClass]. ! ! !MMessage methodsFor: 'printing' stamp: 'jm 12/8/2003 22:44'! printOn: aStream "Refer to the comment in Object|printOn:." super printOn: aStream. aStream nextPutAll: ' selector: ', selector printString; nextPutAll: ' args: ', arguments printString. ! ! My instances support class-specific class behavior such as class initialization and instance creation messages. There is a subclass of me for every normal class, and there is exactly one instance of each of these subclasses, one for each class. Subclasses of me get their names and class pools from their associated class. In general, the superclass hierarchy for metaclasses parallels that of their classes. For example: Integer superclass == Number, and Integer class superclass == Number class However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, but Object class superclass == Class If this is confusing, don't worry; it doesn't really matter unless you're trying to change the way classes work. ! !MMetaclass methodsFor: 'initialization' stamp: 'jm 11/30/2003 10:04'! initMethodDict: newMethodDict "Initialize myself with the given method dictionary. Create but do not initialize my soleInstance." superclass _ MClass. methodDict _ newMethodDict. format _ MClass format. "all metaclasses have the same format as MClass" soleInstance _ self basicNew. ! ! !MMetaclass methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:23'! new "Each metaclass should have exactly one instance." self cannotInstantiate. ! ! !MMetaclass methodsFor: 'accessing' stamp: 'jm 11/23/2003 10:56'! name "Answer my name, either 'Metaclass' or the name of my class followed by ' class'." soleInstance ifNil: [^ 'Metaclass'] ifNotNil: [^ soleInstance name, ' class']. ! ! !MMetaclass methodsFor: 'accessing' stamp: 'jm 11/23/2003 10:55'! soleInstance "Answer my only instance." ^ soleInstance ! ! I represent the context (stack frame) for an executing method. ! !MMethodContext methodsFor: 'accessing' stamp: 'jm 11/30/2003 16:49'! method ^ method ! ! !MMethodContext methodsFor: 'accessing' stamp: 'jm 10/28/2003 14:08'! removeSelf "Nil the receiver pointer and answer its former value." | result | result _ receiver. receiver _ nil. ^ result ! ! I am used by Behaviors to hold the correspondence between selectors (names of methods) and the CompiledMethod objects. I behave like a normal Dictionary but I am implemented differently. In a normal Dictionary, the instance variable 'array' holds an array of Associations. But since there are thousands of methods in the system, these Associations objects would waste space. Thus, I am implemented as a variable-sized object that keeps the list of keys (selectors) in the indexable fields of the instance and keeps the values (CompiledMethods) in the instance variable 'array'. Note: The virtual machine depends on my representation. Don't change it unless you really know what you're doing!! ! !MMethodDictionary methodsFor: 'accessing' stamp: 'jm 10/28/2003 10:20'! add: anAssociation ^ self at: anAssociation key put: anAssociation value ! ! !MMethodDictionary methodsFor: 'accessing'! at: key ifAbsent: aBlock | index | index _ self findElementOrNil: key. (self basicAt: index) == nil ifTrue: [ ^ aBlock value ]. ^ array at: index ! ! !MMethodDictionary methodsFor: 'accessing' stamp: 'jm 10/28/2003 10:20'! at: key put: value "Set the value at key to be value." | index | index _ self findElementOrNil: key. (self basicAt: index) == nil ifTrue: [tally _ tally + 1. self basicAt: index put: key]. array at: index put: value. self fullCheck. ^ value ! ! !MMethodDictionary methodsFor: 'accessing' stamp: 'jm 10/28/2003 10:19'! includesKey: aSymbol "This override assumes that pointsTo is a fast primitive." ^ super pointsTo: aSymbol ! ! !MMethodDictionary methodsFor: 'accessing' stamp: 'jm 11/30/2003 17:11'! keyAtIdentityValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." | k | 1 to: self basicSize do: [:i | value == (array at: i) ifTrue: [ (k _ self basicAt: i) ifNotNil: [^ k]]]. ^ exceptionBlock value ! ! !MMethodDictionary methodsFor: 'removing' stamp: 'jm 10/28/2003 10:21'! removeKey: key ifAbsent: errorBlock "MicroSqueak does not support method removal." self shouldNotImplement. ! ! !MMethodDictionary methodsFor: 'enumeration' stamp: 'jm 11/24/2003 09:22'! associationsDo: aBlock | key | tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (key _ self basicAt: i) ifNotNil: [ aBlock value: (key -> (array at: i))]]. ! ! !MMethodDictionary methodsFor: 'enumeration' stamp: 'jm 10/28/2003 10:24'! do: aBlock tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (self basicAt: i) ifNotNil: [aBlock value: (array at: i)]]. ! ! !MMethodDictionary methodsFor: 'enumeration' stamp: 'jm 10/28/2003 10:23'! keysDo: aBlock | key | tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (key _ self basicAt: i) ifNotNil: [aBlock value: key]]. ! ! !MMethodDictionary methodsFor: 'copying' stamp: 'jm 12/2/2003 22:32'! copy "Copy my values array." ^ self basicCopy withArray: array basicCopy ! ! !MMethodDictionary methodsFor: 'private' stamp: 'jm 10/28/2003 10:28'! grow | newSelf key | newSelf _ self species new: self basicSize. "This will double the size" 1 to: self basicSize do: [:i | key _ self basicAt: i. key == nil ifFalse: [newSelf at: key put: (array at: i)]]. self become: newSelf. ! ! !MMethodDictionary methodsFor: 'private'! keyAt: index ^ self basicAt: index ! ! !MMethodDictionary methodsFor: 'private' stamp: 'jm 10/28/2003 10:32'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start _ (anObject identityHash \\ array size) + 1. finish _ array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ self basicAt: index) == nil or: [element == anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot" ! ! !MMethodDictionary methodsFor: 'private' stamp: 'jm 10/28/2003 10:31'! swap: oneIndex with: otherIndex | element | element _ self basicAt: oneIndex. self basicAt: oneIndex put: (self basicAt: otherIndex). self basicAt: otherIndex put: element. super swap: oneIndex with: otherIndex. ! ! !MMethodDictionary class methodsFor: 'instance creation' stamp: 'jm 10/28/2003 10:13'! new: nElements "Create a Dictionary large enough to hold nElements without growing." "NOTE: The basic size MUST be a power of 2. It is VITAL (see grow) that size gets doubled if nElements is a power of 2." | size | size _ 1 bitShift: nElements highBit. ^ (self basicNew: size) init: size ! ! I am the superclass for all numbers. My descendent subclasses provide concrete representations of particular kinds of numbers. All my subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If self<typeA> op: arg<typeB> fails because of incompatible types, then it is retried in the following form: (arg adaptToTypeA: self) op: arg adaptToTypeA. This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Squeak. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number. ! !MNumber methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by aNumber." self subclassResponsibility! ! !MNumber methodsFor: 'arithmetic'! + aNumber "Answer the sum of the receiver and aNumber." self subclassResponsibility! ! !MNumber methodsFor: 'arithmetic'! - aNumber "Answer the difference between the receiver and aNumber." self subclassResponsibility! ! !MNumber methodsFor: 'arithmetic'! / aNumber "Answer the result of dividing the receiver by aNumber." self subclassResponsibility! ! !MNumber methodsFor: 'arithmetic'! // aNumber "Integer quotient defined by division with truncation toward negative infinity. 9//4 = 2, -9//4 = -3. -0.9//0.4 = -3. \\ answers the remainder from this division." ^(self / aNumber) floor! ! !MNumber methodsFor: 'arithmetic'! \\ aNumber "modulo. Remainder defined in terms of //. Answer a Number with the same sign as aNumber. e.g. 9\\4 = 1, -9\\4 = 3, 9\\-4 = -3, 0.9\\0.4 = 0.1." ^self - (self // aNumber * aNumber)! ! !MNumber methodsFor: 'arithmetic'! abs "Answer a Number that is the absolute value (positive magnitude) of the receiver." self < 0 ifTrue: [^self negated] ifFalse: [^self]! ! !MNumber methodsFor: 'arithmetic'! negated "Answer a Number that is the negation of the receiver." ^0 - self! ! !MNumber methodsFor: 'arithmetic'! quo: aNumber "Integer quotient defined by division with truncation toward zero. -9 quo: 4 = -2, -0.9 quo: 0.4 = -2. rem: answers the remainder from this division." ^(self / aNumber) truncated! ! !MNumber methodsFor: 'arithmetic'! reciprocal "Answer 1 divided by the receiver. Create an error notification if the receiver is 0." self = 0 ifTrue: [^self error: 'zero has no reciprocal'] ifFalse: [^1 / self]! ! !MNumber methodsFor: 'arithmetic'! rem: aNumber "Remainder defined in terms of quo:. Answer a Number with the same sign as self. e.g. 9 rem: 4 = 1, -9 rem: 4 = -1. 0.9 rem: 0.4 = 0.1." ^self - ((self quo: aNumber) * aNumber)! ! !MNumber methodsFor: 'mathematical functions'! arcCos "The receiver is the cosine of an angle. Answer the angle measured in radians." ^self asFloat arcCos! ! !MNumber methodsFor: 'mathematical functions'! arcSin "The receiver is the sine of an angle. Answer the angle measured in radians." ^self asFloat arcSin! ! !MNumber methodsFor: 'mathematical functions'! arcTan "The receiver is the tangent of an angle. Answer the angle measured in radians." ^self asFloat arcTan! ! !MNumber methodsFor: 'mathematical functions'! cos "The receiver represents an angle measured in radians. Answer its cosine." ^self asFloat cos! ! !MNumber methodsFor: 'mathematical functions'! exp "Answer the exponential of the receiver as a floating point number." ^self asFloat exp! ! !MNumber methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:16'! floorLog: radix "Answer the floor of the log base radix of the receiver." ^ self asFloat floorLog: radix ! ! !MNumber methodsFor: 'mathematical functions'! ln "Answer the natural log of the receiver." ^self asFloat ln! ! !MNumber methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'! log "Answer the base-10 log of the receiver." ^self asFloat log! ! !MNumber methodsFor: 'mathematical functions'! log: aNumber "Answer the log base aNumber of the receiver." ^self ln / aNumber ln! ! !MNumber methodsFor: 'mathematical functions'! raisedTo: aNumber "Answer the receiver raised to aNumber." (aNumber isInteger) ifTrue: ["Do the special case of integer power" ^self raisedToInteger: aNumber]. aNumber = 0 ifTrue: [^1]. "Special case of exponent=0" aNumber = 1 ifTrue: [^self]. "Special case of exponent=1" ^(aNumber * self ln) exp "Otherwise raise it to the power using logarithms"! ! !MNumber methodsFor: 'mathematical functions'! raisedToInteger: anInteger "Answer the receiver raised to the power anInteger where the argument must be a kind of Integer. This is a special case of raisedTo:." (anInteger isInteger) ifFalse: [^self error: 'raisedToInteger: only works for integral arguments']. anInteger = 0 ifTrue: [^1]. anInteger = 1 ifTrue: [^self]. anInteger > 1 ifTrue: [^(self * self raisedToInteger: anInteger // 2) * (self raisedToInteger: anInteger \\ 2)]. ^(self raisedToInteger: anInteger negated) reciprocal! ! !MNumber methodsFor: 'mathematical functions'! sin "The receiver represents an angle measured in radians. Answer its sine." ^self asFloat sin! ! !MNumber methodsFor: 'mathematical functions'! sqrt "Answer the square root of the receiver." ^self asFloat sqrt! ! !MNumber methodsFor: 'mathematical functions'! tan "The receiver represents an angle measured in radians. Answer its tangent." ^self asFloat tan! ! !MNumber methodsFor: 'truncation and round off' stamp: 'jm 12/31/2003 10:06'! ceiling "Answer the integer nearest the receiver toward positive infinity." self <= 0 ifTrue: [^ self truncated] ifFalse: [^ self negated floor negated] ! ! !MNumber methodsFor: 'truncation and round off'! floor "Answer the integer nearest the receiver toward negative infinity." | truncation | truncation _ self truncated. self >= 0 ifTrue: [^truncation]. self = truncation ifTrue: [^truncation] ifFalse: [^truncation - 1]! ! !MNumber methodsFor: 'truncation and round off'! roundTo: aNumber "Answer the integer that is a multiple of aNumber that is nearest the receiver." ^(self / aNumber) rounded * aNumber! ! !MNumber methodsFor: 'truncation and round off' stamp: 'jm 11/30/2003 16:40'! roundUpTo: aNumber "Answer the next multiple of aNumber toward infinity that is nearest the receiver." ^ (self / aNumber) ceiling * aNumber ! ! !MNumber methodsFor: 'truncation and round off'! rounded "Answer the integer nearest the receiver." ^(self + (self sign / 2)) truncated! ! !MNumber methodsFor: 'truncation and round off'! truncateTo: aNumber "Answer the next multiple of aNumber toward zero that is nearest the receiver." ^(self quo: aNumber) * aNumber! ! !MNumber methodsFor: 'truncation and round off'! truncated "Answer an integer nearest the receiver toward zero." ^self quo: 1! ! !MNumber methodsFor: 'testing'! isNumber ^ true! ! !MNumber methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ self < 0! ! !MNumber methodsFor: 'testing'! sign "Answer 1 if the receiver is greater than 0, -1 if less than 0, else 0." self > 0 ifTrue: [^1]. self < 0 ifTrue: [^-1]. ^0! ! !MNumber methodsFor: 'converting' stamp: 'jm 12/2/2003 21:38'! adaptToFloat: rcvr andSend: selector "If I am involved in arithmetic with a Float, convert me to a Float." ^ rcvr perform: selector with: self asFloat ! ! !MNumber methodsFor: 'converting' stamp: 'jm 12/2/2003 21:40'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock." ^ self subclassResponsibility ! ! !MNumber methodsFor: 'converting'! asInteger "Answer an Integer nearest the receiver toward zero." ^self truncated! ! !MNumber methodsFor: 'converting'! degreesToRadians "The receiver is assumed to represent degrees. Answer the conversion to radians." ^self asFloat degreesToRadians! ! !MNumber methodsFor: 'converting'! radiansToDegrees "The receiver is assumed to represent radians. Answer the conversion to degrees." ^self asFloat radiansToDegrees! ! !MNumber methodsFor: 'intervals' stamp: 'jm 11/13/2002 16:59'! to: stop "Answer an Interval from the receiver up to the argument incrementing by 1." ^ MInterval from: self to: stop by: 1 ! ! !MNumber methodsFor: 'intervals' stamp: 'jm 11/13/2002 16:59'! to: stop by: step "Answer an Interval from the receiver up to stop incrementing by step." ^ MInterval from: self to: stop by: step ! ! !MNumber methodsFor: 'intervals'! to: stop by: step do: aBlock "Normally compiled in-line, and therefore not overridable. Evaluate aBlock for each element of the interval (self to: stop by: step)." | nextValue | nextValue _ self. step < 0 ifTrue: [[stop <= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]] ifFalse: [[stop >= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]]! ! !MNumber methodsFor: 'intervals'! to: stop do: aBlock "Normally compiled in-line, and therefore not overridable. Evaluate aBlock for each element of the interval (self to: stop by: 1)." | nextValue | nextValue _ self. [nextValue <= stop] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + 1]! ! !MNumber methodsFor: 'printing'! printOn: aStream "Default print radix is 10" self printOn: aStream base: 10! ! !MNumber methodsFor: 'printing' stamp: 'jm 10/29/2003 12:05'! printStringBase: base | stream | stream _ MWriteStream on: (MString new: 100). self printOn: stream base: base. ^ stream contents ! ! !MNumber class methodsFor: 'instance creation' stamp: 'jm 12/2/2003 21:34'! readFrom: stringOrStream "Answer a number as described on aStream. The number may include a leading radix specification, as in 16rFADE." | value base aStream sign | aStream _ (stringOrStream class = MString) ifTrue: [MReadStream on: stringOrStream] ifFalse: [stringOrStream]. sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. base _ 10. value _ MInteger readFrom: aStream base: base. (aStream peekFor: $r) ifTrue: [ "<base>r<integer>" (base _ value) < 2 ifTrue: [^ self error: 'Invalid radix']. (aStream peekFor: $-) ifTrue: [sign _ sign negated]. value _ MInteger readFrom: aStream base: base]. ^ self readRemainderOf: value from: aStream base: base withSign: sign ! ! !MNumber class methodsFor: 'instance creation' stamp: 'jm 12/2/2003 21:34'! readFrom: stringOrStream base: base "Answer a number as described on aStream in the given number base." | aStream sign | aStream _ (stringOrStream class = MString) ifTrue: [MReadStream on: stringOrStream] ifFalse: [stringOrStream]. sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. ^ self readRemainderOf: (MInteger readFrom: aStream base: base) from: aStream base: base withSign: sign ! ! !MNumber class methodsFor: 'instance creation' stamp: 'jm 10/27/2003 07:47'! readRemainderOf: integerPart from: aStream base: base withSign: sign "Read optional fractional part and exponent, and return the final result" "MNumber readFrom: (ReadStream on: '3r-22.2')" | value fraction fracpos | value _ integerPart. (aStream peekFor: $.) ifTrue: [ "<integer>.<fraction>" (aStream atEnd not and: [aStream peek digitValue between: 0 and: base - 1]) ifTrue: [ fracpos _ aStream position. fraction _ MInteger readFrom: aStream base: base. fraction _ fraction asFloat / (base raisedTo: aStream position - fracpos). value _ value asFloat + fraction] ifFalse: [ "oops - just <integer>." aStream skip: -1. "un-gobble the period" ^ value * sign]]. (aStream peekFor: $e) ifTrue: [ "<integer>e<exponent>" value _ value * (base raisedTo: (MInteger readFrom: aStream))]. ^ value * sign ! ! I provide default behavior common to all objects, such as class access, copying and printing. ! !MObject methodsFor: 'initialization' stamp: 'jm 10/28/2003 14:11'! initialize "Initialize this object. Usually called by new when a new object is created. This default implementation does nothing." ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/28/2003 22:10'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." <primitive: 60> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^ self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]. ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/28/2003 22:11'! at: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." <primitive: 61> index isInteger ifTrue: [ (index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^ self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]. ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/14/2002 14:16'! basicAt: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." <primitive: 60> index isInteger ifTrue: [self errorSubscriptBounds: index]. index isNumber ifTrue: [^ self basicAt: index asInteger] ifFalse: [self errorNonIntegerIndex]. ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/14/2002 14:18'! basicAt: index put: value "Primitive. Assumes receiver is indexable. Store the second argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. Do not override in a subclass. See Object documentation whatIsAPrimitive." <primitive: 61> index isInteger ifTrue: [ (index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]]. index isNumber ifTrue: [^ self basicAt: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]. ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/14/2002 14:14'! basicSize "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. Do not override in any subclass. See Object documentation whatIsAPrimitive." <primitive: 62> ^ 0 "for fixed-size objects" ! ! !MObject methodsFor: 'accessing'! instVarAt: index "Primitive. Answer a fixed variable in an object. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Essential. See Object documentation whatIsAPrimitive." <primitive: 73> "Access beyond fixed variables." ^self basicAt: index - self class instSize ! ! !MObject methodsFor: 'accessing'! instVarAt: anInteger put: anObject "Primitive. Store a value into a fixed variable in the receiver. The numbering of the variables corresponds to the named instance variables. Fail if the index is not an Integer or is not the index of a fixed variable. Answer the value stored as the result. Using this message violates the principle that each object has sovereign control over the storing of values into its instance variables. Essential. See Object documentation whatIsAPrimitive." <primitive: 74> "Access beyond fixed fields" ^self basicAt: anInteger - self class instSize put: anObject! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/14/2002 14:30'! species "Answer the preferred class for reconstructing the receiver, which is typically some kind of collection. For example, the response to this message determines the type of object returned by the collect: or select: messages. Species and class are not always the same. For example, the species of Interval is Array." ^ self class ! ! !MObject methodsFor: 'accessing' stamp: 'jm 11/11/2002 19:04'! yourself "Answer the receiver. Useful in cascaded message expressions." ! ! !MObject methodsFor: 'testing'! ifNil: nilBlock "Return self, or evaluate the block if I'm == nil (q.v.)" ^ self! ! !MObject methodsFor: 'testing'! ifNil: nilBlock ifNotNil: ifNotNilBlock "Evaluate the block, unless I'm == nil (q.v.)" ^ ifNotNilBlock value! ! !MObject methodsFor: 'testing'! ifNotNil: ifNotNilBlock "Evaluate the block, unless I'm == nil (q.v.)" ^ ifNotNilBlock value! ! !MObject methodsFor: 'testing'! ifNotNil: ifNotNilBlock ifNil: nilBlock "If I got here, I am not nil, so evaluate the block ifNotNilBlock" ^ ifNotNilBlock value! ! !MObject methodsFor: 'testing' stamp: 'jm 11/24/2003 14:20'! isBehavior "Answer true if I am a subclass of Behavior." ^ false ! ! !MObject methodsFor: 'testing'! isInteger "Overridden to return true in Integer." ^ false! ! !MObject methodsFor: 'testing' stamp: 'jm 11/11/2002 18:59'! isNil "Answer true if the receiver is nil." ^ false ! ! !MObject methodsFor: 'testing'! isNumber "Overridden to return true in Number, natch" ^ false! ! !MObject methodsFor: 'testing' stamp: 'jm 10/27/2003 07:37'! isSmallInteger ^ false ! ! !MObject methodsFor: 'testing' stamp: 'jm 11/14/2002 14:35'! pointsTo: anObject "Answer true if the receiver contains a reference to the given object." <primitive: 132> 1 to: self class instSize do: [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. 1 to: self basicSize do: [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. ^ false ! ! !MObject methodsFor: 'comparing'! = anObject "Answer whether the receiver and the argument represent the same object. If = is redefined in any subclass, consider also redefining the message hash." ^self == anObject! ! !MObject methodsFor: 'comparing'! == anObject "Primitive. Answer whether the receiver and the argument are the same object (have the same object pointer). Do not redefine the message == in any other class!! Essential. No Lookup. Do not override in any subclass. See Object documentation whatIsAPrimitive." <primitive: 110> self primitiveFailed! ! !MObject methodsFor: 'comparing'! hash "Answer a SmallInteger whose value is related to the receiver's identity. May be overridden, and should be overridden in any classes that define = " ^ self identityHash! ! !MObject methodsFor: 'comparing' stamp: 'jm 11/14/2002 14:21'! identityHash "Answer a SmallInteger whose value is related to the receiver's identity. This method must not be overridden, except by SmallInteger. Primitive. Fails if the receiver is a SmallInteger. Essential. See Object documentation whatIsAPrimitive. Do not override!!" <primitive: 75> self primitiveFailed ! ! !MObject methodsFor: 'comparing' stamp: 'jm 11/14/2002 14:22'! ~= anObject "Answer whether the receiver and the argument do not represent the same object." ^ (self = anObject) == false ! ! !MObject methodsFor: 'comparing'! ~~ anObject "Answer whether the receiver and the argument are not the same object (do not have the same object pointer)." self == anObject ifTrue: [^ false] ifFalse: [^ true]! ! !MObject methodsFor: 'copying' stamp: 'jm 12/2/2003 22:30'! basicCopy "Answer a copy of the receiver that shares the receiver's instance variables. This is usually handled by the primitive, so the code below is for documentation." | class result sz | <primitive: 148> class _ self class. class isVariable ifTrue: [ sz _ self basicSize. result _ class basicNew: sz. 1 to: sz do: [:i | result basicAt: i put: (self basicAt: i)]] ifFalse: [ result _ class basicNew]. 1 to: class instSize do: [:i | result instVarAt: i put: (self instVarAt: i)]. ^ result ! ! !MObject methodsFor: 'copying' stamp: 'jm 12/2/2003 22:36'! copy "Answer a copy of me. Subclasses should usually override this method to change copying behavior, not basicCopy. The exception is classes with unique instances, such as Symbol. This operation does not generally copy all the objects that I refer to.." ^ self basicCopy ! ! !MObject methodsFor: 'converting' stamp: 'jm 12/2/2003 21:37'! -> anObject "Answer an Association with myself as its key and anObject as its value." ^ MAssociation new key: self value: anObject ! ! !MObject methodsFor: 'class membership' stamp: 'jm 12/2/2003 21:32'! class "Primitive. Answer the object which is the receiver's class. Essential. See Object documentation whatIsAPrimitive." <primitive: 111> self primitiveFailed ! ! !MObject methodsFor: 'class membership' stamp: 'jm 11/14/2002 21:14'! isKindOf: aClass "Answer whether the class, aClass, is a superclass or class of the receiver." self class == aClass ifTrue: [^ true] ifFalse: [^ self class inheritsFrom: aClass]. ! ! !MObject methodsFor: 'class membership' stamp: 'jm 11/14/2002 20:59'! respondsTo: aSymbol "Answer whether the receiver's class or one of its superclasses has the given symbol as a message selector." ^ self class canUnderstand: aSymbol ! ! !MObject methodsFor: 'error handling' stamp: 'jm 12/8/2003 22:09'! doesNotUnderstand: aMessage "Handle a failed attempt to send the given message to the receiver because the receiver does not implement or inherit a method for the message selector. The 'doesNotUnderstand:' message is sent by the virtual machine when a message send fails. If the receiver has an error handling block, invoke it. Otherwise, report an error." "MObject new snark" | errorString handler | errorString _ 'Message not understood: ', aMessage selector. (handler _ Processor activeProcess errorHandler) ifNil: [self handleExceptionName: errorString context: thisContext] ifNotNil: [handler value: errorString value: self]. ^ aMessage sentTo: self "resend the message if the user proceeds from the debugger" ! ! !MObject methodsFor: 'error handling' stamp: 'jm 12/8/2003 22:10'! error: aString "The default behavior for error: is the same as halt:. The code is replicated in order to avoid having an extra message send on the stack. This additional message is the one a subclass should override in order to change the error handling behavior." "MObject new error: 'test error'" | handler | (handler _ Processor activeProcess errorHandler) ifNil: [self handleExceptionName: aString context: thisContext] ifNotNil: [handler value: aString value: self] ! ! !MObject methodsFor: 'error handling' stamp: 'jm 12/24/2003 09:55'! handleExceptionName: aString context: aContext "Handle an error or halt with the given name in the given context." "Not yet implemented. For now, just print the error and exit." MObject superclass ifNil: [ self putString: aString; putcr. MSystem exitToDebugger] "exit to the VM debugger" ifNotNil: [super error: aString]. "running in Squeak; use Squeak error handler" ! ! !MObject methodsFor: 'errors' stamp: 'jm 12/2/2003 21:28'! errorImproperStore "Error: an improper store was attempted." self error: 'Improper store into indexable object.' ! ! !MObject methodsFor: 'errors' stamp: 'jm 12/2/2003 21:27'! errorNonIntegerIndex "Error: attempting to use a non-integer object as an index." self error: 'Only integers should be used as indices.' ! ! !MObject methodsFor: 'errors' stamp: 'jm 12/2/2003 21:28'! errorSubscriptBounds: index "Error: the given index is out of range." self error: 'Subscript is out of bounds: ', index printString ! ! !MObject methodsFor: 'errors' stamp: 'jm 12/17/2003 22:01'! mustBeBoolean "Error: attempt to use a non-Boolean object as if it were true or false. This message is sent by the virtual machine." self error: 'NonBoolean receiver.'. ^ true ! ! !MObject methodsFor: 'errors' stamp: 'jm 10/27/2003 06:09'! primitiveFailed "Announce that a primitive has failed." self error: 'a primitive has failed'. ! ! !MObject methodsFor: 'errors' stamp: 'jm 11/14/2002 14:24'! shouldNotImplement "Announce that, although the receiver inherits this message, it should not implement it." self error: 'This message is not appropriate for this object' ! ! !MObject methodsFor: 'errors' stamp: 'jm 11/14/2002 14:26'! subclassResponsibility "This message sets up a framework for the behavior of subclasses of this class. Announce that the subclass should have implemented this message." self error: 'My subclass should have overridden one of my messages.' ! ! !MObject methodsFor: 'perform' stamp: 'jm 11/13/2002 16:54'! perform: aSymbol "Primitive. Send the receiver the unary message indicated by the argument. The argument is the selector of the message. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not zero. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (MArray new: 0) ! ! !MObject methodsFor: 'perform' stamp: 'jm 11/13/2002 16:54'! perform: aSymbol with: anObject "Primitive. Send the receiver the keyword message indicated by the arguments. The first argument is the selector of the message. The other argument is the argument of the message to be sent. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not one. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (MArray with: anObject) ! ! !MObject methodsFor: 'perform' stamp: 'jm 12/2/2003 21:34'! perform: selector withArguments: anArray "Primitive. Send the receiver the keyword message indicated by the arguments. The argument, selector, is the selector of the message. The arguments of the message are the elements of anArray. Invoke messageNotUnderstood: if the number of arguments expected by the selector is not the same as the length of anArray. Essential. See Object documentation whatIsAPrimitive." <primitive: 84> (selector class = MSymbol) ifFalse: [^ self error: 'selector argument must be a Symbol']. self primitiveFailed! ! !MObject methodsFor: 'perform' stamp: 'jm 12/2/2003 21:34'! perform: selector withArguments: argArray inSuperclass: lookupClass "NOTE: This is just like perform:withArguments: except that the message lookup process begins, not with the receivers's class, but with the supplied superclass instead. It will fail if lookupClass cannot be found among the receiver's superclasses. Primitive. Essential. See Object documentation whatIsAPrimitive." <primitive: 100> (selector class = MSymbol) ifFalse: [^ self error: 'selector argument must be a Symbol']. (selector numArgs = argArray size) ifFalse: [^ self error: 'incorrect number of arguments']. (self class == lookupClass or: [self class inheritsFrom: lookupClass]) ifFalse: [^ self error: 'lookupClass is not in my inheritance chain']. self primitiveFailed. ! ! !MObject methodsFor: 'printing' stamp: 'jm 12/2/2003 21:30'! printOn: aStream "Print a description of me on the given stream." | n | n _ self class name. aStream nextPutAll: (n first isVowel ifTrue: ['an '] ifFalse: ['a ']), n ! ! !MObject methodsFor: 'printing' stamp: 'jm 12/2/2003 21:31'! printString "Answer a string describing me." | stream | stream _ MWriteStream on: (MString new: 100). self printOn: stream. ^ stream contents ! ! !MObject methodsFor: 'printing' stamp: 'jm 12/22/2003 16:22'! putString: aString "Write the given string to the standard output stream." aString do: [:ch | self putAscii: ch asciiValue]. ! ! !MObject methodsFor: 'printing' stamp: 'jm 12/22/2003 16:38'! putcr "Write a carriage return to the standard output stream." self putAscii: 13. ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 11/13/2002 16:53'! become: otherObject "Swap the object pointers of the receiver and the argument. After this, all variables in the entire system that used to point to the receiver now point to the argument, and vice-versa. Fails if either object is a SmallInteger." (MArray with: self) elementsExchangeIdentityWith: (MArray with: otherObject) ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 12/2/2003 08:11'! beep "Emit a short beep sound. Do nothing if the primitive fails." <primitive: 140> ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 11/14/2002 20:23'! nextInstance "Primitive. Answer the next instance after the receiver in the enumeration of all instances of this class. Fails if all instances have been enumerated. Essential. See Object documentation whatIsAPrimitive." <primitive: 78> ^ nil ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 10/27/2003 06:10'! nextObject "Primitive. Answer the next object after the receiver in the enumeration of all objects. Answer 0 when all objects have been enumerated." <primitive: 139> self primitiveFailed ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 12/22/2003 16:02'! putAscii: asciiValue "Put the given ascii character (0..255) to standard output. Do nothing if this primitive is not supported." <primitive: 249> ! ! !MObject methodsFor: 'system primitives' stamp: 'jm 10/27/2003 06:09'! someObject "Primitive. Answer the first object in the enumeration of all objects." <primitive: 138> self primitiveFailed ! ! !MObject class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:32'! cannotInstantiate "This message is sent if you try to create new instances of classes with unique instances such as booleans or characters." self error: 'You cannot create new instances of ', self name ! ! !MObject class methodsFor: 'instance creation' stamp: 'jm 10/28/2003 14:10'! new "Create a new instance of me and initialize it." ^ self basicNew initialize ! ! I represent a collection of objects that grows as new objects are added. Objects can be added at the front, back, or even inserted at an arbitrary position. ! !MOrderedCollection methodsFor: 'accessing'! at: anInteger "Answer my element at index anInteger. at: is used by a knowledgeable client to access an existing element" (anInteger < 1 or: [anInteger + firstIndex - 1 > lastIndex]) ifTrue: [self errorNoSuchElement] ifFalse: [^ array at: anInteger + firstIndex - 1]! ! !MOrderedCollection methodsFor: 'accessing'! at: anInteger put: anObject "Put anObject at element index anInteger. at:put: cannot be used to append, front or back, to an ordered collection; it is used by a knowledgeable client to replace an element." | index | index _ anInteger asInteger. (index < 1 or: [index + firstIndex - 1 > lastIndex]) ifTrue: [self errorNoSuchElement] ifFalse: [^array at: index + firstIndex - 1 put: anObject]! ! !MOrderedCollection methodsFor: 'accessing'! first "Answer the first element. If the receiver is empty, create an errror message. This is a little faster than the implementation in the superclass." self emptyCheck. ^ array at: firstIndex! ! !MOrderedCollection methodsFor: 'accessing'! last "Answer the last element. If the receiver is empty, create an errror message. This is a little faster than the implementation in the superclass." self emptyCheck. ^ array at: lastIndex! ! !MOrderedCollection methodsFor: 'accessing'! size ^lastIndex - firstIndex + 1! ! !MOrderedCollection methodsFor: 'copying'! copyFrom: startIndex to: endIndex "Answer a copy of the receiver that contains elements from position startIndex to endIndex." | targetCollection | endIndex < startIndex ifTrue: [^self species new: 0]. targetCollection _ self species new: endIndex + 1 - startIndex. startIndex to: endIndex do: [:index | targetCollection add: (self at: index)]. ^ targetCollection! ! !MOrderedCollection methodsFor: 'copying' stamp: 'jm 12/31/2003 12:40'! copyReplaceFrom: start to: stop with: replacementCollection "Answer a copy of the receiver with replacementCollection's elements in place of the receiver's start'th to stop'th elements. This does not expect a 1-1 map from replacementCollection to the start to stop elements, so it will do an insert or append." | newOrderedCollection delta startIndex stopIndex | "if start is less than 1, ignore stop and assume this is inserting at the front. if start greater than self size, ignore stop and assume this is appending. otherwise, it is replacing part of me and start and stop have to be within my bounds. " delta _ 0. startIndex _ start. stopIndex _ stop. start < 1 ifTrue: [startIndex _ stopIndex _ 0] ifFalse: [startIndex > self size ifTrue: [startIndex _ stopIndex _ self size + 1] ifFalse: [(stopIndex < (startIndex - 1) or: [stopIndex > self size]) ifTrue: [self error: 'indices are out of bounds']. delta _ stopIndex - startIndex + 1]]. newOrderedCollection _ self species new: self size + replacementCollection size - delta. 1 to: startIndex - 1 do: [:index | newOrderedCollection add: (self at: index)]. 1 to: replacementCollection size do: [:index | newOrderedCollection add: (replacementCollection at: index)]. stopIndex + 1 to: self size do: [:index | newOrderedCollection add: (self at: index)]. ^newOrderedCollection! ! !MOrderedCollection methodsFor: 'adding' stamp: 'jm 12/31/2003 13:50'! add: newObject "Append newObject to me. Equivalent to addLast:. Answer newObject." lastIndex = array size ifTrue: [self makeRoomAtLast]. lastIndex _ lastIndex + 1. array at: lastIndex put: newObject. ^ newObject ! ! !MOrderedCollection methodsFor: 'adding'! addFirst: newObject "Add newObject to the beginning of the receiver. Answer newObject." firstIndex = 1 ifTrue: [self makeRoomAtFirst]. firstIndex _ firstIndex - 1. array at: firstIndex put: newObject. ^ newObject! ! !MOrderedCollection methodsFor: 'removing'! remove: oldObject ifAbsent: absentBlock | index | index _ firstIndex. [index <= lastIndex] whileTrue: [oldObject = (array at: index) ifTrue: [self removeIndex: index. ^ oldObject] ifFalse: [index _ index + 1]]. ^ absentBlock value! ! !MOrderedCollection methodsFor: 'removing'! removeFirst "Remove the first element of the receiver and answer it. If the receiver is empty, create an error notification." | firstObject | self emptyCheck. firstObject _ array at: firstIndex. array at: firstIndex put: nil. firstIndex _ firstIndex + 1. ^ firstObject! ! !MOrderedCollection methodsFor: 'removing'! removeLast "Remove the last element of the receiver and answer it. If the receiver is empty, create an error notification." | lastObject | self emptyCheck. lastObject _ array at: lastIndex. array at: lastIndex put: nil. lastIndex _ lastIndex - 1. ^ lastObject! ! !MOrderedCollection methodsFor: 'enumerating'! collect: aBlock "Evaluate aBlock with each of my elements as the argument. Collect the resulting values into a collection that is like me. Answer the new collection. Override superclass in order to use add:, not at:put:." | newCollection | newCollection _ self species new. self do: [:each | newCollection add: (aBlock value: each)]. ^newCollection! ! !MOrderedCollection methodsFor: 'enumerating'! do: aBlock "Override the superclass for performance reasons." | index | index _ firstIndex. [index <= lastIndex] whileTrue: [aBlock value: (array at: index). index _ index + 1]! ! !MOrderedCollection methodsFor: 'enumerating' stamp: 'jm 10/29/2003 11:44'! select: aBlock "Evaluate aBlock with each of my elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true. Override the superclass in order to use add:, not at:put:." | newCollection | newCollection _ self species new. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^ newCollection ! ! !MOrderedCollection methodsFor: 'private'! errorNoSuchElement self error: 'attempt to index non-existent element in an ordered collection'! ! !MOrderedCollection methodsFor: 'private' stamp: 'jm 12/31/2003 13:47'! grow "Become larger. Typically, a subclass must override this method if it adds instance variables." | newArray | newArray _ MArray new: self size + (array size max: 2). newArray replaceFrom: 1 to: array size with: array startingAt: 1. array _ newArray. ! ! !MOrderedCollection methodsFor: 'private'! insert: anObject before: spot | index delta spotIndex| spotIndex _ spot. delta _ spotIndex - firstIndex. firstIndex = 1 ifTrue: [self makeRoomAtFirst. spotIndex _ firstIndex + delta]. index _ firstIndex _ firstIndex - 1. [index < (spotIndex - 1)] whileTrue: [array at: index put: (array at: index + 1). index _ index + 1]. array at: index put: anObject. ^ anObject! ! !MOrderedCollection methodsFor: 'private'! makeRoomAtFirst | delta index | delta _ array size - self size. delta = 0 ifTrue: [self grow. delta _ array size - self size]. lastIndex = array size ifTrue: [^ self]. "just in case we got lucky" index _ array size. [index > delta] whileTrue: [array at: index put: (array at: index - delta + firstIndex - 1). array at: index - delta + firstIndex - 1 put: nil. index _ index - 1]. firstIndex _ delta + 1. lastIndex _ array size! ! !MOrderedCollection methodsFor: 'private'! makeRoomAtLast | newLast delta | newLast _ self size. array size - self size = 0 ifTrue: [self grow]. (delta _ firstIndex - 1) = 0 ifTrue: [^ self]. "we might be here under false premises or grow did the job for us" 1 to: newLast do: [:index | array at: index put: (array at: index + delta). array at: index + delta put: nil]. firstIndex _ 1. lastIndex _ newLast! ! !MOrderedCollection methodsFor: 'private'! removeIndex: removedIndex | index | index _ removedIndex. [index < lastIndex] whileTrue: [array at: index put: (array at: index + 1). index _ index + 1]. array at: lastIndex put: nil. lastIndex _ lastIndex - 1! ! !MOrderedCollection methodsFor: 'private' stamp: 'jm 12/31/2003 13:27'! setCollection: anArray array _ anArray. firstIndex _ array size // 3 max: 1. lastIndex _ firstIndex - 1. ! ! !MOrderedCollection class methodsFor: 'instance creation' stamp: 'jm 12/31/2003 13:51'! new ^ self new: 8 ! ! !MOrderedCollection class methodsFor: 'instance creation' stamp: 'jm 11/26/2003 20:06'! new: anInteger "If a subclass adds fields, then that subclass must reimplement new:." ^ self basicNew setCollection: (MArray new: anInteger) ! ! I represent an x-y pair of numbers useful for designating a location on the screen. ! !MPoint methodsFor: 'accessing' stamp: 'jm 11/13/2002 18:01'! x ^ x ! ! !MPoint methodsFor: 'accessing' stamp: 'jm 11/13/2002 18:00'! y ^ y ! ! !MPoint methodsFor: 'polar coordinates' stamp: 'jm 11/13/2002 18:05'! degrees "Answer the angle the receiver makes with origin in degrees. Right is 0; down is 90." | tan theta | x = 0 ifTrue: [ y >= 0 ifTrue: [^ 90.0] ifFalse: [^ 270.0]] ifFalse: [ tan _ y asFloat / x asFloat. theta _ tan arcTan. x >= 0 ifTrue: [ y >= 0 ifTrue: [^ theta radiansToDegrees] ifFalse: [^ 360.0 + theta radiansToDegrees]] ifFalse: [ ^ 180.0 + theta radiansToDegrees]]. ! ! !MPoint methodsFor: 'polar coordinates' stamp: 'jm 11/13/2002 18:03'! r "Answer the receiver's radius in polar coordinate system." ^ ((x * x) + (y * y)) sqrt ! ! !MPoint methodsFor: 'polar coordinates' stamp: 'jm 11/13/2002 18:05'! theta "Answer the angle the receiver makes with origin in radians. See degrees." | tan theta | x = 0 ifTrue: [ y >= 0 ifTrue: [^ 1.5708 "90.0 degreesToRadians"] ifFalse: [^ 4.71239 "270.0 degreesToRadians"]] ifFalse: [ tan _ y asFloat / x asFloat. theta _ tan arcTan. x >= 0 ifTrue: [ y >= 0 ifTrue: [^ theta] ifFalse: [^ 360.0 degreesToRadians + theta]] ifFalse: [^ 180.0 degreesToRadians + theta]]. ! ! !MPoint methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! * arg "Answer a Point that is the product of the receiver and arg." arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)]. ^ arg adaptToPoint: self andSend: #*! ! !MPoint methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! + arg "Answer a Point that is the sum of the receiver and arg." arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)]. ^ arg adaptToPoint: self andSend: #+! ! !MPoint methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! - arg "Answer a Point that is the difference of the receiver and arg." arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)]. ^ arg adaptToPoint: self andSend: #-! ! !MPoint methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! / arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)]. ^ arg adaptToPoint: self andSend: #/! ! !MPoint methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! // arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)]. ^ arg adaptToPoint: self andSend: #//! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:46'! abs "Answer a Point whose x and y are the absolute values of the receiver's x and y." ^ x abs @ y abs ! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:44'! max: aPoint "Answer a new Point whose x and y are the maximum of the receiver and the argument point x and y." ^ (x max: aPoint x) @ (y max: aPoint y) ! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:45'! min: aPoint "Answer a new Point whose x and y are the minimum of the receiver's and the argument point's x and y." ^ (x min: aPoint x) @ (y min: aPoint y) ! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 11/13/2002 17:50'! negated "Answer a point whose x and y coordinates are the negatives of those of the receiver." ^ x negated @ y negated ! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 6/3/1998 12:21'! rounded "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x rounded @ y rounded ! ! !MPoint methodsFor: 'arithmetic' stamp: 'jm 5/29/1998 15:53'! truncated "Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x truncated @ y truncated ! ! !MPoint methodsFor: 'comparing'! = aPoint self species = aPoint species ifTrue: [^x = aPoint "Refer to the comment in Object|=." x and: [y = aPoint y]] ifFalse: [^false]! ! !MPoint methodsFor: 'comparing' stamp: 'jm 11/13/2002 17:43'! hash "Hash is reimplemented because = is implemented." ^ (x hash bitShift: 2) bitXor: y hash ! ! !MPoint methodsFor: 'converting' stamp: 'jm 12/2/2003 21:50'! adaptToFloat: rcvr andSend: selector "If I am involved in arithmetic with a Float, convert it to a Point." ^ rcvr@rcvr perform: selector with: self ! ! !MPoint methodsFor: 'converting' stamp: 'jm 12/2/2003 21:47'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Point." ^ rcvr@rcvr perform: selector with: self ! ! !MPoint methodsFor: 'converting' stamp: 'jm 11/13/2002 17:54'! asPoint "Answer the receiver itself." ^ self ! ! !MPoint methodsFor: 'point functions' stamp: 'jm 11/13/2002 17:56'! crossProduct: aPoint "Answer a number that is the cross product of the receiver and the argument, aPoint." ^ (x * aPoint y) - (y * aPoint x) ! ! !MPoint methodsFor: 'point functions' stamp: 'jm 11/13/2002 17:56'! dist: aPoint "Answer the distance between aPoint and the receiver." ^ (aPoint - self) r ! ! !MPoint methodsFor: 'point functions' stamp: 'jm 11/13/2002 17:56'! dotProduct: aPoint "Answer a number that is the dot product of the receiver and the argument." ^ (x * aPoint x) + (y * aPoint y) ! ! !MPoint methodsFor: 'printing'! printOn: aStream "The receiver prints on aStream in terms of infix notation." x printOn: aStream. aStream nextPut: $@. y printOn: aStream! ! !MPoint methodsFor: 'private' stamp: 'jm 11/13/2002 17:59'! setR: rho degrees: theta | radians | radians _ theta asFloat degreesToRadians. x _ rho asFloat * radians cos. y _ rho asFloat * radians sin. ! ! !MPoint methodsFor: 'private' stamp: 'sw 3/21/2000 13:24'! setX: xValue setY: yValue x _ xValue. y _ yValue! ! !MPoint class methodsFor: 'instance creation' stamp: 'jm 11/13/2002 17:59'! r: rho degrees: theta "Answer an instance of me with polar coordinates rho and theta." ^ self new setR: rho degrees: theta ! ! !MPoint class methodsFor: 'instance creation' stamp: 'jm 11/13/2002 18:00'! x: xValue y: yValue "Answer an instance of me with the given coordinates." ^ self new setX: xValue setY: yValue ! ! I represent an independent path of control in the system. This path of control can be stopped (by sending the message suspend) and later restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of MProcessorScheduler determines which one will actually be advanced partly using the process priority. Note: The virtual machine depends on the order of my first four instance variables. ! !MProcess methodsFor: 'process control' stamp: 'jm 10/26/2003 19:35'! resume "Primitive. Allow this process to proceed. Put the receiver in line to become the active process. Fail if the receiver is already waiting on a queue (i.e., on a Semaphore or on a scheduler queue). Essential. See Object documentation whatIsAPrimitive." <primitive: 87> self primitiveFailed. ! ! !MProcess methodsFor: 'process control' stamp: 'jm 10/26/2003 19:43'! suspend "Primitive. Stop this process in such a way that it can be restarted later (see resume). If the receiver is the active process, suspend it. Otherwise, remove the receiver from its suspended process list. Essential. See Object documentation whatIsAPrimitive." <primitive: 88> Processor activeProcess == self ifTrue: [self primitiveFailed] ifFalse: [ Processor remove: self ifAbsent: [self error: 'This process was not active']. myList _ nil] ! ! !MProcess methodsFor: 'process control' stamp: 'jm 12/31/2003 09:41'! terminate "Stop this process forever." Processor activeProcess == self ifTrue: [ thisContext removeSelf suspend] ifFalse: [ myList ifNotNil: [ myList remove: self ifAbsent: []. myList _ nil]. suspendedContext _ nil]. ! ! !MProcess methodsFor: 'accessing' stamp: 'jm 10/26/2003 19:24'! errorHandler ^ errorHandler ! ! !MProcess methodsFor: 'accessing'! errorHandler: aBlock errorHandler _ aBlock. ! ! !MProcess methodsFor: 'accessing' stamp: 'jm 10/26/2003 20:07'! nextLink ^ nextLink ! ! !MProcess methodsFor: 'accessing' stamp: 'jm 10/26/2003 20:10'! nextLink: aLink nextLink _ aLink. ! ! !MProcess methodsFor: 'accessing'! priority "Answer the priority of the receiver." ^ priority ! ! !MProcess methodsFor: 'accessing' stamp: 'jm 12/2/2003 06:57'! priority: anInteger "Set the receiver's priority to anInteger. The priority is used by the VM as an index into the scheduler's array of process queues so it must be an integer between 1 and Processor highestPriority." priority _ (anInteger asInteger max: 1) min: Processor highestPriority. ! ! !MProcess methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' in '. suspendedContext printOn: aStream ! ! !MProcess methodsFor: 'private' stamp: 'jm 12/2/2003 07:04'! initSuspendedContext: aContext suspendedContext _ aContext. priority _ 1. "lowest priority" ! ! !MProcess class methodsFor: 'instance creation' stamp: 'jm 12/2/2003 07:05'! for: aContext priority: anInteger "Answer an instance of me for the given context (usually a Block) at the given priority." ^ self new initSuspendedContext: aContext; priority: anInteger ! ! I represent a linked list of Process objects. A process can be on at most one LinkedList at a time. Instances of me are used by the process scheduler and the virtual machine to store queues of waiting processes, one for each process priority level. Semaphore, a subclass of me, keeps a linked list of processes waiting to be signalled. Warning: The virtual machine depends on the order of my instance variables. ! !MProcessList methodsFor: 'accessing' stamp: 'jm 12/2/2003 07:35'! first "Answer the first element. Raise an error if I am empty." self emptyCheck. ^ firstLink ! ! !MProcessList methodsFor: 'accessing' stamp: 'jm 12/2/2003 07:35'! size "Answer the number of elements I contain." | tally | tally _ 0. self do: [:each | tally _ tally + 1]. ^ tally ! ! !MProcessList methodsFor: 'testing' stamp: 'jm 12/2/2003 07:34'! isEmpty ^ firstLink == nil ! ! !MProcessList methodsFor: 'adding' stamp: 'jm 12/2/2003 07:38'! add: aLink "Add aLink to the end of the receiver's list. Answer aLink." ^ self addLast: aLink ! ! !MProcessList methodsFor: 'adding' stamp: 'jm 12/2/2003 07:37'! addLast: aLink "Add aLink to the end of the receiver's list. Answer aLink." self isEmpty ifTrue: [firstLink _ aLink] ifFalse: [lastLink nextLink: aLink]. lastLink _ aLink. ^ aLink ! ! !MProcessList methodsFor: 'removing' stamp: 'jm 12/2/2003 07:41'! remove: aLink ifAbsent: aBlock "Remove aLink from the receiver. If it is not there, answer the result of evaluating aBlock." | tempLink | aLink == firstLink ifTrue: [firstLink _ aLink nextLink. aLink == lastLink ifTrue: [lastLink _ nil]] ifFalse: [tempLink _ firstLink. [tempLink == nil ifTrue: [^aBlock value]. tempLink nextLink == aLink] whileFalse: [tempLink _ tempLink nextLink]. tempLink nextLink: aLink nextLink. aLink == lastLink ifTrue: [lastLink _ tempLink]]. aLink nextLink: nil. ^ aLink ! ! !MProcessList methodsFor: 'removing' stamp: 'jm 12/2/2003 07:40'! removeFirst "Remove and answer the first element. Raise an error if I am empty." | oldLink | self emptyCheck. oldLink _ firstLink. firstLink == lastLink ifTrue: [firstLink _ nil. lastLink _ nil] ifFalse: [firstLink _ oldLink nextLink]. oldLink nextLink: nil. ^ oldLink ! ! !MProcessList methodsFor: 'enumerating' stamp: 'jm 12/2/2003 07:41'! do: aBlock "Evaluate the given block for each of my elements." | aLink | aLink _ firstLink. [aLink == nil] whileFalse: [ aBlock value: aLink. aLink _ aLink nextLink]. ! ! My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service. Warning: The virtual machine depends on the order of my instance variables. ! !MProcessorScheduler methodsFor: 'accessing'! activeProcess "Answer the currently running Process." ^ activeProcess ! ! !MProcessorScheduler methodsFor: 'accessing' stamp: 'jm 11/28/2003 18:54'! highestPriority "Answer the number of priority levels currently available for use." ^ suspendedProcessLists size ! ! !MProcessorScheduler methodsFor: 'other' stamp: 'jm 10/26/2003 19:13'! remove: aProcess ifAbsent: aBlock "Remove the given process from the list on which it is waiting. If the process is not on the queue for it's priority, evaluate the given block. Always answer the process." (suspendedProcessLists at: aProcess priority) remove: aProcess ifAbsent: aBlock. ^ aProcess ! ! !MProcessorScheduler methodsFor: 'private' stamp: 'jm 12/2/2003 07:17'! idleProcess "A default background process that simply loops forever. It runs only when no higher priority processes are available, perhaps because they are waiting on a semaphore or timer." [true] whileTrue: ["do nothing"]. ! ! !MProcessorScheduler methodsFor: 'private' stamp: 'jm 12/9/2003 00:16'! initProcessLists "Create process lists for prioriy levels 1 through 5." suspendedProcessLists _ (1 to: 5) collect: [:i | MProcessList new]. ! ! !MProcessorScheduler methodsFor: 'private' stamp: 'jm 12/9/2003 00:15'! installIdleProcess "Install an idle process of the lowest possible priority that is always runnable." "Details: The virtual machine requires that there is always some runnable process that can be scheduled; this background process ensures that this is the case." | idleList idleProc | "terminate any old idle processes" idleList _ suspendedProcessLists at: 1. [idleList isEmpty] whileFalse: [idleList first terminate]. idleProc _ MProcess for: [self idleProcess] priority: 1. (suspendedProcessLists at: idleProc priority) addLast: idleProc ! ! !MProcessorScheduler methodsFor: 'private' stamp: 'jm 12/9/2003 00:15'! installStartProcess "Install the startup process as the active process. This process will run when MicroSqueak is started." activeProcess _ MProcess for: [MSystem start] priority: 3. ! ! !MProcessorScheduler class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:23'! new "The VM depends on a unique scheduler." self cannotInstantiate. ! ! I support sequential access to a collection of objects. I keep track of the position of the next element to be processed; this position can be changed to allow random access. ! !MReadStream methodsFor: 'accessing'! contents "Answer with a copy of my collection from 1 to readLimit." ^ collection copyFrom: 1 to: readLimit ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 15:34'! next "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." <primitive: 65> position >= readLimit ifTrue: [^ nil] ifFalse: [^ collection at: (position _ position + 1)]. ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 15:36'! next: anInteger "Answer a collection containing the next anInteger elements of my collection." | end result | end _ (position + anInteger) min: readLimit. result _ collection copyFrom: position + 1 to: end. position _ end. ^ result ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 16:32'! peek "Answer the next object without advancing my position. Answer nil if there are no more elements." | result | self atEnd ifTrue: [^ nil]. result _ self next. position _ position - 1. ^ result ! ! !MReadStream methodsFor: 'accessing'! position "Answer the current position of accessing the sequence of objects." ^ position ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 16:42'! position: anInteger "Set my current position to anInteger, as long as anInteger is within bounds. If not, report an error." anInteger >= 0 & (anInteger <= readLimit) ifTrue: [position _ anInteger asInteger] ifFalse: [self error: 'Position out of bounds: ', anInteger printString] ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 15:37'! size "Compatibility with other streams (e.g., FileStream)" ^ readLimit ! ! !MReadStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 16:44'! skip: anInteger "Set the receiver's position to be the current position+anInteger." self position: ((position + anInteger) min: readLimit). ! ! !MReadStream methodsFor: 'testing' stamp: 'jm 10/26/2003 14:10'! atEnd "Primitive. Answer whether the receiver can access any more objects. Optional. See Object documentation whatIsAPrimitive." <primitive: 67> ^ position >= readLimit ! ! !MReadStream methodsFor: 'testing' stamp: 'jm 10/26/2003 16:35'! peekFor: anObject "If my next element equals the given object, skip it and answer true. Otherwise, answer false and leave my position unchanged." | result | result _ self peek = anObject. result ifTrue: [self skip: 1]. ^ result ! ! !MReadStream methodsFor: 'private' stamp: 'jm 10/26/2003 17:02'! on: aCollection "Initialize myself for streaming over the given collection." collection _ aCollection. readLimit _ aCollection size. position _ 0. ! ! !MReadStream class methodsFor: 'instance creation'! on: aCollection "Answer an instance of me, streaming over the elements of aCollection." ^ self basicNew on: aCollection ! ! I provide a way to synchronize processes using the 'signal' and 'wait' operations. A processing wishing to wait for some condition or for exclusive access to some data structure performs a wait operation. If the semaphore contains at least one signal, it decrements the signal count and proceeds. If it has no signals, the calling process is suspended until the semaphore is signaled by the virtual machine in response to some external event, such as new data arriving on a socket or a timeout expiring. Warning: The virtual machine depends on the order of my instance variables. ! !MSemaphore methodsFor: 'initialize' stamp: 'jm 12/8/2003 21:00'! initialize "Consume any excess signals the receiver may have accumulated." excessSignals _ 0. ! ! !MSemaphore methodsFor: 'comparing' stamp: 'jm 10/26/2003 18:42'! = anObject ^ self == anObject ! ! !MSemaphore methodsFor: 'comparing' stamp: 'jm 10/26/2003 18:42'! hash ^ self identityHash ! ! !MSemaphore methodsFor: 'semaphore operations' stamp: 'jm 10/26/2003 18:44'! critical: aBlock "Evaluate the given block immediated if the receiver is not currently running the critical: method. If it is, evaluate the given block when the current critical: message is finished. Answer the result of evaluating the block." | result | self wait. result _ aBlock value. self signal. ^ result ! ! !MSemaphore methodsFor: 'semaphore operations' stamp: 'jm 10/26/2003 18:49'! signal "Primitive. Increment my signal count. If one or more processes are waiting on me, allow the first one to proceed. If no process is waiting, just remember the excess signal. Essential. See Object documentation whatIsAPrimitive." <primitive: 85> self primitiveFailed. ! ! !MSemaphore methodsFor: 'semaphore operations' stamp: 'jm 10/26/2003 18:48'! wait "Primitive. This semaphore must have a signal before the caller's process can proceed. If I have no signals, the process is suspended this semaphore is signalled. Essential. See Object documentation whatIsAPrimitive." <primitive: 86> self primitiveFailed. ! ! I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices. ! !MSequenceableCollection methodsFor: 'comparing'! = otherCollection "Answer whether the species of the receiver is the same as otherCollection's species, and the receiver's size is the same as otherCollection's size, and each of the receiver's elements equal the corresponding element of otherCollection." | size | (size _ self size) = otherCollection size ifFalse: [^false]. self species == otherCollection species ifFalse: [^false]. 1 to: size do: [:index | (self at: index) = (otherCollection at: index) ifFalse: [^false]]. ^true! ! !MSequenceableCollection methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:49'! at: index ifAbsent: absentBlock "Answer the element at the given index. If I do not contain an element at that index, answer the result of evaluating the argument, absentBlock." (index between: 1 and: self size) ifTrue: [^ self at: index]. ^ absentBlock value ! ! !MSequenceableCollection methodsFor: 'accessing'! first "Answer the first element of the receiver. Create an error notification if the receiver contains no elements." self emptyCheck. ^self at: 1! ! !MSequenceableCollection methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:46'! indexOf: anObject ifAbsent: absentBlock "Answer the index of the given object within me. If I do not contain the given object, answer the result of evaluating the given block." ^ self indexOf: anObject startingAt: 1 ifAbsent: absentBlock ! ! !MSequenceableCollection methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:47'! indexOf: anObject startingAt: startIndex ifAbsent: absentBlock "Answer the index of the given object within me starting the search at the given index. If I do not contain the given object, answer the result of evaluating the given block." startIndex to: self size do: [:i | (self at: i) = anObject ifTrue: [^ i]]. ^ absentBlock value ! ! !MSequenceableCollection methodsFor: 'accessing'! last "Answer the last element of the receiver. Create an error notification if the receiver contains no elements." self emptyCheck. ^self at: self size! ! !MSequenceableCollection methodsFor: 'accessing'! replaceFrom: start to: stop with: replacement "This destructively replaces elements from start to stop in the receiver. Answer the receiver itself. Use copyReplaceFrom:to:with: for insertion/deletion which may alter the size of the result." replacement size = (stop - start + 1) ifFalse: [self error: 'Size of replacement doesnt match']. ^self replaceFrom: start to: stop with: replacement startingAt: 1! ! !MSequenceableCollection methodsFor: 'accessing'! replaceFrom: start to: stop with: replacement startingAt: repStart "This destructively replaces elements from start to stop in the receiver starting at index, repStart, in the sequenceable collection, replacementCollection. Answer the receiver. No range checks are performed." | index repOff | repOff _ repStart - start. index _ start - 1. [(index _ index + 1) <= stop] whileTrue: [self at: index put: (replacement at: repOff + index)]! ! !MSequenceableCollection methodsFor: 'accessing'! size self subclassResponsibility! ! !MSequenceableCollection methodsFor: 'removing' stamp: 'jm 10/27/2003 06:08'! remove: oldObject ifAbsent: anExceptionBlock "SequencableCollections cannot implement removing." self shouldNotImplement. ! ! !MSequenceableCollection methodsFor: 'copying' stamp: 'di 1/16/98 16:40'! , otherCollection "Concatenate two Strings or Collections." ^ self copyReplaceFrom: self size + 1 to: self size with: otherCollection " #(2 4 6 8) , #(who do we appreciate) ((2989 printStringBase: 16) copyFrom: 4 to: 6) , ' boy!!' "! ! !MSequenceableCollection methodsFor: 'copying'! copyFrom: start to: stop "Answer a copy of a subset of the receiver, starting from element at index start until element at index stop." | newSize | newSize _ stop - start + 1. ^(self species new: newSize) replaceFrom: 1 to: newSize with: self startingAt: start! ! !MSequenceableCollection methodsFor: 'copying'! copyReplaceFrom: start to: stop with: replacementCollection "Answer a copy of the receiver satisfying the following conditions: If stop is less than start, then this is an insertion; stop should be exactly start-1, start = 1 means insert before the first character, start = size+1 means append after last character. Otherwise, this is a replacement; start and stop have to be within the receiver's bounds." | newSequenceableCollection newSize endReplacement | newSize _ self size - (stop - start + 1) + replacementCollection size. endReplacement _ start - 1 + replacementCollection size. newSequenceableCollection _ self species new: newSize. newSequenceableCollection replaceFrom: 1 to: start - 1 with: self startingAt: 1. newSequenceableCollection replaceFrom: start to: endReplacement with: replacementCollection startingAt: 1. newSequenceableCollection replaceFrom: endReplacement + 1 to: newSize with: self startingAt: stop + 1. ^newSequenceableCollection! ! !MSequenceableCollection methodsFor: 'copying'! copyWith: newElement "Answer a copy of the receiver that is 1 bigger than the receiver and has newElement at the last element." | newIC | newIC _ self species new: self size + 1. newIC replaceFrom: 1 to: self size with: self startingAt: 1. newIC at: newIC size put: newElement. ^newIC! ! !MSequenceableCollection methodsFor: 'enumerating'! collect: aBlock "Refer to the comment in Collection|collect:." | result | result _ self species new: self size. 1 to: self size do: [:index | result at: index put: (aBlock value: (self at: index))]. ^ result! ! !MSequenceableCollection methodsFor: 'enumerating'! do: aBlock "Refer to the comment in Collection|do:." 1 to: self size do: [:index | aBlock value: (self at: index)]! ! !MSequenceableCollection methodsFor: 'enumerating' stamp: 'jm 10/27/2003 06:42'! select: aBlock "Refer to the comment in Collection|select:." | s | s _ MWriteStream on: (self species new: self size). 1 to: self size do: [:i | (aBlock value: (self at: i)) ifTrue: [s nextPut: (self at: i)]]. ^ s contents ! ! !MSequenceableCollection methodsFor: 'converting' stamp: 'jm 11/13/2002 16:40'! asArray "Answer an Array whose elements are the elements of the receiver, in the same order." | newArray | newArray _ MArray new: self size. 1 to: self size do: [:index | newArray at: index put: (self at: index)]. ^ newArray ! ! !MSequenceableCollection methodsFor: 'private' stamp: 'jm 10/28/2003 10:31'! swap: oneIndex with: anotherIndex "Move the element at oneIndex to anotherIndex, and vice-versa." | element | element _ self at: oneIndex. self at: oneIndex put: (self at: anotherIndex). self at: anotherIndex put: element. ! ! I represent a collection of elements in which each element is stored only once. Elements must respond to hash and =. ! !MSet methodsFor: 'testing' stamp: 'jm 11/13/2002 17:20'! = aSet (aSet isKindOf: MSet) ifFalse: [^ false]. self size = aSet size ifFalse: [^ false]. self do: [:each | (aSet includes: each) ifFalse: [^ false]]. ^ true ! ! !MSet methodsFor: 'testing'! includes: anObject ^ (array at: (self findElementOrNil: anObject)) ~~ nil! ! !MSet methodsFor: 'adding' stamp: 'go 10/1/97 09:33'! add: newObject "Add an element. User error instead of halt. go 10/1/97 09:33" | index | newObject == nil ifTrue: [self error: 'Sets cannot meaningfully contain nil as an element']. index _ self findElementOrNil: newObject. (array at: index) == nil ifTrue: [self atNewIndex: index put: newObject]. ^ newObject! ! !MSet methodsFor: 'removing'! remove: oldObject ifAbsent: aBlock | index | index _ self findElementOrNil: oldObject. (array at: index) == nil ifTrue: [ ^ aBlock value ]. array at: index put: nil. tally _ tally - 1. self fixCollisionsFrom: index. ^ oldObject! ! !MSet methodsFor: 'enumerating' stamp: 'jm 11/13/2002 17:21'! collect: aBlock "Return a Set containing the result of evaluating aBlock for each element of this set." | newSet | tally = 0 ifTrue: [^ MSet new: 2]. newSet _ MSet new: self size. array do: [:each | each == nil ifFalse: [newSet add: (aBlock value: each)]]. ^ newSet ! ! !MSet methodsFor: 'enumerating'! do: aBlock tally = 0 ifTrue: [^ self]. array do: [:element | element == nil ifFalse: [aBlock value: element]]! ! !MSet methodsFor: 'private'! atNewIndex: index put: anObject array at: index put: anObject. tally _ tally + 1. self fullCheck! ! !MSet methodsFor: 'private' stamp: 'jm 12/2/2003 22:22'! copy ^ self basicCopy withArray: array basicCopy ! ! !MSet methodsFor: 'private'! findElementOrNil: anObject "Answer the index of a first slot containing either a nil (indicating an empty slot) or an element that matches the given object. Answer the index of that slot or zero. Fail if neither a match nor an empty slot is found." | index | index _ self scanFor: anObject. index > 0 ifTrue: [ ^ index ]. "Bad scene. Neither have we found a matching element nor even an empty slot. No hashed set is ever supposed to get completely full." self error: 'There is no free space in this set!!'.! ! !MSet methodsFor: 'private'! fixCollisionsFrom: index "The element at index has been removed and replaced by nil. This method moves forward from there, relocating any entries that had been placed below due to collisions with this one" | length oldIndex newIndex element | oldIndex _ index. length _ array size. [oldIndex = length ifTrue: [oldIndex _ 1] ifFalse: [oldIndex _ oldIndex + 1]. (element _ self keyAt: oldIndex) == nil] whileFalse: [newIndex _ self findElementOrNil: element. oldIndex = newIndex ifFalse: [self swap: oldIndex with: newIndex]]! ! !MSet methodsFor: 'private' stamp: 'di 11/4/97 20:11'! fullCheck "Keep array at least 1/4 free for decent hash behavior" array size - tally < (array size // 4 max: 1) ifTrue: [self grow]! ! !MSet methodsFor: 'private' stamp: 'jm 12/31/2003 13:46'! grow "Grow the elements array and reinsert the old elements." | oldElements | oldElements _ array. array _ MArray new: array size + (array size max: 2). tally _ 0. oldElements do: [:each | each == nil ifFalse: [self noCheckAdd: each]]. ! ! !MSet methodsFor: 'private' stamp: 'jm 11/13/2002 16:41'! init: n "Initialize array to an array size of n." array _ MArray new: n. tally _ 0. ! ! !MSet methodsFor: 'private'! keyAt: index "May be overridden by subclasses so that fixCollisions will work" ^ array at: index! ! !MSet methodsFor: 'private'! noCheckAdd: anObject array at: (self findElementOrNil: anObject) put: anObject. tally _ tally + 1! ! !MSet methodsFor: 'private'! scanFor: anObject "Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches anObject. Answer the index of that slot or zero if no slot is found. This method will be overridden in various subclasses that have different interpretations for matching elements." | element start finish | start _ (anObject hash \\ array size) + 1. finish _ array size. "Search from (hash mod size) to the end." start to: finish do: [:index | ((element _ array at: index) == nil or: [element = anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [element = anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !MSet methodsFor: 'private'! size ^ tally! ! !MSet methodsFor: 'private'! swap: oneIndex with: otherIndex "May be overridden by subclasses so that fixCollisions will work" array swap: oneIndex with: otherIndex ! ! !MSet methodsFor: 'private'! withArray: anArray "private -- for use only in copy" array _ anArray! ! !MSet methodsFor: 'accessing' stamp: 'jm 11/24/2003 09:19'! asArray "Return an array whose elements are those of the receiver. " | s | s _ MWriteStream on: (MArray new: self size). self do: [:el | s nextPut: el]. ^ s contents ! ! !MSet methodsFor: 'converting' stamp: 'jm 12/8/2003 22:45'! asSet ^ self ! ! !MSet class methodsFor: 'instance creation' stamp: 'jm 10/26/2003 20:05'! new ^ self new: 4 ! ! !MSet class methodsFor: 'instance creation' stamp: 'jm 11/26/2003 20:08'! new: nElements "Create a Set large enough to hold nElements without growing." | initialSize | "make large enough size to hold nElements with some slop (see fullCheck)" nElements <= 0 ifTrue: [initialSize _ 1] ifFalse: [initialSize _ ((nElements + 1) * 4) // 3]. ^ self basicNew init: initialSize ! ! My instances are 31-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal). ! !MSmallInteger methodsFor: 'arithmetic'! * aNumber "Primitive. Multiply the receiver by the argument and answer with the result if it is a SmallInteger. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 9> self = 0 ifTrue: [^0]. "This eliminates the need for a self=0 check in LargeInteger *" ^super * aNumber! ! !MSmallInteger methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:12'! + aNumber "Primitive. Add the receiver to the argument and answer with the result if it is a SmallInteger. Fail if the argument or the result is not a SmallInteger Essential No Lookup. See Object documentation whatIsAPrimitive." <primitive: 1> aNumber isInteger ifTrue: [^ super + aNumber]. ^ aNumber adaptToInteger: self andSend: #+! ! !MSmallInteger methodsFor: 'arithmetic'! - aNumber "Primitive. Subtract the argument from the receiver and answer with the result if it is a SmallInteger. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 2> ^super - aNumber! ! !MSmallInteger methodsFor: 'arithmetic' stamp: 'jm 10/27/2003 07:40'! / aNumber "Primitive. Divide the receiver by the argument and return the result if the division is exact. Fail if the result is not a whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 10> aNumber = 0 ifTrue: [^ self error: 'division by 0']. aNumber isSmallInteger ifTrue: [^ self asFloat / aNumber asFloat] ifFalse: [^ super / aNumber]. ! ! !MSmallInteger methodsFor: 'arithmetic'! // aNumber "Primitive. Divide the receiver by the argument and answer with the result. Round the result down towards negative infinity to make it a whole integer. Fail if the argument is 0 or is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive. " <primitive: 12> ^super // aNumber"Do with quo: if primitive fails"! ! !MSmallInteger methodsFor: 'arithmetic'! \\ aNumber "Primitive. Take the receiver modulo the argument. The result is the remainder rounded towards negative infinity, of the receiver divided by the argument Fail if the argument is 0 or is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 11> ^super \\ aNumber"Do with // if primitive fails"! ! !MSmallInteger methodsFor: 'arithmetic' stamp: 'jm 10/27/2003 07:40'! quo: aNumber "Primitive. Divide the receiver by the argument and answer with the result. Round the result down towards zero to make it a whole integer. Fail if the argument is 0 or is not a MSmallInteger. Optional. See Object documentation whatIsAPrimitive." <primitive: 13> aNumber = 0 ifTrue: [^ self error: 'Attempt to divide by zero']. aNumber class isSmallInteger ifTrue: [self primitiveFailed] ifFalse: [^ super quo: aNumber]. ! ! !MSmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'! bitAnd: arg "Primitive. Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument, arg. Numbers are interpreted as having 2's-complement representation. Essential. See Object documentation whatIsAPrimitive." <primitive: 14> self >= 0 ifTrue: [^ arg bitAnd: self]. ^ (self bitInvert bitOr: arg bitInvert) bitInvert! ! !MSmallInteger methodsFor: 'bit manipulation' stamp: 'di 4/30/1998 10:33'! bitOr: arg "Primitive. Answer an Integer whose bits are the logical OR of the receiver's bits and those of the argument, arg. Numbers are interpreted as having 2's-complement representation. Essential. See Object documentation whatIsAPrimitive." <primitive: 15> self >= 0 ifTrue: [^ arg bitOr: self]. ^ arg < 0 ifTrue: [(self bitInvert bitAnd: arg bitInvert) bitInvert] ifFalse: [(self bitInvert bitClear: arg) bitInvert]! ! !MSmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'! bitShift: arg "Primitive. Answer an Integer whose value is the receiver's value shifted left by the number of bits indicated by the argument. Negative arguments shift right. The receiver is interpreted as having 2's-complement representation. Essential. See Object documentation whatIsAPrimitive." <primitive: 17> self >= 0 ifTrue: [^ super bitShift: arg]. ^ arg >= 0 ifTrue: [(self negated bitShift: arg) negated] ifFalse: [(self bitInvert bitShift: arg) bitInvert]! ! !MSmallInteger methodsFor: 'bit manipulation' stamp: 'wb 4/28/1998 12:17'! bitXor: arg "Primitive. Answer an Integer whose bits are the logical XOR of the receiver's bits and those of the argument, arg. Numbers are interpreted as having 2's-complement representation. Essential. See Object documentation whatIsAPrimitive." <primitive: 16> self >= 0 ifTrue: [^ arg bitXor: self]. ^ arg < 0 ifTrue: [self bitInvert bitXor: arg bitInvert] ifFalse: [(self bitInvert bitXor: arg) bitInvert]! ! !MSmallInteger methodsFor: 'bit manipulation' stamp: 'jm 5/1/1998 14:54'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic." | shifted bitNo | self < 0 ifTrue: [self error: 'highBit is not defined for negative integers']. shifted _ self. bitNo _ 0. [shifted < 16] whileFalse: [shifted _ shifted bitShift: -4. bitNo _ bitNo + 4]. [shifted = 0] whileFalse: [shifted _ shifted bitShift: -1. bitNo _ bitNo + 1]. ^ bitNo ! ! !MSmallInteger methodsFor: 'testing' stamp: 'jm 10/27/2003 07:36'! isSmallInteger ^ true ! ! !MSmallInteger methodsFor: 'comparing'! < aNumber "Primitive. Compare the receiver with the argument and answer with true if the receiver is less than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 3> ^super < aNumber! ! !MSmallInteger methodsFor: 'comparing'! <= aNumber "Primitive. Compare the receiver with the argument and answer true if the receiver is less than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive. " <primitive: 5> ^super <= aNumber! ! !MSmallInteger methodsFor: 'comparing'! = aNumber "Primitive. Compare the receiver with the argument and answer true if the receiver is equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive. " <primitive: 7> ^super = aNumber! ! !MSmallInteger methodsFor: 'comparing'! > aNumber "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 4> ^super > aNumber! ! !MSmallInteger methodsFor: 'comparing'! >= aNumber "Primitive. Compare the receiver with the argument and answer true if the receiver is greater than or equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 6> ^super >= aNumber! ! !MSmallInteger methodsFor: 'comparing' stamp: 'jm 12/31/2003 09:14'! hash ^ self ! ! !MSmallInteger methodsFor: 'comparing' stamp: 'jm 11/14/2002 14:20'! identityHash ^ self ! ! !MSmallInteger methodsFor: 'comparing'! ~= aNumber "Primitive. Compare the receiver with the argument and answer true if the receiver is not equal to the argument. Otherwise answer false. Fail if the argument is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 8> ^super ~= aNumber! ! !MSmallInteger methodsFor: 'copying' stamp: 'jm 12/2/2003 22:25'! basicCopy "I am immutable (and not really an object), so answer myself." ! ! !MSmallInteger methodsFor: 'converting'! asFloat "Primitive. Answer a Float that represents the value of the receiver. Essential. See Object documentation whatIsAPrimitive." <primitive: 40> self primitiveFailed! ! !MSmallInteger methodsFor: 'printing' stamp: 'jm 10/26/2003 13:31'! printOn: aStream base: b "Refer to the comment in Integer|printOn:base:." "self maxVal printStringBase: 2" | digitsInReverse x i | self < 0 ifTrue: [ aStream nextPut: $-. ^ self negated printOn: aStream base: b]. b = 10 ifFalse: [b printOn: aStream. aStream nextPut: $r]. digitsInReverse _ MArray new: 32. x _ self. i _ 0. [x >= b] whileTrue: [ digitsInReverse at: (i _ i + 1) put: x \\ b. x _ x // b]. digitsInReverse at: (i _ i + 1) put: x. [i > 0] whileTrue: [ aStream nextPut: (MCharacter digitValue: (digitsInReverse at: i)). i _ i - 1]. ! ! !MSmallInteger methodsFor: 'system primitives' stamp: 'jm 11/13/2002 17:22'! digitAt: n "Answer the value of an indexable field in the receiver. Fail if the argument (the index) is not an Integer or is out of bounds." n>4 ifTrue: [^ 0]. self < 0 ifTrue: [self = MSmallInteger minVal ifTrue: ["Can't negate minVal -- treat specially" ^ #(0 0 0 64) at: n]. ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! !MSmallInteger methodsFor: 'system primitives' stamp: 'jm 12/31/2003 09:17'! digitAt: n put: value "Fails. The digits of a small integer can not be modified." self error: 'You cannot store in a SmallInteger' ! ! !MSmallInteger methodsFor: 'system primitives'! digitLength "Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Included so that a SmallInteger can behave like a LargePositiveInteger or LargeNegativeInteger." (self < 16r100 and: [self > -16r100]) ifTrue: [^ 1]. (self < 16r10000 and: [self > -16r10000]) ifTrue: [^ 2]. (self < 16r1000000 and: [self > -16r1000000]) ifTrue: [^ 3]. ^ 4! ! !MSmallInteger class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:24'! new "SmallIntegers are created as constants or by performing arithmetic." self cannotInstantiate. ! ! !MSmallInteger class methodsFor: 'constants'! maxVal "Answer the maximum value for a SmallInteger." ^ 16r3FFFFFFF! ! !MSmallInteger class methodsFor: 'constants'! minVal "Answer the minimum value for a SmallInteger." ^ -16r40000000! ! I represent an ArrayedCollection of Character objects efficiently packed into 8-bit bytes. String support a vast array of useful methods, which can best be learned by browsing and trying out examples as you find them in the code. Here are a few useful methods to look at... String match: String contractTo: String also inherits many useful methods from its hierarchy, such as SequenceableCollection , SequenceableCollection copyReplaceAll:with: ! !MString methodsFor: 'accessing' stamp: 'jm 10/28/2003 11:31'! at: index "Primitive. Answer the Character stored in the field of the receiver indexed by the argument. Fail if the index argument is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." <primitive: 63> ^ (super at: index) asCharacter ! ! !MString methodsFor: 'accessing' stamp: 'jm 11/13/2002 16:28'! at: index put: aCharacter "Primitive. Store the Character in the field of the receiver indicated by the index. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." <primitive: 64> (aCharacter isKindOf: MCharacter) ifTrue: [ index isInteger ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNonIntegerIndex]] ifFalse: [self error: 'Strings only store Characters']! ! !MString methodsFor: 'accessing' stamp: 'jm 12/8/2003 23:33'! findString: key startingAt: start caseSensitive: caseSensitive "Answer the index in this String at which the substring key first occurs at or after the given starting index. The match can be case-sensitive or not. Answer zero if no match is found." ^ self findSubstring: key in: self startingAt: start matchTable: (caseSensitive ifTrue: [CaseSensitiveOrder] ifFalse: [CaseInsensitiveOrder]) ! ! !MString methodsFor: 'accessing' stamp: 'jm 12/8/2003 23:36'! findTokens: delimiters "Answer the collection of tokens that result from parsing self. Any character in the String delimiters marks a border. Several delimiters in a row are considered as just one separation." | tokens keyStart keyStop | tokens _ MOrderedCollection new. keyStop _ 1. [keyStop <= self size] whileTrue: [ keyStart _ self skipDelimiters: delimiters startingAt: keyStop. keyStop _ self findDelimiters: delimiters startingAt: keyStart. keyStart < keyStop ifTrue: [tokens add: (self copyFrom: keyStart to: (keyStop - 1))]]. ^ tokens ! ! !MString methodsFor: 'accessing' stamp: 'jm 10/26/2003 17:21'! indexOf: aCharacter startingAt: start ^ self indexOfAscii: aCharacter asciiValue inString: self startingAt: start ! ! !MString methodsFor: 'accessing' stamp: 'jm 12/31/2003 12:48'! indexOf: aCharacter startingAt: startIndex ifAbsent: absentBlock "Answer the index of the given Character within me starting the search at the given index. If I do not contain the Character, answer the result of evaluating the given block." | ans | ans _ self indexOfAscii: aCharacter asciiValue inString: self startingAt: startIndex. ans = 0 ifTrue: [^ absentBlock value] ifFalse: [^ ans] ! ! !MString methodsFor: 'accessing' stamp: 'jm 12/8/2003 23:24'! numArgs "Answer the number of arguments that the receiver would take considered as a selector or -1 if it couldn't be a selector." | firstChar numColons | firstChar _ self at: 1. firstChar isLetter ifTrue: [ numColons _ 0. self do: [:ch | ch tokenish ifFalse: [^ -1]. ch = $: ifTrue: [numColons _ numColons + 1]]. ((numColons > 0) & (self last ~= $:)) ifTrue: [^ -1]. ^ numColons]. firstChar isSpecial ifTrue: [ self size = 1 ifTrue: [^ 1]. ((self size = 2) and: [(self at: 2) isSpecial]) ifTrue: [^ 1]. ^ -1]. ^ -1 ! ! !MString methodsFor: 'accessing'! size "Primitive. Answer the number of indexable fields in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." <primitive: 62> ^self basicSize! ! !MString methodsFor: 'comparing' stamp: 'di 2/27/98 12:16'! < aString "Answer whether the receiver sorts before aString. The collation order is simple ascii (with case differences)." ^ (self compare: self with: aString collated: AsciiOrder) = 1! ! !MString methodsFor: 'comparing' stamp: 'di 2/27/98 12:17'! <= aString "Answer whether the receiver sorts before or equal to aString. The collation order is simple ascii (with case differences)." ^ (self compare: self with: aString collated: AsciiOrder) <= 2! ! !MString methodsFor: 'comparing' stamp: 'jm 11/13/2002 18:48'! = aString "Answer whether the receiver sorts equally as aString. The collation order is simple ascii (with case differences)." aString species == MString ifFalse: [^ false]. ^ (self compare: self with: aString collated: AsciiOrder) = 2! ! !MString methodsFor: 'comparing' stamp: 'di 2/27/98 12:17'! > aString "Answer whether the receiver sorts after aString. The collation order is simple ascii (with case differences)." ^ (self compare: self with: aString collated: AsciiOrder) = 3! ! !MString methodsFor: 'comparing' stamp: 'di 2/27/98 12:18'! >= aString "Answer whether the receiver sorts after or equal to aString. The collation order is simple ascii (with case differences)." ^ (self compare: self with: aString collated: AsciiOrder) >= 2! ! !MString methodsFor: 'comparing' stamp: 'di 2/27/98 12:41'! compare: aString "Answer a comparison code telling how the receiver sorts relative to aString: 1 - before 2 - equal 3 - after. The collation sequence is ascii with case differences ignored. To get the effect of a <= b, but ignoring case, use (a compare: b) <= 2." ^ self compare: self with: aString collated: CaseInsensitiveOrder! ! !MString methodsFor: 'comparing'! hash | l m | (l _ m _ self size) <= 2 ifTrue: [l = 2 ifTrue: [m _ 3] ifFalse: [l = 1 ifTrue: [^((self at: 1) asciiValue bitAnd: 127) * 106]. ^21845]]. ^(self at: 1) asciiValue * 48 + ((self at: (m - 1)) asciiValue + l)! ! !MString methodsFor: 'converting' stamp: 'jm 11/24/2003 07:50'! asByteArray "Answer a ByteArray containing the ASCII values of my characters. Uses a fast primitive that avoids character conversion." ^ (MByteArray new: self size) replaceFrom: 1 to: self size with: self ! ! !MString methodsFor: 'converting' stamp: 'jm 12/8/2003 23:27'! asLowercase "Answer a String made up from the receiver whose characters are all lowercase." | result | result _ self copy asString. self translate: result from: 1 to: result size table: LowercasingTable. ^ result ! ! !MString methodsFor: 'converting' stamp: 'jm 5/14/1998 10:40'! asString "Answer this string." ^ self ! ! !MString methodsFor: 'converting' stamp: 'jm 11/30/2003 17:20'! asSymbol "This is the only place that new Symbols are created. A Symbol is created if and only if there is not already a Symbol with its contents in existance." MSymbol allInstancesDo: [:sym | self = sym ifTrue: [^ sym]]. ^ (MSymbol basicNew: self size) initFrom: self ! ! !MString methodsFor: 'printing' stamp: 'jm 10/29/2003 11:21'! printOn: aStream "Print inside string quotes, doubling inbedded quotes." | x | aStream nextPut: $'. 1 to: self size do: [:i | aStream nextPut: (x _ self at: i). x == $' ifTrue: [aStream nextPut: x]]. aStream nextPut: $'. ! ! !MString methodsFor: 'private' stamp: 'jm 11/30/2003 16:35'! compare: string1 with: string2 collated: order "Return 1, 2 or 3, if string1 is <, =, or > string2, with the collating order of characters given by the order array." | len1 len2 c1 c2 | <primitive: 235> len1 _ string1 size. len2 _ string2 size. 1 to: (len1 min: len2) do: [:i | c1 _ order at: (string1 basicAt: i) + 1. c2 _ order at: (string2 basicAt: i) + 1. c1 = c2 ifFalse: [c1 < c2 ifTrue: [^ 1] ifFalse: [^ 3]]]. len1 = len2 ifTrue: [^ 2]. len1 < len2 ifTrue: [^ 1] ifFalse: [^ 3]. ! ! !MString methodsFor: 'private'! findDelimiters: delimiters startingAt: start "Answer the index of the character within the receiver, starting at start, that matches one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1." start to: self size do: [:i | delimiters do: [:delim | delim = (self at: i) ifTrue: [^ i]]]. ^ self size + 1! ! !MString methodsFor: 'private' stamp: 'jm 11/30/2003 16:38'! findSubstring: key in: body startingAt: start matchTable: matchTable "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned." "Note: The algorithm below is not optimum because it is intended to be translated to C." | index | <primitive: 246> key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index _ 1. [(matchTable at: (body at: startIndex+index-1) asciiValue + 1) = (matchTable at: (key at: index) asciiValue + 1) ] whileTrue: [ index = key size ifTrue: [^ startIndex]. index _ index+1]]. ^ 0 " ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7 "! ! !MString methodsFor: 'private' stamp: 'jm 11/30/2003 16:39'! indexOfAscii: anInteger inString: aString startingAt: start | stringSize | <primitive: 245> stringSize _ aString size. start to: stringSize do: [:pos | (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. ^ 0 ! ! !MString 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." <primitive: 105> super replaceFrom: start to: stop with: replacement startingAt: repStart! ! !MString methodsFor: 'private' stamp: 'jm 12/8/2003 23:29'! skipDelimiters: delimiters startingAt: start "Answer the index of the first character in this string starting at the given index that does NOT match one of the delimiters. If the receiver does not contain any of the delimiters, answer size + 1. Assumes the delimiters to be a non-empty string." start to: self size do: [:i | (delimiters indexOf: (self at: i) startingAt: 1) = 0 ifTrue: [^ i]]. ^ self size + 1 ! ! !MString methodsFor: 'private' stamp: 'jm 11/30/2003 16:39'! translate: aString from: start to: stop table: table "Translate the characters in the given string in place using the given mapping table." <primitive: 243> start to: stop do: [:i | aString at: i put: (table at: (aString at: i) asciiValue + 1)]. ! ! !MString class methodsFor: 'class initialization' stamp: 'jm 11/24/2003 07:57'! initialize "self initialize" | order | AsciiOrder _ (0 to: 255) asByteArray. CaseInsensitiveOrder _ AsciiOrder copy. ($a to: $z) do: [:c | CaseInsensitiveOrder at: c asciiValue + 1 put: (CaseInsensitiveOrder at: c asUppercase asciiValue + 1)]. "case-sensitive compare sorts space, digits, letters, all the rest..." CaseSensitiveOrder _ (AsciiOrder collect: [:x | 255]) asByteArray. order _ -1. ' 0123456789' do: [:c | "digits, 0-10" CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order + 1)]. ($a to: $z) do: [:c | "letters, 11-64" CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order + 1). CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order + 1)]. 1 to: CaseSensitiveOrder size do: [:i | "all other characters" (CaseSensitiveOrder at: i) = 255 ifTrue: [ CaseSensitiveOrder at: i put: (order _ order + 1)]]. order = 255 ifFalse: [self error: 'order problem']. "create a table for translating to lower case" LowercasingTable _ ((0 to: 255) collect: [:i | i asCharacter asLowercase]) asString. ! ! !MString class methodsFor: 'constants' stamp: 'jm 10/28/2003 11:45'! cr "Answer a string containing a carriage return character." ^ self with: MCharacter cr ! ! I represent a String that has a single unique instance in the system. These unique string objects are used by the system as message selectors. Notes: o In Microsqueak, symbols can *only* be created by the compiler, not at runtime. o To save space, we may eventually replace all symbols with unique integers. In that case, any code that converts symbols into strings (e.g., using asString) would fail. ! !MSymbol methodsFor: 'accessing' stamp: 'jm 10/27/2003 07:20'! at: anInteger put: anObject "You cannot modify the receiver." self errorNoModification. ! ! !MSymbol methodsFor: 'accessing' stamp: 'jm 10/27/2003 07:20'! replaceFrom: start to: stop with: replacement startingAt: repStart self errorNoModification. ! ! !MSymbol methodsFor: 'comparing' stamp: 'jm 10/27/2003 07:20'! = anObject ^ self == anObject ! ! !MSymbol methodsFor: 'comparing' stamp: 'jm 10/27/2003 07:21'! hash ^ self identityHash ! ! !MSymbol methodsFor: 'copying' stamp: 'jm 12/2/2003 22:24'! basicCopy "Answer myself because Symbols are unique." ! ! !MSymbol methodsFor: 'converting' stamp: 'jm 10/27/2003 07:24'! asString "Answer a string containing my characters." | sz result | sz _ self size. result _ MString new: sz. result replaceFrom: 1 to: sz with: self startingAt: 1. ^ result ! ! !MSymbol methodsFor: 'converting' stamp: 'jm 11/30/2003 17:12'! asSymbol ^ self ! ! !MSymbol methodsFor: 'printing' stamp: 'jm 10/27/2003 07:27'! printOn: aStream aStream nextPutAll: self. ! ! !MSymbol methodsFor: 'private' stamp: 'jm 10/27/2003 07:18'! errorNoModification self error: 'Symbols can not be modified.' ! ! !MSymbol methodsFor: 'private' stamp: 'jm 11/30/2003 17:18'! initFrom: aString "Warning!! Use only to initialize new Symbols. Symbols are assumed to be immutable there after." self size = aString size ifFalse: [self error: 'size mismatch']. super replaceFrom: 1 to: self size with: aString startingAt: 1. ! ! !MSymbol methodsFor: 'private' stamp: 'jm 11/13/2002 18:28'! species ^ MString ! ! !MSymbol class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:31'! new: size "Symbols are unique. You can create a new Symbol from a String using 'asSymbol'." self cannotInstantiate. ! ! I represent the system itself. I implement some useful system facilities as class methods. I am a very lightweight version of the 'SystemDictionary' in other Smalltalk systems. ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 19:39'! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" | f | self putString: 'Welcome to MicroSqueak!!'; putcr. self putString: self tinyBenchmarks; putcr. self putString: MForm new primScreenSize printString; putcr. f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! !MSystem class methodsFor: 'misc' stamp: 'jm 12/2/2003 22:52'! allObjectsDo: aBlock "Evaluate the argument, aBlock, for each object in the system excluding SmallIntegers." | object | object _ self someObject. [0 == object] whileFalse: [ aBlock value: object. object _ object nextObject]. ! ! !MSystem class methodsFor: 'misc' stamp: 'jm 11/24/2003 21:01'! getchar "Answer the ASCII value of the next character from the keyboard buffer. Answer nil if no key has been typed." | ch | (ch _ self primKeyboardNext) ifNil: [^ nil] ifNotNil: [^ ch bitAnd: 16rFF]. ! ! !MSystem class methodsFor: 'misc' stamp: 'jm 11/13/2002 18:57'! milliseconds "Answer the current value of the millisecond clock. Optional primitive." "Note: The millisecond clock may wrap around frequently, depending on the underlaying hardware. If no hardware clock is available, it may always return 0." <primitive: 135> ^ 0 ! ! !MSystem class methodsFor: 'misc' stamp: 'jm 12/9/2003 00:08'! tinyBenchmarks "Report the results of running the two tiny Squeak benchmarks." | n t1 t2 r | n _ 25. t1 _ [n benchmark] msecs. t2 _ [r _ 28 benchFib] msecs. ^ ((n * 500000 * 1000) // t1) printString, ' bytecodes/sec; ', ((r * 1000) // t2) printString, ' sends/sec' ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/2/2003 08:09'! exitToDebugger "Tell the VM that we've encountered an unhandled error or halt." <primitive: 114> ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/2/2003 08:07'! garbageCollect "Primitive. Reclaims all garbage and answers the number of bytes of available space." <primitive: 130> self primitiveFailed ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/2/2003 06:46'! getVMParameters "Answer an Array containing the current values of the VM's internal parameter and statistics registers. The same primitive can be called with one integer argument to read a specific parameter and with two parameters to set a writable parameter, although these variations may not be implemented. Optional." "VM parameters are numbered as follows: 1 end of old-space (0-based, read-only) 2 end of young-space (read-only) 3 end of memory (read-only) 4 allocationCount (read-only) 5 allocations between GCs (read-write) 6 survivor count tenuring threshold (read-write) 7 full GCs since startup (read-only) 8 total milliseconds in full GCs since startup (read-only) 9 incremental GCs since startup (read-only) 10 total milliseconds in incremental GCs since startup (read-only) 11 tenures of surving objects since startup (read-only) 12-20 specific to the translating VM (obsolete) 21 root table size (read-only) 22 root table overflows since startup (read-only)" <primitive: 254> self primitiveFailed ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/2/2003 08:07'! incrementalGarbageCollect "Primitive. Reclaims recently created garbage fairly quickly and answers the number of bytes of available space." <primitive: 131> ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 11/24/2003 21:00'! primKeyboardNext "Answer the next keycode from the keyboard buffer. A keycode is 12 bits: four modifier flags in the 4 most significant bits and the 8 bit ISO character in the least significant bits. Answer nil if no key has been typed." <primitive: 108> ^ nil ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/22/2003 15:48'! quit "Exit from Squeak." <primitive: 113> ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 12/29/2003 20:09'! specialObjectsArray "Answer the virtual machine's special objects array." <primitive: 129> self primitiveFailed ! ! I represent the logical value true. ! !MTrue methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:15'! & alternativeObject "Answer true if both the receiver AND the argument are true. Unlike and:, the argument is always evaluted." ^ alternativeObject ! ! !MTrue methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:42'! and: alternativeBlock "Answer true if both the receiver AND the result of evaluating the given block are true. Only evaluate the given block if the receiver is true." ^ alternativeBlock value ! ! !MTrue methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:23'! not "Answer the negation of the receiver." ^ false ! ! !MTrue methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:43'! or: alternativeBlock "Answer true if either the receiver OR the argument are true. Only evaluate the given block if the receiver is false." ^ true ! ! !MTrue methodsFor: 'logical operations' stamp: 'jm 11/11/2002 18:23'! | aBoolean "Answer true if either the receiver OR the argument are true. Unlike or:, the argument is always evaluted." ^ true ! ! !MTrue methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:30'! ifFalse: falseBlock "If the receiver is false, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because the expression is compiled in-line." ^ nil ! ! !MTrue methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:30'! ifTrue: trueBlock "If the receiver is true, answer the result of evaluating the given block. Otherwise, answer nil. Raise an error notification if the true is not a boolean. Execution does not actually reach here because the expression is compiled in-line." ^ trueBlock value ! ! !MTrue methodsFor: 'controlling' stamp: 'jm 11/11/2002 18:28'! ifTrue: trueBlock ifFalse: falseBlock "If the receiver is true, answer the result of evaluating trueBlock. Otherwise, answer the result of evaluating falseBlock. Raise an error notification if the receiver is not a boolean. Execution does not actually reach here because this message is compiled in-line." ^ trueBlock value ! ! !MTrue methodsFor: 'copying' stamp: 'jm 12/2/2003 22:24'! basicCopy "There is the only one instance of me, so answer myself." ! ! !MTrue methodsFor: 'printing' stamp: 'jm 11/11/2002 19:00'! printOn: aStream aStream nextPutAll: 'true'. ! ! !MTrue class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:25'! new "There is a single unique instance of each boolean." self cannotInstantiate. ! ! I describe the behavior of my sole instance, nil, an object used as the value of variables or array elements that have not been initialized or for results that are meaningless. ! !MUndefinedObject methodsFor: 'testing' stamp: 'jm 11/11/2002 18:57'! isNil "Answer true if the receiver is nil." ^ true ! ! !MUndefinedObject methodsFor: 'controlling'! ifNil: aBlock "A convenient test, in conjunction with Object ifNil:" ^ aBlock value! ! !MUndefinedObject methodsFor: 'controlling'! ifNil: nilBlock ifNotNil: ifNotNilBlock "Evaluate the block for nil because I'm == nil" ^ nilBlock value! ! !MUndefinedObject methodsFor: 'controlling'! ifNotNil: aBlock "A convenient test, in conjunction with Object ifNotNil:" ^ self! ! !MUndefinedObject methodsFor: 'copying' stamp: 'jm 12/2/2003 22:24'! basicCopy "There is the only one instance of me, so answer myself." ! ! !MUndefinedObject methodsFor: 'printing' stamp: 'jm 11/11/2002 18:53'! printOn: aStream aStream nextPutAll: 'nil'. ! ! !MUndefinedObject class methodsFor: 'instance creation' stamp: 'jm 12/8/2003 22:24'! new "There is a single unique instance of me." self cannotInstantiate. ! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'sma 4/30/2000 10:40'! displayAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." Smalltalk isMorphic ifFalse: [^ self]. World addMorph: self centeredNear: aPoint. self world displayWorld. "show myself" aBlock value. self delete! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'jm 10/13/2002 18:21'! informUserAt: aPoint during: aBlock "Add this menu to the Morphic world during the execution of the given block." | title | Smalltalk isMorphic ifFalse: [^ self]. title _ submorphs first submorphs first. self isHidden: true. aBlock value: [:string | self isHidden ifTrue: [ World addMorph: self centeredNear: aPoint. self isHidden: false]. title contents: string. self setConstrainedPositionFrom: Sensor cursorPoint. self changed. World displayWorld]. "show myself" self delete. World displayWorld! ! !MVCMenuMorph methodsFor: 'invoking' stamp: 'di 6/7/1999 15:45'! invokeAt: aPoint in: aWorld "Add this menu to the given world centered at the given point. Wait for the user to make a selection and answer it. The selection value returned is an integer in keeping with PopUpMenu, if the menu is converted from an MVC-style menu." "Details: This is invoked synchronously from the caller. In order to keep processing inputs and updating the screen while waiting for the user to respond, this method has its own version of the World's event loop." self popUpAt: aPoint forHand: aWorld primaryHand. done _ false. [self isInWorld & done not] whileTrue: [aWorld doOneSubCycle]. self delete. ^ selectedItem ! ! !MVCMenuMorph methodsFor: 'private' stamp: 'di 3/14/1999 13:12'! invokeItem: aMenuItem event: evt "Called by the MenuItemMorph that the user selects. Record the selection and set the done flag to end this interaction." selectedItem _ aMenuItem selector. done _ true. ! ! !MVCMenuMorph class methodsFor: 'instance creation' stamp: 'di 4/13/1999 17:08'! from: aPopupMenu title: titleStringOrNil "Answer a MenuMorph constructed from the given PopUpMenu. Used to simulate MVC-style menus in a Morphic-only world." | menu items lines selections labelString j emphasis | menu _ self new. titleStringOrNil ifNotNil: [ titleStringOrNil isEmpty ifFalse: [menu addTitle: titleStringOrNil]]. labelString _ aPopupMenu labelString. items _ labelString asString findTokens: String cr. labelString isText ifTrue: ["Pass along text emphasis if present" j _ 1. items _ items collect: [:item | j _ labelString asString findString: item startingAt: j. emphasis _ TextEmphasis new emphasisCode: (labelString emphasisAt: j). item asText addAttribute: emphasis]]. lines _ aPopupMenu lineArray. lines ifNil: [lines _ #()]. menu cancelValue: 0. selections _ (1 to: items size) asArray. 1 to: items size do: [:i | menu add: (items at: i) action: (selections at: i). (lines includes: i) ifTrue: [menu addLine]]. ^ menu ! ! A subclass of WiWPasteUpMorph that supports Morphic worlds embedded in MVC Views.! !MVCWiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/25/1999 10:10'! viewBox: newViewBox | vb | self damageRecorder reset. "since we may have moved, old data no longer valid" ((vb _ self viewBox) == nil or: [vb ~= newViewBox]) ifTrue: [self canvas: nil]. worldState viewBox: newViewBox. self bounds: newViewBox. "works better here than simply storing into bounds" self assuredCanvas. "Paragraph problem workaround; clear selections to avoid screen droppings:" self handsDo: [:h | h newKeyboardFocus: nil]. self fullRepaintNeeded. ! ! !MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'jm 10/5/2002 06:38'! becomeTheActiveWorldWith: evt self canvas: nil. "safer to start from scratch" ! ! !MVCWiWPasteUpMorph methodsFor: 'activation' stamp: 'RAA 11/25/1999 10:09'! revertToParentWorldWithEvent: evt ">>unused, but we may want some of this later self damageRecorder reset. World _ parentWorld. World assuredCanvas. World installFlaps. owner changed. hostWindow setStripeColorsFrom: Color red. World restartWorldCycleWithEvent: evt. <<<" ! ! !MVCWiWPasteUpMorph methodsFor: 'drawing' stamp: 'RAA 11/25/1999 09:12'! invalidRect: damageRect self damageRecorder ifNotNil: [self damageRecorder recordInvalidRect: damageRect] ! ! !MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/25/1999 09:20'! position: aPoint "Change the position of this morph and and all of its submorphs." | delta | delta _ aPoint - bounds topLeft. (delta x = 0 and: [delta y = 0]) ifTrue: [^ self]. "Null change" self changed. self privateFullMoveBy: delta. self changed. ! ! !MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/24/1999 18:59'! resetViewBox | c | (c _ self canvas) == nil ifTrue: [^self resetViewBoxForReal]. c form == Display ifFalse: [^self resetViewBoxForReal]. c origin = (0@0) ifFalse: [^self resetViewBoxForReal]. c clipRect extent = (self viewBox "intersect: parentWorld viewBox") extent ifFalse: [^self resetViewBoxForReal]. ! ! !MVCWiWPasteUpMorph methodsFor: 'geometry' stamp: 'ar 5/25/2000 17:59'! resetViewBoxForReal | newClip | self viewBox ifNil: [^self]. newClip _ self viewBox "intersect: parentWorld viewBox". self canvas: ( (Display getCanvas) copyOffset: 0@0 clipRect: newClip )! ! I support sequential reading and writing of a collection of objects. I keep track of the position of the next element to be processed; this position can be changed to allow random access. ! !MWriteStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 16:21'! contents "Answer with a copy of my collection up to the high-water mark that was written." readLimit _ readLimit max: position. ^ collection copyFrom: 1 to: readLimit ! ! !MWriteStream methodsFor: 'accessing' stamp: 'jm 10/26/2003 16:20'! position: anInteger "Set my read position, but remember the high-water mark that was written." readLimit _ readLimit max: position. super position: anInteger. ! ! !MWriteStream methodsFor: 'accessing'! size ^ readLimit _ readLimit max: position ! ! !MWriteStream methodsFor: 'writing' stamp: 'jm 10/26/2003 16:55'! nextPut: anObject "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." <primitive: 66> position >= writeLimit ifTrue: [^ self pastEndPut: anObject] ifFalse: [ position _ position + 1. ^ collection at: position put: anObject]. ! ! !MWriteStream methodsFor: 'writing' stamp: 'jm 10/26/2003 16:52'! nextPutAll: aCollection "Write the elements of the given collection starting at my current position. Answer the collection." "Optimization: If the given collection has the same class as my collection, use the fast operation replaceFrom:to:with:." | newEnd | collection class == aCollection class ifFalse: [ aCollection do: [:v | self nextPut: v]. ^ aCollection]. newEnd _ position + aCollection size. newEnd > writeLimit ifTrue: [ "grow my collection if necessary" collection _ collection, (collection species new: (newEnd - writeLimit + (collection size max: 20))). writeLimit _ collection size]. collection replaceFrom: position + 1 to: newEnd with: aCollection. position _ newEnd. ! ! !MWriteStream methodsFor: 'writing' stamp: 'jm 10/27/2003 05:49'! space "Append a space character to me." self nextPut: MCharacter space. ! ! !MWriteStream methodsFor: 'private'! on: aCollection super on: aCollection. readLimit _ 0. writeLimit _ aCollection size. ! ! !MWriteStream methodsFor: 'private' stamp: 'jm 10/26/2003 16:15'! pastEndPut: anObject "Grow my collection." "Details: In general, double my size. Grow by at least 20 elements if my size is under 20 and grow by 20000 if my size is over 20000." collection _ collection, (collection class new: ((collection size max: 20) min: 20000)). writeLimit _ collection size. collection at: (position _ position + 1) put: anObject. ! ! !MacFileDirectory class methodsFor: 'platform specific' stamp: 'di 5/11/1999 08:53'! isCaseSensitive "Mac OS ignores the case of file names" ^ false! ! I am an abstract representation of objects that measure something linear. Examples are dates, times, and numbers.! !Magnitude methodsFor: 'comparing' stamp: 'jm 2/25/2003 17:03'! within: min and: max "Answer the receiver if it is within the given interval [min..max]. Otherwise, answer the closest value within that interval." self < min ifTrue: [^ min]. self > max ifTrue: [^ max]. ^ self ! ! This class represents a transformation for points, that is a combination of scale, offset, and rotation. It is implemented as a 2x3 matrix containing the transformation from the local coordinate system in the global coordinate system. Thus, transforming points from local to global coordinates is fast and cheap whereas transformations from global to local coordinate systems are relatively expensive. Implementation Note: It is assumed that the transformation deals with Integer points. All transformations will return Integer coordinates (even though float points may be passed in here).! !MatrixTransform2x3 methodsFor: 'initialize' stamp: 'ar 11/2/1998 23:17'! setIdentiy "Initialize the receiver to the identity transformation (e.g., not affecting points)" self a11: 1.0; a12: 0.0; a13: 0.0; a21: 0.0; a22: 1.0; a23: 0.0.! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/4/1999 17:05'! at: index <primitive: 'primitiveFloatArrayAt'> ^Float fromIEEE32Bit: (self basicAt: index)! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 2/4/1999 17:05'! at: index put: value <primitive: 'primitiveFloatArrayAtPut'> value isFloat ifTrue:[self basicAt: index put: value asIEEE32BitWord] ifFalse:[self at: index put: value asFloat]. ^value! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/18/1998 14:03'! inverseTransformation "Return the inverse transformation of the receiver. The inverse transformation is computed by first calculating the inverse offset and then computing transformations for the two identity vectors (1@0) and (0@1)" | r1 r2 r3 m | r3 _ self invertPoint: 0@0. r1 _ (self invertPoint: 1@0) - r3. r2 _ (self invertPoint: 0@1) - r3. m _ self species new. m a11: r1 x; a12: r2 x; a13: r3 x; a21: r1 y; a22: r2 y; a23: r3 y. ^m! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:19'! offset ^self a13 @ self a23! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'! offset: aPoint self a13: aPoint x asFloat. self a23: aPoint y asFloat.! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a11 ^self at: 1! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a11: value self at: 1 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a12 ^self at: 2! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a12: value self at: 2 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a13 ^self at: 3! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a13: value self at: 3 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a21 ^self at: 4! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a21: value self at: 4 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a22 ^self at: 5! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a22: value self at: 5 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a23 ^self at: 6! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a23: value self at: 6 put: value! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:05'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." <primitive: 'm23PrimitiveIsIdentity'> ^self isPureTranslation and:[self a13 = 0.0 and:[self a23 = 0.0]]! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:15'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^true! ! !MatrixTransform2x3 methodsFor: 'testing' stamp: 'ar 11/2/1998 23:06'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." <primitive: 'm23PrimitiveIsPureTranslation'> ^self a11 = 1.0 and:[self a12 = 0.0 and:[self a22 = 0.0 and:[self a21 = 1.0]]]! ! !MatrixTransform2x3 methodsFor: 'comparing' stamp: 'bf 8/20/1999 12:47'! = aMatrixTransform2x3 | length | <primitive: 'primitiveFloatArrayEqual'> self class = aMatrixTransform2x3 class ifFalse: [^ false]. length _ self size. length = aMatrixTransform2x3 size ifFalse: [^ false]. 1 to: self size do: [:i | (self at: i) = (aMatrixTransform2x3 at: i) ifFalse: [^ false]]. ^ true! ! !MatrixTransform2x3 methodsFor: 'comparing' stamp: 'ar 11/2/1998 19:31'! hash | result | <primitive:'primitiveFloatArrayHash'> result _ 0. 1 to: self size do:[:i| result _ result + (self basicAt: i) ]. ^result bitAnd: 16r1FFFFFFF! ! !MatrixTransform2x3 methodsFor: 'composing' stamp: 'ar 11/2/1998 19:50'! composedWithLocal: aTransformation "Return the composition of the receiver and the local transformation passed in" aTransformation isMatrixTransform2x3 ifFalse:[^super composedWith: aTransformation]. ^self composedWithLocal: aTransformation asMatrixTransform2x3 into: self class new! ! !MatrixTransform2x3 methodsFor: 'composing' stamp: 'ar 11/2/1998 23:08'! composedWithLocal: aTransformation into: result "Return the composition of the receiver and the local transformation passed in. Store the composed matrix into result." | a11 a12 a13 a21 a22 a23 b11 b12 b13 b21 b22 b23 matrix | <primitive: 'm23PrimitiveComposeMatrix'> matrix _ aTransformation asMatrixTransform2x3. a11 _ self a11. b11 _ matrix a11. a12 _ self a12. b12 _ matrix a12. a13 _ self a13. b13 _ matrix a13. a21 _ self a21. b21 _ matrix a21. a22 _ self a22. b22 _ matrix a22. a23 _ self a23. b23 _ matrix a23. result a11: (a11 * b11) + (a12 * b21). result a12: (a11 * b12) + (a12 * b22). result a13: a13 + (a11 * b13) + (a12 * b23). result a21: (a21 * b11) + (a22 * b21). result a22: (a21 * b12) + (a22 * b22). result a23: a23 + (a21 * b13) + (a22 * b23). ^result! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/9/1998 13:46'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" <primitive: 'm23PrimitiveInvertPoint'> ^(self invertPoint: aPoint) rounded! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/16/1998 23:46'! invertPoint: aPoint "Transform aPoint from global coordinates into local coordinates" | x y det a11 a12 a21 a22 detX detY | x _ aPoint x asFloat - (self a13). y _ aPoint y asFloat - (self a23). a11 _ self a11. a12 _ self a12. a21 _ self a21. a22 _ self a22. det _ (a11 * a22) - (a12 * a21). det = 0.0 ifTrue:[^0@0]. "So we have at least a valid result" det _ 1.0 / det. detX _ (x * a22) - (a12 * y). detY _ (a11 * y) - (x * a21). ^(detX * det) @ (detY * det)! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/3/1998 03:04'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" <primitive: 'm23PrimitiveTransformPoint'> ^(self transformPoint: aPoint) rounded! ! !MatrixTransform2x3 methodsFor: 'transforming points' stamp: 'ar 11/2/1998 23:09'! transformPoint: aPoint "Transform aPoint from local coordinates into global coordinates" | x y | x _ (aPoint x * self a11) + (aPoint y * self a12) + self a13. y _ (aPoint x * self a21) + (aPoint y * self a22) + self a23. ^x @ y! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:41'! globalBounds: srcRect toLocal: dstRect "Transform aRectangle from global coordinates into local coordinates" <primitive:'m23PrimitiveInvertRectInto'> ^super globalBoundsToLocal: srcRect! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^self globalBounds: aRectangle toLocal: Rectangle new! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:41'! localBounds: srcRect toGlobal: dstRect "Transform aRectangle from local coordinates into global coordinates" <primitive:'m23PrimitiveTransformRectInto'> ^super localBoundsToGlobal: srcRect! ! !MatrixTransform2x3 methodsFor: 'transforming rects' stamp: 'ar 11/9/1998 14:40'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^self localBounds: aRectangle toGlobal: Rectangle new! ! !MatrixTransform2x3 methodsFor: 'converting' stamp: 'ar 11/2/1998 15:34'! asMatrixTransform2x3 ^self! ! !MatrixTransform2x3 methodsFor: 'printing' stamp: 'ar 11/2/1998 23:11'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; cr; print: self a11; tab; print: self a12; tab; print: self a13; cr; print: self a21; tab; print: self a22; tab; print: self a23; cr; nextPut:$).! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'! setAngle: angle "Set the raw rotation angle in the receiver" | rad s c | rad := angle degreesToRadians. s := rad sin. c := rad cos. self a11: c. self a12: s negated. self a21: s. self a22: c.! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:17'! setOffset: aPoint "Set the raw offset in the receiver" | pt | pt _ aPoint asPoint. self a13: pt x asFloat. self a23: pt y asFloat.! ! !MatrixTransform2x3 methodsFor: 'private' stamp: 'ar 11/2/1998 23:16'! setScale: aPoint "Set the raw scale in the receiver" | pt | pt _ aPoint asPoint. self a11: pt x asFloat. self a22: pt y asFloat.! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 22:50'! identity ^self new setScale: 1.0! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 7/9/1998 20:09'! new ^self new: 6! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/12/1998 01:25'! transformFromLocal: localBounds toGlobal: globalBounds ^((self withOffset: (globalBounds center)) composedWithLocal: (self withScale: (globalBounds extent / localBounds extent) asFloatPoint)) composedWithLocal: (self withOffset: localBounds center negated) " ^(self identity) setScale: (globalBounds extent / localBounds extent) asFloatPoint; setOffset: localBounds center negated asFloatPoint; composedWithGlobal:(self withOffset: globalBounds center asFloatPoint) "! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! withAngle: angle ^self new setAngle: angle! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'! withOffset: aPoint ^self identity setOffset: aPoint! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 23:17'! withRotation: angle ^self new setAngle: angle! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 02:49'! withScale: aPoint ^self new setScale: aPoint! ! !MenuItemMorph methodsFor: 'initialization' stamp: 'sw 12/8/1999 17:26'! initialize super initialize. bounds _ 0@0 extent: 10@10. color _ Color black. contents _ ''. hasFocus _ false. isEnabled _ true. subMenu _ nil. isSelected _ false. target _ nil. selector _ nil. arguments _ nil. font _ Preferences standardMenuFont. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 10/4/2002 08:34'! adaptToWorld: aWorld super adaptToWorld: aWorld. target isMorph ifTrue: [ target isWorldMorph ifTrue: [self target: aWorld]. target isHandMorph ifTrue: [self target: aWorld primaryHand]]. ! ! !MenuItemMorph methodsFor: 'drawing' stamp: 'sma 6/5/2000 14:50'! drawOn: aCanvas | selectionColor | isSelected & isEnabled ifTrue: [selectionColor _ Display depth <= 2 ifTrue: [Color gray] ifFalse: [owner color darker]. aCanvas fillRectangle: self bounds color: selectionColor]. super drawOn: aCanvas. subMenu ifNotNil: [aCanvas paintImage: SubMenuMarker at: self right - 8 @ (self top + self bottom - SubMenuMarker height // 2)]! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 6/24/1999 11:34'! invokeWithEvent: evt "Perform the action associated with the given menu item." | selArgCount | self isEnabled ifFalse: [^ self]. (owner isKindOf: MenuMorph) ifTrue: [owner lastSelection: selector]. Cursor normal showWhile: [ "show cursor in case item opens a new MVC window" (selArgCount _ selector numArgs) = 0 ifTrue: [target perform: selector] ifFalse: [selArgCount = arguments size ifTrue: [target perform: selector withArguments: arguments] ifFalse: [target perform: selector withArguments: (arguments copyWith: evt)]]] ! ! !MenuItemMorph methodsFor: 'events' stamp: 'sw 3/2/1999 13:39'! mouseDown: evt "Handle a mouse down event. Menu items get activated when the mouse is over them." self isInMenu ifFalse: [^ super mouseDown: evt]. evt shiftPressed ifTrue: [^ super mouseDown: evt]. "enable label editing" (owner hasProperty: #paletteMenu) ifFalse: [self bringMenuChainToFront]. self selectFromHand: evt hand ! ! !MenuItemMorph methodsFor: 'events' stamp: 'bf 11/23/1999 09:37'! mouseUp: evt "Handle a mouse up event. Menu items get activated when the mouse is over them." | mouseInMe | mouseInMe _ self containsPoint: evt cursorPoint. self deselectItem. self isInMenu ifTrue: [(mouseInMe and: [self selector = #toggleStayUp:]) ifFalse: [owner deleteIfPopUpFrom: self event: evt]. subMenu ifNil: [mouseInMe ifTrue: [evt hand world displayWorld. owner invokeItem: self event: evt]]] ifFalse: [self invokeWithEvent: evt] ! ! !MenuItemMorph methodsFor: 'layout' stamp: 'ar 5/18/2000 18:34'! layoutInWidth: w height: h | scanner | scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse. self extent: ((scanner stringWidth: contents) @ (scanner lineHeight) max: w@h). ! ! !MenuItemMorph methodsFor: 'layout' stamp: 'ar 5/18/2000 18:34'! minWidth | scanner | scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse. ^ (scanner stringWidth: contents) + (subMenu == nil ifTrue: [0] ifFalse: [10]) ! ! !MenuItemMorph methodsFor: 'private' stamp: 'sw 6/20/1999 23:39'! bringMenuChainToFront | menusToPopUp menu owningItem | menusToPopUp _ OrderedCollection new. menu _ self owner. [menu isKindOf: MenuMorph] whileTrue: [ menusToPopUp addFirst: menu. owningItem _ menu popUpOwner. (owningItem isKindOf: MenuItemMorph) ifTrue: [menu _ owningItem owner] ifFalse: [menu _ nil]]. menusToPopUp do: [:m | (m owner isKindOf: AlignmentMorph) ifFalse: [m owner addMorphFront: m]]. ! ! !MenuItemMorph methodsFor: 'private' stamp: 'di 8/8/1998 09:22'! selectFromHand: aHand self isSelected: true. aHand newMouseFocus: self. subMenu ifNotNil: [ subMenu delete. subMenu popUpAdjacentTo: (Array with: self bounds topRight + (10@0) with: self bounds topLeft) forHand: aHand from: self]. ! ! !MenuLineMorph methodsFor: 'drawing' stamp: 'sw 7/14/1999 10:14'! drawOn: aCanvas | pref | aCanvas fillRectangle: (bounds topLeft corner: bounds rightCenter) color: ((pref _ Preferences menuColorFromWorld) ifTrue: [owner color darker] ifFalse: [Preferences menuLineUpperColor]). aCanvas fillRectangle: (bounds leftCenter corner: bounds bottomRight) color: (pref ifTrue: [owner color lighter] ifFalse: [Preferences menuLineLowerColor])! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 11/22/1999 10:25'! itemWithWording: wording | aString aSubmenu subItem | "If any of the receiver's items or submenu items have the given wording (case-blind comparison done), then return it, else return nil." aString _ wording asString asLowercase. self items do: [:anItem | (anItem contents asString asLowercase = aString) ifTrue: [^ anItem]. (aSubmenu _ anItem subMenu) ifNotNil: [(subItem _ aSubmenu itemWithWording: wording) ifNotNil: [^ subItem]]]. ^ nil! ! !MenuMorph methodsFor: 'accessing' stamp: 'sw 4/19/1999 12:22'! lastItem ^ submorphs last! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! add: aString action: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the default target object." "Details: Note that the menu item added captures the default target object at the time the item is added; the default target can later be changed before added additional items without affecting the targets of previously added entries. The model is that each entry is like a button that knows everything it needs to perform its action." self add: aString target: defaultTarget selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! add: aString target: aTarget action: aSymbol self add: aString target: aTarget selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! add: aString target: anObject selector: aSymbol "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object." self add: aString target: anObject selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'md 12/15/1999 12:44'! addList: listOfPairs "Add the given items to this menu, where each item is a pair (<string> <actionSelector>).. ILf an element of the list is simply the symobl $-, add a line to the receiver." listOfPairs do: [:pair | #- = pair ifTrue: [self addLine] ifFalse: [self add: pair first action: pair last]]! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! addStayUpItem "Append a menu item that can be used to toggle this menu's persistent." self add: 'keep this menu up' target: self selector: #toggleStayUp: argumentList: Array empty. self addLine. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/19/1999 23:09'! addTitle: aString "Add a title line at the top of this menu." self addTitle: aString updatingSelector: nil updateTarget: nil! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 12/8/1999 17:53'! addTitle: aString updatingSelector: aSelector updateTarget: aTarget "Add a title line at the top of this menu Make aString its initial contents. If aSelector is not nil, then periodically obtain fresh values for its contents by sending aSelector to aTarget.." | title | title _ AlignmentMorph new. self setTitleParametersFor: title. title vResizing: #shrinkWrap. title orientation: #vertical. title centering: #center. aSelector ifNotNil: [title addMorphBack: (UpdatingStringMorph new lock; useStringFormat; target: aTarget; getSelector: aSelector)] ifNil: [(aString asString findTokens: String cr) do: [:line | title addMorphBack: (StringMorph contents: line font: Preferences standardMenuFont)]]. self addMorphFront: title. ! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! addUpdating: aWordingSelector action: aSymbol self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol self addUpdating: aWordingSelector enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/21/1999 11:32'! addUpdating: wordingSelector enablementSelector: enablementSelector target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled." | item | item _ UpdatingMenuItemMorph new target: target; selector: aSymbol; wordingProvider: target wordingSelector: wordingSelector; enablementSelector: enablementSelector; arguments: argList asArray. self addMorphBack: item. ! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 10/13/2002 17:38'! addUpdating: aWordingSelector target: aTarget action: aSymbol self addUpdating: aWordingSelector target: aTarget selector: aSymbol argumentList: Array empty. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/11/1999 16:46'! addUpdating: wordingSelector target: target selector: aSymbol argumentList: argList "Append a menu item with the given label. If the item is selected, it will send the given selector to the target object with the given arguments. If the selector takes one more argument than the number of arguments in the given list, then the triggering event is supplied as as the last argument. In this variant, the wording of the menu item is obtained by sending the wordingSelector to the target" | item | item _ UpdatingMenuItemMorph new target: target; selector: aSymbol; wordingProvider: target wordingSelector: wordingSelector; arguments: argList asArray. self addMorphBack: item. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 11/5/1998 21:13'! balloonTextForLastItem: balloonText submorphs last setBalloonText: balloonText! ! !MenuMorph methodsFor: 'construction' stamp: 'di 8/20/1998 09:30'! labels: labelList 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:." "Labels can be either a sting with embedded crs, or a collection of strings." | labelArray | (labelList isMemberOf: String) ifTrue: [labelArray _ labelList findTokens: String cr] ifFalse: [labelArray _ labelList]. 1 to: labelArray size do: [:i | self add: (labelArray at: i) action: (selectionsArray at: i). (linesArray includes: i) ifTrue: [self addLine]]. ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 7/1/1999 22:21'! title: aString "Add a title line at the top of this menu." self addTitle: aString! ! !MenuMorph methodsFor: 'control' stamp: 'jm 10/15/2002 17:18'! deleteIfPopUp "Remove this menu from the screen if stayUp is not true. If it is a submenu, also remove its owning menu." stayUp ifFalse: [self delete]. (popUpOwner notNil and: [popUpOwner isKindOf: MenuItemMorph]) ifTrue: [ popUpOwner isSelected: false. (popUpOwner owner isKindOf: MenuMorph) ifTrue: [popUpOwner owner deleteIfPopUp]]. ! ! !MenuMorph methodsFor: 'control' stamp: 'bf 11/23/1999 11:11'! deleteIfPopUpFrom: item event: evt "Remove this menu from the screen if stayUp is not true, but only if the user did move the mouse since invoking me. This allows for click-move-click selection style." stayUp ifFalse: [((self hasProperty: #stayUpOnce) or: [(evt cursorPoint dist: originalEvent cursorPoint) < 2]) ifTrue: [self removeProperty: #stayUpOnce. ^evt hand newMouseFocus: item "Do tracking and delete on next click"]]. self deleteIfPopUp. ! ! !MenuMorph methodsFor: 'control' stamp: 'di 3/14/1999 13:04'! invokeItem: aMenuItem "Perform the action associated with the given menu item." ^ self invokeItem: aMenuItem event: originalEvent! ! !MenuMorph methodsFor: 'control' stamp: 'di 3/14/1999 13:03'! invokeItem: aMenuItem event: evt "Perform the action associated with the given menu item." | sel target args selArgCount | aMenuItem isEnabled ifFalse: [^ self]. lastSelection _ aMenuItem. "to do: report lastSelection" sel _ aMenuItem selector. target _ aMenuItem target. args _ aMenuItem arguments. selArgCount _ sel numArgs. Cursor normal showWhile: [ "show cursor in case item opens a new MVC window" selArgCount = 0 ifTrue: [target perform: sel] ifFalse: [ selArgCount = args size ifTrue: [target perform: sel withArguments: args] ifFalse: [target perform: sel withArguments: (args copyWith: evt)]]]. ! ! !MenuMorph methodsFor: 'control' stamp: 'bf 11/23/1999 11:17'! justDroppedInto: aMorph event: anEvent "This menu was grabbed and moved. Save us from being deleted by the mouseUp event." stayUp ifFalse: [self setProperty: #stayUpOnce toValue: true]. super justDroppedInto: aMorph event: anEvent! ! !MenuMorph methodsFor: 'control' stamp: 'sma 6/5/2000 14:56'! popUpAdjacentTo: rightOrLeftPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | selectedItem delta tryToPlace selectedOffset | hand world startSteppingSubmorphsOf: self. popUpOwner _ sourceItem. originalEvent _ hand lastEvent. selectedItem _ self selectedItem. self fullBounds. "ensure layout is current" selectedOffset _ selectedItem position - self position. tryToPlace _ [:where :mustFit | self position: where - selectedOffset. delta _ self fullBoundsInWorld amountToTranslateWithin: hand worldBounds. (delta x = 0 or: [mustFit]) ifTrue: [delta = (0@0) ifFalse: [self position: self position + delta]. sourceItem owner owner addMorphFront: self. ^ self]]. tryToPlace value: rightOrLeftPoint first value: false; value: rightOrLeftPoint last - (self width @ 0) value: false; value: rightOrLeftPoint first value: true ! ! !MenuMorph methodsFor: 'control' stamp: 'sma 6/5/2000 13:55'! popUpAt: aPoint event: evt "Present this menu at the given point in response to the given event." self popUpAt: aPoint forHand: evt hand! ! !MenuMorph methodsFor: 'control' stamp: 'mir 5/25/2000 17:39'! popUpAt: aPoint forHand: hand "Present this menu at the given point under control of the given hand." | selectedItem i yOffset sub delta | hand resetClickState. popUpOwner _ hand. originalEvent _ hand lastEvent. selectedItem _ self items detect: [:each | each == lastSelection] ifNone: [self items isEmpty ifTrue: [^ self] ifFalse: [self items first]]. "Note: items may not be laid out yet (I found them all to be at 0@0), so have to add up heights of items above the selected item." i _ 0. yOffset _ 0. [(sub _ self submorphs at: (i _ i + 1)) == selectedItem] whileFalse: [yOffset _ yOffset + sub height]. self position: aPoint - (2 @ (yOffset + 8)). self bounds right > hand worldBounds right ifTrue: [self position: self position - (self bounds width - 4 @ 0)]. delta _ self bounds amountToTranslateWithin: hand worldBounds. delta = (0 @ 0) ifFalse: [self position: self position + delta]. hand world addMorphFront: self; startSteppingSubmorphsOf: self. hand newMouseFocus: selectedItem. self changed! ! !MenuMorph methodsFor: 'control' stamp: 'sma 6/5/2000 14:43'! popUpAt: aPoint forHand: hand from: sourceItem "Present this menu at the given point under control of the given hand." | selectedItem delta | popUpOwner _ sourceItem. originalEvent _ hand lastEvent. selectedItem _ self selectedItem. self fullBounds. "ensure layout is current" self position: aPoint - (selectedItem position - self position). sourceItem owner owner addMorphFront: self. delta _ self fullBoundsInWorld amountToTranslateWithin: hand worldBounds. delta = (0@0) ifFalse: [self position: self position + delta]! ! !MenuMorph methodsFor: 'control' stamp: 'sma 6/5/2000 13:54'! popUpEvent: evt "Present this menu in response to the given event." self popUpForHand: evt hand! ! !MenuMorph methodsFor: 'control' stamp: 'sma 6/5/2000 13:50'! popUpForHand: hand "Present this menu under control of the given hand." self popUpAt: hand position forHand: hand! ! !MenuMorph methodsFor: 'control' stamp: 'sw 5/26/2000 06:59'! popUpNearHand | aHand | aHand _ self currentHand. self popUpAt: aHand position forHand: aHand! ! !MenuMorph methodsFor: 'control' stamp: 'sw 5/9/2000 02:32'! willingToBeEmbeddedUponLanding ^ Preferences systemWindowEmbedOK! ! !MenuMorph methodsFor: 'initialization' stamp: 'sw 11/29/1999 17:38'! initialize super initialize. self setDefaultParameters. orientation _ #vertical. hResizing _ #shrinkWrap. vResizing _ #shrinkWrap. defaultTarget _ nil. lastSelection _ nil. stayUp _ false. originalEvent _ nil. popUpOwner _ nil. Preferences roundedMenuCorners ifTrue: [self useRoundedCorners] ! ! !MenuMorph methodsFor: 'initialization' stamp: 'sw 7/14/1999 10:21'! setDefaultParameters | worldColor | ((Preferences menuColorFromWorld and: [Display depth > 4]) and: [(worldColor _ self currentWorld color) isKindOf: Color]) ifTrue: [self setColor: (worldColor luminance > 0.7 ifTrue: [worldColor mixed: 0.8 with: Color black] ifFalse: [worldColor mixed: 0.4 with: Color white]) borderWidth: Preferences menuBorderWidth borderColor: #raised] ifFalse: [self setColor: Preferences menuColor borderWidth: Preferences menuBorderWidth borderColor: Preferences menuBorderColor]. inset _ 3! ! !MenuMorph methodsFor: 'initialization' stamp: 'sw 11/3/1998 11:23'! setTitleParametersFor: aMenuTitle aMenuTitle setColor: Preferences menuTitleColor borderWidth: Preferences menuTitleBorderWidth borderColor: Preferences menuTitleBorderColor! ! !MenuMorph methodsFor: 'menu' stamp: 'jm 10/15/2002 17:18'! toggleStayUp: evt "Toggle my 'stayUp' flag and adjust the menu item to reflect its new state." self items do: [:item | item selector = #toggleStayUp: ifTrue: [stayUp _ stayUp not. stayUp ifTrue: [item contents: 'dismiss this menu'] ifFalse: [item contents: 'keep this menu up']]]. stayUp ifFalse: [self delete]. ! ! !MenuMorph methodsFor: 'private' stamp: 'sma 6/5/2000 14:40'! positionAt: aPoint "Note: items may not be laid out yet (I found them all to be at 0@0), so we have to add up heights of items above the selected item." | i yOffset selectedItem sub delta | i _ 0. yOffset _ 0. selectedItem _ self selectedItem. [(sub _ self submorphs at: (i _ i + 1)) == selectedItem] whileFalse: [yOffset _ yOffset + sub height]. self position: aPoint - (2 @ (yOffset + 8)). "If it doesn't fit, show it to the left, not to the right of the hand." self right > popUpOwner worldBounds right ifTrue: [self left: self left - self width + 4]. "Make sure that the menu fits in the world." delta _ self bounds amountToTranslateWithin: popUpOwner worldBounds. delta = (0 @ 0) ifFalse: [self position: self position + delta]! ! !MenuMorph methodsFor: 'private' stamp: 'sma 6/5/2000 14:42'! positionAt: aPoint relativeTo: selectedItem "Note: items may not be laid out yet (I found them all to be at 0@0), so we have to add up heights of items above the selected item." | i yOffset sub delta | i _ 0. yOffset _ 0. [(sub _ self submorphs at: (i _ i + 1)) == selectedItem] whileFalse: [yOffset _ yOffset + sub height]. self position: aPoint - (2 @ (yOffset + 8)). "If it doesn't fit, show it to the left, not to the right of the hand." self right > popUpOwner worldBounds right ifTrue: [self left: self left - self width + 4]. "Make sure that the menu fits in the world." delta _ self bounds amountToTranslateWithin: popUpOwner worldBounds. delta = (0 @ 0) ifFalse: [self position: self position + delta]! ! !MenuMorph methodsFor: 'private' stamp: 'sma 6/5/2000 14:38'! selectedItem | items | items _ self items. ^ items detect: [:each | each == lastSelection] ifNone: [items first]! ! I represent a selector and its argument values. Generally, the system does not use instances of Message for efficiency reasons. However, when a message is not understood by its receiver, the interpreter will make up an instance of me in order to capture the information involved in an actual message transmission. This instance is sent it as an argument with the message doesNotUnderstand: to the receiver.! !Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:00'! printOn: aStream "Refer to the comment in Object|printOn:." super printOn: aStream. aStream nextPutAll: ' with selector: '; print: selector; nextPutAll: ' and arguments: '; print: args! ! !Message methodsFor: 'printing' stamp: 'sma 6/1/2000 10:01'! storeOn: aStream "Refer to the comment in Object|storeOn:." aStream nextPut: $(; nextPutAll: self class name; nextPutAll: ' selector: '; store: selector; nextPutAll: ' arguments: '; store: args; nextPut: $)! ! !Message methodsFor: 'sending' stamp: 'di 3/25/1999 21:54'! sentTo: receiver "answer the result of sending this message to receiver" lookupClass == nil ifTrue: [^ receiver perform: selector withArguments: args] ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! ! This node represents accesses to temporary variables for do-its in the debugger. Since they execute in another context, they must send a message to the original context to access the value of the temporary variable in that context.! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:38'! asStorableNode: encoder "This node is a message masquerading as a temporary variable. It currently has the form {homeContext tempAt: offset}. We need to generate code for {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack. This, in turn will get turned into {homeContext tempAt: offset put: expr} at runtime if nobody disturbs storeAt:inTempFrame: in Object (not clean)" ^ MessageAsTempNode new receiver: nil "suppress code generation for reciever already on stack" selector: #storeAt:inTempFrame: arguments: (arguments copyWith: receiver) precedence: precedence from: encoder! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 10/12/1999 17:29'! code "Allow synthetic temp nodes to be sorted by code" ^ arguments first literalValue! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! emitStorePop: stack on: codeStream "This node has the form {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack." ^ self emitForEffect: stack on: codeStream! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:35'! isTemp "Masquerading for debugger access to temps." ^ true! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! nowHasDef "For compatibility with temp scope protocol" ! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! nowHasRef "For compatibility with temp scope protocol" ! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! scope "For compatibility with temp scope protocol" ^ -1! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! scope: ignored "For compatibility with temp scope protocol" ! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:39'! sizeForStorePop: encoder "This node has the form {expr storeAt: offset inTempFrame: homeContext}, where the expr, the block argument, is already on the stack." ^ self sizeForEffect: encoder! ! !MessageAsTempNode methodsFor: 'access to remote temps' stamp: 'di 3/22/1999 09:40'! store: expr from: encoder "ctxt tempAt: n -> ctxt tempAt: n put: expr (see Assignment). For assigning into temps of a context being debugged." selector key ~= #tempAt: ifTrue: [^self error: 'cant transform this message']. ^ MessageAsTempNode new receiver: receiver selector: #tempAt:put: arguments: (arguments copyWith: expr) precedence: precedence from: encoder! ! I represent a receiver and its message. Precedence codes: 1 unary 2 binary 3 keyword 4 other If special>0, I compile special code in-line instead of sending messages with literal methods as remotely copied contexts.! !MessageNode methodsFor: 'initialize-release' stamp: 'di 1/28/2000 21:19'! receiver: rcvr selector: selNode arguments: args precedence: p "Decompile." self receiver: rcvr arguments: args precedence: p. self noteSpecialSelector: selNode key. selector _ selNode. "self pvtCheckForPvtSelector: encoder" "We could test code being decompiled, but the compiler should've checked already. And where to send the complaint?"! ! !MessageNode methodsFor: 'initialize-release' stamp: 'di 1/28/2000 21:19'! receiver: rcvr selector: selName arguments: args precedence: p from: encoder "Compile." self receiver: rcvr arguments: args precedence: p. self noteSpecialSelector: selName. (self transform: encoder) ifTrue: [selector isNil ifTrue: [selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro]] ifFalse: [selector _ encoder encodeSelector: selName. rcvr == NodeSuper ifTrue: [encoder noteSuper]]. self pvtCheckForPvtSelector: encoder! ! !MessageNode methodsFor: 'macro transformations' stamp: 'di 1/28/2000 21:19'! noteSpecialSelector: selectorSymbol " special > 0 flags specially treated messages. " special _ MacroSelectors indexOf: selectorSymbol. ! ! !MessageNode methodsFor: 'macro transformations' stamp: 'sma 3/3/2000 13:37'! toDoFromWhileWithInit: initStmt "Return nil, or a to:do: expression equivalent to this whileTrue:" | variable increment limit toDoBlock body test | (selector key == #whileTrue: and: [(initStmt isMemberOf: AssignmentNode) and: [initStmt variable isTemp]]) ifFalse: [^ nil]. body _ arguments last statements. variable _ initStmt variable. increment _ body last toDoIncrement: variable. (increment == nil or: [receiver statements size ~= 1]) ifTrue: [^ nil]. test _ receiver statements first. "Note: test chould really be checked that <= or >= comparison jibes with the sign of the (constant) increment" ((test isMemberOf: MessageNode) and: [(limit _ test toDoLimit: variable) notNil]) ifFalse: [^ nil]. toDoBlock _ BlockNode statements: body allButLast returns: false. toDoBlock arguments: (Array with: variable). ^ MessageNode new receiver: initStmt value selector: (SelectorNode new key: #to:by:do: code: #macro) arguments: (Array with: limit with: increment with: toDoBlock) precedence: precedence! ! !MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 00:48'! transformIfFalseIfTrue: encoder ((self checkBlock: (arguments at: 1) as: 'False arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'True arg' from: encoder]) ifTrue: [selector _ #ifTrue:ifFalse:. arguments swap: 1 with: 2. ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'di 4/24/2000 13:32'! transformIfNil: encoder (self transformBoolean: encoder) ifFalse: [^ false]. (MacroSelectors at: special) = #ifNotNil: ifTrue: [(self checkBlock: arguments first as: 'ifNotNil arg' from: encoder) ifFalse: [^ false]. "Transform 'ifNotNil: [stuff]' to 'ifNil: [nil] ifNotNil: [stuff]'. Slightly better code and more consistent with decompilation." self noteSpecialSelector: #ifNil:ifNotNil:. selector _ SelectorNode new key: (MacroSelectors at: special) code: #macro. arguments _ {BlockNode withJust: NodeNil. arguments first}. (self transform: encoder) ifFalse: [self error: 'compiler logic error']. ^ true] ifFalse: [^ self checkBlock: arguments first as: 'ifNil arg' from: encoder] ! ! !MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:49'! transformIfNilIfNotNil: encoder ((self checkBlock: (arguments at: 1) as: 'Nil arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'NotNil arg' from: encoder]) ifTrue: [selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro. receiver _ MessageNode new receiver: receiver selector: #== arguments: (Array with: NodeNil) precedence: 2 from: encoder. ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/28/2000 21:50'! transformIfNotNilIfNil: encoder ((self checkBlock: (arguments at: 1) as: 'NotNil arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'Nil arg' from: encoder]) ifTrue: [selector _ SelectorNode new key: #ifTrue:ifFalse: code: #macro. receiver _ MessageNode new receiver: receiver selector: #== arguments: (Array with: NodeNil) precedence: 2 from: encoder. arguments swap: 1 with: 2. ^true] ifFalse: [^false]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'acg 1/27/2000 22:29'! transformIfTrueIfFalse: encoder ^(self checkBlock: (arguments at: 1) as: 'True arg' from: encoder) and: [self checkBlock: (arguments at: 2) as: 'False arg' from: encoder]! ! !MessageNode methodsFor: 'macro transformations' stamp: 'tao 1/30/1999 08:56'! transformToDo: encoder " var _ rcvr. L1: [var <= arg1] Bfp(L2) [block body. var _ var + inc] Jmp(L1) L2: " | limit increment block initStmt test incStmt limitInit blockVar | "First check for valid arguments" ((arguments last isMemberOf: BlockNode) and: [arguments last numberOfArguments = 1]) ifFalse: [^ false]. arguments last firstArgument isVariableReference ifFalse: [^ false]. "As with debugger remote vars" arguments size = 3 ifTrue: [increment _ arguments at: 2. (increment isConstantNumber and: [increment literalValue ~= 0]) ifFalse: [^ false]] ifFalse: [increment _ encoder encodeLiteral: 1]. arguments size < 3 ifTrue: "transform to full form" [selector _ SelectorNode new key: #to:by:do: code: #macro]. "Now generate auxiliary structures" block _ arguments last. blockVar _ block firstArgument. initStmt _ AssignmentNode new variable: blockVar value: receiver. limit _ arguments at: 1. limit isVariableReference | limit isConstantNumber ifTrue: [limitInit _ nil] ifFalse: "Need to store limit in a var" [limit _ encoder autoBind: blockVar key , 'LimiT'. limit scope: -2. "Already done parsing block" limitInit _ AssignmentNode new variable: limit value: (arguments at: 1)]. test _ MessageNode new receiver: blockVar selector: (increment key > 0 ifTrue: [#<=] ifFalse: [#>=]) arguments: (Array with: limit) precedence: precedence from: encoder. incStmt _ AssignmentNode new variable: blockVar value: (MessageNode new receiver: blockVar selector: #+ arguments: (Array with: increment) precedence: precedence from: encoder). arguments _ (Array with: limit with: increment with: block) , (Array with: initStmt with: test with: incStmt with: limitInit). ^ true! ! !MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 21:59'! emitIfNil: stack on: strm value: forValue | theNode theSize theSelector | theNode _ arguments first. theSize _ sizes at: 1. theSelector _ #ifNotNil:. receiver emitForValue: stack on: strm. forValue ifTrue: [strm nextPut: Dup. stack push: 1]. strm nextPut: LdNil. stack push: 1. equalNode emit: stack args: 1 on: strm. self emitBranchOn: (selector key == theSelector) dist: theSize pop: stack on: strm. forValue ifTrue: [strm nextPut: Pop. stack pop: 1. theNode emitForEvaluatedValue: stack on: strm] ifFalse: [theNode emitForEvaluatedEffect: stack on: strm].! ! !MessageNode methodsFor: 'code generation' stamp: 'acg 1/28/2000 22:00'! sizeIfNil: encoder value: forValue | theNode theSize theSelector | equalNode _ encoder encodeSelector: #==. sizes _ Array new: 1. theNode _ arguments first. theSelector _ #ifNotNil:. forValue ifTrue: [sizes at: 1 put: (theSize _ (1 "pop" + (theNode sizeForEvaluatedValue: encoder))). ^(receiver sizeForValue: encoder) + 2 "Dup. LdNil" + (equalNode size: encoder args: 1 super: false) + (self sizeBranchOn: (selector key == theSelector) dist: theSize) + theSize] ifFalse: [sizes at: 1 put: (theSize _ (theNode sizeForEvaluatedEffect: encoder)). ^(receiver sizeForValue: encoder) + 1 "LdNil" + (equalNode size: encoder args: 1 super: false) + (self sizeBranchOn: (selector key == theSelector) dist: theSize) + theSize] ! ! !MessageNode methodsFor: 'printing' stamp: 'acg 1/28/2000 00:45'! printIfNil: aStream indent: level ^self printKeywords: selector key arguments: (Array with: arguments first) on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'di 1/28/2000 23:51'! printIfNilNotNil: aStream indent: level receiver ifNotNil: [receiver ifNilReceiver printOn: aStream indent: level precedence: precedence]. (arguments first isJust: NodeNil) ifTrue: [^ self printKeywords: #ifNotNil: arguments: { arguments second } on: aStream indent: level]. (arguments second isJust: NodeNil) ifTrue: [^ self printKeywords: #ifNil: arguments: { arguments first } on: aStream indent: level]. ^ self printKeywords: #ifNil:ifNotNil: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'di 1/28/2000 23:47'! printOn: aStream indent: level | printer | special > 0 ifTrue: [printer _ MacroPrinters at: special]. (printer == #printCaseOn:indent:) ifTrue: [^self printCaseOn: aStream indent: level]. (printer == #printIfNilNotNil:indent:) ifTrue: [^self printIfNilNotNil: aStream indent: level]. receiver == nil ifFalse: [receiver printOn: aStream indent: level precedence: precedence]. (special > 0) ifTrue: [self perform: printer with: aStream with: level] ifFalse: [self printKeywords: selector key arguments: arguments on: aStream indent: level]! ! !MessageNode methodsFor: 'private' stamp: 'acg 1/28/2000 00:57'! ifNilReceiver ^receiver! ! !MessageNode methodsFor: 'private' stamp: 'tk 8/2/1999 18:40'! pvtCheckForPvtSelector: encoder "If the code being compiled is trying to send a private message (e.g. 'pvtCheckForPvtSelector:') to anyone other than self, then complain to encoder." selector isPvtSelector ifTrue: [receiver isSelfPseudoVariable ifFalse: [encoder notify: 'Private messages may only be sent to self']].! ! !MessageNode methodsFor: 'equation translation' stamp: 'tk 8/4/1999 17:33'! eval "When everything in me is a constant, I can produce a value. This is only used by the Scripting system (TilePadMorph tilesFrom:in:)" | rec args | (receiver isKindOf: VariableNode) ifFalse: [^ #illegal]. rec _ receiver key value. args _ arguments collect: [:each | each eval]. ^ rec perform: selector key withArguments: args! ! !MessageNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:51'! asTranslatorNode "Selector is sometimes a Symbol, sometimes a SelectorNode!! On top of this, numArgs is needed due to the (truly grody) use of arguments as a place to store the extra expressions needed to generate code for in-line to:by:do:, etc. See below, where it is used." | sel args | sel _ (selector isMemberOf: Symbol) ifTrue: [selector] ifFalse: [selector key]. args _ (1 to: sel numArgs) collect: [:i | (arguments at: i) asTranslatorNode]. (sel = #to:by:do: and: [arguments size = 7 and: [(arguments at: 7) notNil]]) ifTrue: ["Restore limit expr that got moved by transformToDo:" args at: 1 put: (arguments at: 7) value asTranslatorNode]. (sel = #or: and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: ["Restore argument block that got moved by transformOr:" args at: 1 put: (arguments at: 2) asTranslatorNode]. (sel = #ifFalse: and: [arguments size = 2 and: [(arguments at: 2) notNil]]) ifTrue: ["Restore argument block that got moved by transformIfFalse:" args at: 1 put: (arguments at: 2) asTranslatorNode]. ^ TSendNode new setSelector: sel receiver: ((receiver == nil) ifTrue: [nil] ifFalse: [receiver asTranslatorNode]) arguments: args! ! !MessageNode class methodsFor: 'class initialization' stamp: 'acg 1/28/2000 21:58'! initialize "MessageNode initialize" MacroSelectors _ #(ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue: and: or: whileFalse: whileTrue: whileFalse whileTrue to:do: to:by:do: caseOf: caseOf:otherwise: ifNil: ifNotNil: ifNil:ifNotNil: ifNotNil:ifNil:). MacroTransformers _ #(transformIfTrue: transformIfFalse: transformIfTrueIfFalse: transformIfFalseIfTrue: transformAnd: transformOr: transformWhile: transformWhile: transformWhile: transformWhile: transformToDo: transformToDo: transformCase: transformCase: transformIfNil: transformIfNil: transformIfNilIfNotNil: transformIfNotNilIfNil:). MacroEmitters _ #(emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitIf:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitWhile:on:value: emitToDo:on:value: emitToDo:on:value: emitCase:on:value: emitCase:on:value: emitIfNil:on:value: emitIfNil:on:value: emitIf:on:value: emitIf:on:value:). MacroSizers _ #(sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeIf:value: sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeWhile:value: sizeToDo:value: sizeToDo:value: sizeCase:value: sizeCase:value: sizeIfNil:value: sizeIfNil:value: sizeIf:value: sizeIf:value: ). MacroPrinters _ #(printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printIfOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printWhileOn:indent: printToDoOn:indent: printToDoOn:indent: printCaseOn:indent: printCaseOn:indent: printIfNil:indent: printIfNil:indent: printIfNilNotNil:indent: printIfNilNotNil:indent:)! ! I represent a query path of the retrieval result of making a query about methods in the system. The result is a set of methods, denoted by a message selector and the class in which the method was found. As a StringHolder, the string I represent is the source code of the currently selected method. I am typically viewed in a Message Set Browser consisting of a MessageListView and a BrowserCodeView.! !MessageSet methodsFor: 'message list' stamp: 'sma 5/28/2000 11:10'! messageListIndex: anInteger "Set the index of the selected item to be anInteger." messageListIndex _ anInteger. contents _ messageListIndex ~= 0 ifTrue: [self selectedMessage] ifFalse: ['']. self changed: #messageListIndex. "update my selection" editSelection _ #editMessage. self contentsChanged. (messageListIndex ~= 0 and: [autoSelectString notNil]) ifTrue: [self changed: #autoSelect]. ! ! !MessageSet methodsFor: 'message list' stamp: 'sbw 12/30/1999 17:19'! optionalButtonHeight ^ 15! ! !MessageSet methodsFor: 'message list' stamp: 'sma 3/3/2000 11:17'! selectedMessageName "Answer the name of the currently selected message." "wod 6/16/1998: answer nil if none are selected." messageListIndex = 0 ifTrue: [^ nil]. ^ self setClassAndSelectorIn: [:class :selector | ^ selector]! ! !MessageSet methodsFor: 'message functions' stamp: 'sw 2/24/1999 18:31'! methodCategoryChanged self changed: #annotation! ! !MessageSet methodsFor: 'message functions' stamp: 'sw 1/28/1999 12:34'! removeMessage "Remove the selected message from the system. 1/15/96 sw" | 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: messageName. self initializeMessageList: (messageList copyWithout: self selection). "self messageListIndex: 0." self changed: #messageList. self changed: #messageListIndex. self contentsChanged. confirmation == 2 ifTrue: [Smalltalk browseAllCallsOn: messageName]! ! !MessageSet methodsFor: 'message functions' stamp: 'sw 1/28/1999 12:34'! removeMessageFromBrowser "Remove the selected message from the browser." messageListIndex = 0 ifTrue: [^ self]. self initializeMessageList: (messageList copyWithout: self selection). "self messageListIndex: 0." self changed: #messageList. self changed: #messageListIndex. self contentsChanged. ! ! !MessageSet methodsFor: 'message functions' stamp: 'sw 9/27/1999 15:30'! toggleDiff self okToChange ifTrue: [self showDiffs: self showDiffs not. self changed: #contents] ! ! !MessageSet methodsFor: 'contents' stamp: 'sma 5/28/2000 11:09'! contents ^ contents == nil ifTrue: [currentCompiledMethod _ nil. ''] ifFalse: [messageListIndex = 0 ifTrue: [currentCompiledMethod _ nil. contents] ifFalse: [editSelection == #byteCodes ifTrue: [(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName) symbolic] ifFalse: [self selectedMessage]]]! ! !MessageSet methodsFor: 'contents' stamp: 'sw 3/1/2000 10:57'! selectedMessage "Answer the source method for the currently selected message." | source | self setClassAndSelectorIn: [:class :selector | class ifNil: [^ 'Class vanished']. source _ class sourceMethodAt: selector ifAbsent: [currentCompiledMethod _ nil. ^ 'Missing']. currentCompiledMethod _ class compiledMethodAt: selector ifAbsent: [nil]. Preferences browseWithPrettyPrint ifTrue: [source _ class compilerClass new format: source in: class notifying: nil decorated: Preferences colorWhenPrettyPrinting]. self showDiffs ifTrue: [source _ self diffFromPriorSourceFor: source]. ^ source asText makeSelectorBoldIn: class]! ! !MessageSet methodsFor: 'contents' stamp: 'sw 10/19/1999 17:30'! updateCodePaneIfNeeded "If the code for the currently selected method has changed underneath me, then update the contents of my code pane unless it holds unaccepted edits. Overridden here in order not to set contents to nil" self didCodeChangeElsewhere ifTrue: [self hasUnacceptedEdits ifFalse: [self contentsChanged] ifTrue: [self changed: #codeChangedElsewhere]]! ! !MessageSet methodsFor: 'private' stamp: 'ls 12/5/1999 13:46'! contents: aString notifying: aController "Compile the code in aString. Notify aController of any syntax errors. 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 | messageListIndex = 0 ifTrue: [^ false]. self okayToAccept ifFalse: [^ false]. self setClassAndSelectorIn: [:c :os | class_c. oldSelector_os]. category _ class organization categoryOfElement: oldSelector. selector _ class compile: aString classified: category notifying: aController. selector == nil ifTrue: [^false]. selector == oldSelector ifFalse: [self messageListIndex: 0]. contents _ aString copy. self changed: #annotation. ^ true! ! !MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:58'! open: aMessageSet name: aString "Create a standard system view for the messageSet, aMessageSet, whose label is aString." | topView aListView aBrowserCodeView aTextView underPane y buttonsView winWidth | Smalltalk isMorphic ifTrue: [^ self openAsMorph: aMessageSet name: aString]. winWidth _ 200. topView _ (StandardSystemView new) model: aMessageSet. topView label: aString. topView minimumSize: winWidth @ 120. topView borderWidth: 1. aListView _ PluggableListView on: aMessageSet list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListView menuTitleSelector: #messageListSelectorTitle. aListView window: (0 @ 0 extent: winWidth @ 100). topView addSubView: aListView. Preferences useAnnotationPanes ifTrue: [ aTextView _ PluggableTextView on: aMessageSet text: #annotation accept: nil readSelection: nil menu: nil. aTextView window: (0 @ 0 extent: winWidth @ 24). topView addSubView: aTextView below: aListView. underPane _ aTextView. y _ 300 - 24. aTextView askBeforeDiscardingEdits: false] ifFalse: [ underPane _ aListView. y _ 300]. Preferences optionalButtons ifTrue: [ buttonsView _ aMessageSet buildOptionalButtonsView. topView addSubView: buttonsView below: underPane. underPane _ buttonsView. y _ y - aMessageSet optionalButtonHeight]. aBrowserCodeView _ PluggableTextView on: aMessageSet text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. aBrowserCodeView window: (0 @ 0 extent: winWidth @ y). topView addSubView: aBrowserCodeView below: underPane. topView setUpdatablePanesFrom: #(messageList). topView controller open! ! !MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:41'! openAsMorph: aMessageSet name: labelString "Create a SystemWindow aMessageSet, with the label labelString, in a Morphic project" ^ self openAsMorph: aMessageSet name: labelString inWorld: self currentWorld! ! !MessageSet class methodsFor: 'instance creation' stamp: 'sw 12/13/1999 10:26'! openAsMorph: aMessageSet name: labelString inWorld: aWorld "Create a SystemWindow aMessageSet, with the label labelString." | window aListMorph aTextMorph baseline | window _ (SystemWindow labelled: labelString) model: aMessageSet. aListMorph _ PluggableListMorph on: aMessageSet list: #messageList selected: #messageListIndex changeSelected: #messageListIndex: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 extent: 1@0.2). Preferences useAnnotationPanes ifFalse: [baseline _ 0.2] ifTrue: [aTextMorph _ PluggableTextMorph on: aMessageSet text: #annotation accept: nil readSelection: nil menu: nil. aTextMorph askBeforeDiscardingEdits: false. window addMorph: aTextMorph frame: (0@0.2 corner: 1@0.25). baseline _ 0.25]. Preferences optionalButtons ifTrue: [window addMorph: aMessageSet optionalButtonRow frame: ((0@baseline corner: 1 @ (baseline + 0.08))). baseline _ baseline + 0.08]. window addMorph: (PluggableTextMorph on: aMessageSet text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@baseline corner: 1@1). window setUpdatablePanesFrom: #(messageList). window openInWorld: aWorld! ! !MessageSet class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 09:59'! openMessageList: messageList name: labelString autoSelect: autoSelectString "Open a system view for a MessageSet on messageList. 1/24/96 sw: the there-are-no msg now supplied by my sender" | messageSet | messageSet _ self messageList: messageList. messageSet autoSelectString: autoSelectString. Smalltalk isMorphic ifTrue: [^ self openAsMorph: messageSet name: labelString]. ScheduledControllers scheduleActive: (self open: messageSet name: labelString)! ! !MessageSet class methodsFor: 'instance creation' stamp: 'sw 3/1/2000 10:59'! parse: messageString toClassAndSelector: csBlock "Decode strings of the form <className> [class] <selectorName>." | tuple cl | tuple _ messageString findTokens: ' .'. cl _ Smalltalk atOrBelow: tuple first asSymbol ifAbsent: [^ csBlock value: nil value: nil]. (tuple size = 2 or: [tuple size > 2 and: [(tuple at: 2) ~= 'class']]) ifTrue: [^ csBlock value: cl value: (tuple at: 2) asSymbol] ifFalse: [^ csBlock value: cl class value: (tuple at: 3) asSymbol]! ! I transmit and receive "messages", where a message is simply a String or ByteArray that is treated as an atomic unit of communication. When sending, I queue messages for transmission and stream them out in order. When receiving, I gather the incoming data into discrete messages. This allows clients code to treat message transmission as an atomic action; the sender can "send and forget" and the receiver will never see an incomplete message. Messages are transmitted as a four-byte size field followed by the bytes of the message. Notes: 1. Zero-length messages are allowed. 2. Since messages are buffered in memory in their entirety, this facility is not appropriate for transmitting large pieces of data (i.e., many megabytes) such as large sound or movie files, unless both ends have enough heap space to buffer the data. 3. The sender should call sendData and the receiver should call nextMessage frequently; these are the methods that actually feed data through the socket connection. ! !MessageSocket methodsFor: 'initialization' stamp: 'jm 8/20/2001 22:36'! initialize "Initialize this message socket." socket _ nil. inSizeBuf _ ByteArray new: 4. inSizeIndex _ 1. inBuf _ nil. inIndex _ 1. outgoingMessages _ OrderedCollection new. outBuf _ nil. outIndex _ 1. lastActivityTime _ Time totalSeconds. ! ! !MessageSocket methodsFor: 'initialization' stamp: 'jm 8/20/2001 22:36'! on: aSocket "Initialize this message socket on the given socket." self initialize. socket _ aSocket. ! ! !MessageSocket methodsFor: 'sending' stamp: 'jm 4/23/2003 08:53'! sendData "Send some more data, if possible. Answer true if there is more data to be sent. This method should be called frequently by the client. It does nothing if there are no messages to send, or if the socket is not connected or ready to accept data. If outBuf is not a bytes object (i.e., a ByteArray or String) then assume it is a positionable stream and let sendStreamData send it." | n szBuf | (socket notNil and: [socket isConnected]) ifFalse: [^ false]. socket waitForSendDoneUntil: (Socket deadlineSecs: 1). outBuf ifNil: [ "not currently sending" outgoingMessages size = 0 ifTrue: [^ false]. "no more message to send" socket sendDone ifFalse: [^ true]. "still sending last data" outBuf _ outgoingMessages removeFirst. outBuf class isBytes ifFalse: [^ self sendStreamData]. outIndex _ 1. szBuf _ ((WriteStream on: ByteArray new) uint32: outBuf size) contents. n _ socket sendDataNoWait: szBuf startIndex: 1. n > 0 ifTrue: [lastActivityTime _ Time totalSeconds]. n < 4 ifTrue: [ "unlikely case: socket did not accept entire 4-byte size" "prepend leftover bytes to outBuf" outBuf _ (szBuf copyFrom: n + 1 to: 4), outBuf]. outBuf size = 0 ifTrue: [outBuf _ nil]]. outBuf ifNotNil: [ "currently sending outBuf" outBuf class isBytes ifFalse: [^ self sendStreamData]. n _ socket sendDataNoWait: outBuf startIndex: outIndex. n > 0 ifTrue: [ lastActivityTime _ Time totalSeconds. outIndex _ outIndex + n. outIndex > outBuf size ifTrue: [ "finished sending the current message" outBuf _ nil]]]. ^ true ! ! !MessageSocket methodsFor: 'sending' stamp: 'jm 7/28/2001 20:06'! sendMessage: aByteArray "Add this message to the list of messages to be sent." outgoingMessages addLast: aByteArray. ! ! !MessageSocket methodsFor: 'sending' stamp: 'jm 4/23/2003 10:18'! sendStreamData "Private!! Used by sendData only when outBuf is a positionable stream. Send some data from outBuf, if possible. Set outBuf to nil when the entire stream has been sent. Always answer true. " | tempBuf n | tempBuf _ outBuf next: 10000. "read up to 10000 bytes from the stream" outBuf skip: tempBuf size negated. n _ socket sendDataNoWait: tempBuf startIndex: 1. n > 0 ifTrue: [ lastActivityTime _ Time totalSeconds. outBuf skip: n. outBuf atEnd ifTrue: [outBuf _ nil]]. "finished sending outbuf" ^ true ! ! !MessageSocket methodsFor: 'receiving' stamp: 'jm 6/27/2002 12:21'! nextMessage "Processing any data available on my socket and answer the next complete message, if any. Answer nil if the current messsage is not yet complete or if the socket is not connected." "Details: If msgBuf is nil, then we are in the process of reading the four-byte size field. Otherwise, we are in the process of reading the current message into msgBuf." | n sz msg | (socket notNil and: [socket isConnected]) ifFalse: [^ nil]. inBuf ifNil: [ n _ socket readInto: inSizeBuf startingAt: inSizeIndex. n > 0 ifTrue: [lastActivityTime _ Time totalSeconds]. inSizeIndex _ inSizeIndex + n. inSizeIndex > 4 ifTrue: [ "received message size; allocate the message buffer" sz _ (ReadStream on: inSizeBuf) uint32. sz > 1000000 ifTrue: [ "msg size over a megabyte; check available space" sz > (Smalltalk garbageCollect - 1000000) ifTrue: [ self error: 'message too big; bad size field?']]. inBuf _ ByteArray new: sz. inIndex _ 1]]. inBuf ifNotNil: [ n _ socket readInto: inBuf startingAt: inIndex. n > 0 ifTrue: [lastActivityTime _ Time totalSeconds]. inIndex _ inIndex + n. inIndex > inBuf size ifTrue: [ "received complete message; reset and answer it" msg _ inBuf. inBuf _ nil. inSizeIndex _ 1. "ready to read size field of the next message" ^ msg]]. ^ nil ! ! !MessageSocket methodsFor: 'receiving' stamp: 'jm 8/1/2001 07:25'! receiveProgress "Answer a Float between 0.0 and 1.0 indicating the amount of progress towards receiving the current message." inBuf ifNil: [^ 0.0]. "haven't even received the message size yet" ^ inIndex asFloat / inBuf size ! ! !MessageSocket methodsFor: 'receiving' stamp: 'jm 7/30/2001 22:08'! waitForData "Wait a little while for data to arrive. Return when data arrives or when the deadline time is reached, whichever comes first. Calling this allows other threads to run while this thread is waiting for data." ^ socket waitForDataUntil: (Socket deadlineSecs: 1) ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 9/6/2001 17:50'! connectTo: serverAddress port: serverPortNumber "Attempt to open a connection to the give port of the given host. Does not wait until the connection is established. Destroys previous socket, if any." Socket initializeNetwork. socket ifNotNil: [socket destroy]. socket _ Socket newTCP. socket connectTo: serverAddress port: serverPortNumber. ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 9/6/2001 17:51'! connectTo: serverAddress port: serverPortNumber waitSecs: waitSecs "Attempt to open a connection to the given port of the given host and wait for up to waitSecs for the connection to be established. Answer true if the connection is established. Destroys previous socket, if any." self connectTo: serverAddress port: serverPortNumber. socket waitForConnectionUntil: (Socket deadlineSecs: waitSecs). socket isConnected ifFalse: [ "connection attempt failed or timed out" socket destroy. socket _ nil]. ^ socket notNil ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 8/20/2001 22:38'! destroy "Destroy my socket, breaking the connection. Do nothing if it the socket is nil." socket ifNotNil: [ socket destroy. socket _ nil]. ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 7/29/2001 09:32'! isConnected "Answer true if my socket is connected." ^ socket notNil and: [socket isConnected] ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 8/20/2001 21:55'! secondsSinceLastActivity "Answer the time, in seconds, since data was last sent or received on this socket." ^ Time totalSeconds - lastActivityTime ! ! !MessageSocket methodsFor: 'connection' stamp: 'jm 7/28/2001 20:05'! socket "Answer my socket." ^ socket ! ! !MessageSocket methodsFor: 'requests' stamp: 'jm 8/20/2001 22:07'! request: aByteArrayOrString "Send the given message to the server and answer its reply message. Answer nil if the connection is broken before the transaction is complete. Wait indefinitely for the reply as long as the connection is unbroken." | reply sending | self sendMessage: aByteArrayOrString. [self isConnected] whileTrue: [ sending _ self sendData. reply _ self nextMessage. reply ifNotNil: [^ reply]. sending ifFalse: [socket waitForDataUntil: (Socket deadlineSecs: 1)]]. "connection was broken" self destroy. "close my end" ^ nil ! ! !MessageSocket methodsFor: 'requests' stamp: 'jm 8/20/2001 22:07'! request: aByteArrayOrString timeoutSecs: timeoutSecs "Send the given message to the server and answer its reply message. Answer nil if the connection is broken or timeoutSecs pass with no activity." | sending reply | self sendMessage: aByteArrayOrString. [self isConnected and: [self secondsSinceLastActivity < timeoutSecs]] whileTrue: [ sending _ self sendData. reply _ self nextMessage. reply ifNotNil: [^ reply]. sending ifFalse: [socket waitForDataUntil: (Socket deadlineSecs: 1)]]. ^ nil "timeout or broken connection" ! ! !MessageSocket methodsFor: 'requests' stamp: 'jm 4/23/2003 18:44'! request: aByteArrayOrString withStream: aPositionableStream "Send the given message to the server followed by the bytes from the given stream and answer its reply message. Answer nil if the connection is broken before the transaction is complete. Wait indefinitely for the reply as long as the connection is unbroken." | reply sending | self sendMessage: aByteArrayOrString. self sendMessage: aPositionableStream. [self isConnected] whileTrue: [ sending _ self sendData. reply _ self nextMessage. reply ifNotNil: [^ reply]. sending ifFalse: [socket waitForDataUntil: (Socket deadlineSecs: 1)]]. "connection was broken" self destroy. "close my end" ^ nil ! ! My instances observe and report the amount of time spent in methods. Observing a method implies observing all messages it sends. Q: How do you interpret MessageTally>>tallySends A: The methods #tallySends and #spyOn: measure two very different quantities, but broken down in the same who-called-who format. #spyOn: is approximate, but more indicative of real time spent, whereas #tallySends is exact and a precise record of how many times each method got executed.! !MessageTally methodsFor: 'initialize-release' stamp: 'stp 05/07/1999 15:31'! spyEvery: millisecs on: aBlock "Create a spy and spy on the given block at the specified rate." | myDelay value startTime time0 | (aBlock isMemberOf: BlockContext) ifFalse: [self error: 'spy needs a block here']. self class: aBlock receiver class method: aBlock method. "set up the probe" ObservedProcess _ Processor activeProcess. myDelay := Delay forMilliseconds: millisecs. time0 := Time millisecondClockValue. Timer := [[true] whileTrue: [startTime := Time millisecondClockValue. myDelay wait. self tally: ObservedProcess suspendedContext "tally can be > 1 if ran a long primitive" by: (Time millisecondClockValue - startTime) // millisecs]. nil] newProcess. Timer priority: Processor userInterruptPriority. "activate the probe and evaluate the block" Timer resume. value := aBlock value. "cancel the probe and return the value" Timer terminate. time := Time millisecondClockValue - time0. ^value! ! !MessageTally methodsFor: 'reporting' stamp: 'stp 05/07/1999 14:38'! report: strm cutoff: threshold tally = 0 ifTrue: [strm nextPutAll: ' - no tallies obtained'] ifFalse: [strm nextPutAll: ' - '; print: tally; nextPutAll: ' tallies, ', time printString, ' msec.'; cr; cr. self fullPrintOn: strm tallyExact: false orThreshold: threshold]! ! !MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 12:06'! tally "Answer the receiver's number of tally." ^tally! ! !MessageTally methodsFor: 'reporting' stamp: 'stp 05/08/1999 11:47'! time "Answer the receiver's run time." ^time! ! !MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:49'! fullPrintOn: aStream tallyExact: isExact orThreshold: perCent | threshold | isExact ifFalse: [threshold _ (perCent asFloat / 100 * tally) rounded]. aStream nextPutAll: '**Tree**'; cr. self treePrintOn: aStream tabs: OrderedCollection new thisTab: '' total: tally totalTime: time tallyExact: isExact orThreshold: threshold. aStream nextPut: Character newPage; cr. aStream nextPutAll: '**Leaves**'; cr. self leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold! ! !MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'! leavesPrintOn: aStream tallyExact: isExact orThreshold: threshold | dict | dict _ IdentityDictionary new: 100. self leavesInto: dict fromSender: nil. isExact ifTrue: [dict asSortedCollection do: [:node | node printOn: aStream total: tally totalTime: nil tallyExact: isExact. node printSenderCountsOn: aStream]] ifFalse: [(dict asOrderedCollection select: [:node | node tally > threshold]) asSortedCollection do: [:node | node printOn: aStream total: tally totalTime: time tallyExact: isExact]]! ! !MessageTally methodsFor: 'printing' stamp: 'ls 10/10/1999 11:56'! printOn: aStream | aSelector className aClass | aSelector _ class selectorAtMethod: method setClass: [:c | aClass _ c]. className _ aClass name contractTo: 30. aStream nextPutAll: className; nextPutAll: ' >> '; nextPutAll: (aSelector contractTo: 60-className size)! ! !MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:56'! printOn: aStream total: total totalTime: totalTime tallyExact: isExact | aSelector className myTally aClass percentage | isExact ifTrue: [myTally _ tally. receivers == nil ifFalse: [receivers do: [:r | myTally _ myTally - r tally]]. aStream print: myTally; space] ifFalse: [percentage _ tally asFloat / total * 100.0 roundTo: 0.1. aStream print: percentage; nextPutAll: '% {'; print: (percentage * totalTime / 100) rounded; nextPutAll: 'ms} ']. receivers == nil ifTrue: [aStream nextPutAll: 'primitives'; cr] ifFalse: [aSelector _ class selectorAtMethod: method setClass: [:c | aClass _ c]. className _ aClass name contractTo: 30. aStream nextPutAll: class name; nextPutAll: (aClass = class ifTrue: ['>>'] ifFalse: ['(' , aClass name , ')>>']); nextPutAll: (aSelector contractTo: 60-className size); cr]! ! !MessageTally methodsFor: 'printing' stamp: 'dew 3/22/2000 02:28'! printSenderCountsOn: aStream | mergedSenders mergedNode | mergedSenders _ IdentityDictionary new. senders do: [:node | mergedNode _ mergedSenders at: node method ifAbsent: [nil]. mergedNode == nil ifTrue: [mergedSenders at: node method put: node] ifFalse: [mergedNode bump: node tally]]. mergedSenders asSortedCollection do: [:node | 10 to: node tally printString size by: -1 do: [:i | aStream space]. node printOn: aStream total: tally totalTime: nil tallyExact: true]! ! !MessageTally methodsFor: 'printing' stamp: 'dew 3/15/2000 21:51'! treePrintOn: aStream tabs: tabs thisTab: myTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold | sons sonTab | tabs do: [:tab | aStream nextPutAll: tab]. tabs size > 0 ifTrue: [self printOn: aStream total: total totalTime: totalTime tallyExact: isExact]. sons _ isExact ifTrue: [receivers] ifFalse: [self sonsOver: threshold]. sons isEmpty ifFalse: [tabs addLast: myTab. sons _ sons asSortedCollection. (1 to: sons size) do: [:i | sonTab _ i < sons size ifTrue: [' |'] ifFalse: [' ']. (sons at: i) treePrintOn: aStream tabs: (tabs size < 18 ifTrue: [tabs] ifFalse: [(tabs select: [:x | x = '[']) copyWith: '[']) thisTab: sonTab total: total totalTime: totalTime tallyExact: isExact orThreshold: threshold]. tabs removeLast]! ! My instances add instance-specific behavior to various class-describing objects in the system. This typically includes messages for initializing class variables and instance creation messages particular to a class. There is only one instance of a particular Metaclass, namely the class which is being described. A Metaclass shares the class variables of its instance. [Subtle] In general, the superclass hierarchy for metaclasses parallels that for classes. Thus, Integer superclass == Number, and Integer class superclass == Number class. However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, and Object class superclass == Class. [Subtle detail] A class is know by name to an environment. Typically this is the SystemDictionary named Smalltalk. If we ever make lightweight classes that are not in Smalltalk, they must be in some environment. Specifically, the code that sets 'wasPresent' in name:inEnvironment:subclassOf:instanceVariableNames:variable:words:pointers:classVariableNames:poolDictionaries:category:comment:changed: must continue to work.! !Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/13/1999 04:52'! adoptInstance: oldInstance from: oldMetaClass "Recreate any existing instances of the argument, oldClass, as instances of the receiver, which is a newly changed class. Permute variables as necessary." thisClass class == self ifTrue:[^self error:'Metaclasses have only one instance']. oldMetaClass isMeta ifFalse:[^self error:'Argument must be Metaclass']. oldInstance class == oldMetaClass ifFalse:[^self error:'Not the class of argument']. ^thisClass _ self newInstanceFrom: oldInstance variable: self isVariable size: self instSize map: (self instVarMappingFrom: oldMetaClass)! ! !Metaclass methodsFor: 'initialize-release' stamp: 'ar 7/15/1999 18:56'! instanceVariableNames: instVarString "Declare additional named variables for my instance." ^(ClassBuilder new) class: self instanceVariableNames: instVarString! ! !Metaclass methodsFor: 'initialize-release' stamp: 'jm 10/14/2002 18:34'! 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." | oldInstances | oldInstances _ oldClass allInstances asArray. self updateInstances: oldInstances from: oldClass isMeta: true. ! ! !Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 08:14'! allInstances thisClass class == self ifTrue:[^Array with: thisClass]. ^super allInstances! ! !Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'! environment ^thisClass environment! ! !Metaclass methodsFor: 'instance creation' stamp: 'ar 7/11/1999 10:07'! new "The receiver can only have one instance. Create it or complain that one already exists." thisClass class ~~ self ifTrue: [^thisClass _ super new] ifFalse: [self error: 'A Metaclass should only have one instance!!']! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! addSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! removeSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'! subclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass subclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses_nil' for: m logged: false]"! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'jm 5/16/2003 09:48'! subclassesDo: aBlock "Evaluate aBlock for each of the receiver's immediate subclasses. Skip metaclasses." thisClass subclassesDo: [:cl | cl isMeta ifFalse: [aBlock value: cl class]]. ! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'! fileOutInitializerOn: aStream (self methodDict includesKey: #initialize) ifTrue: [aStream cr. aStream nextChunkPut: thisClass name , ' initialize'].! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:31'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex ^self fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: true! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. (aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: [aFileStream cr. aFileStream cr. aFileStream nextChunkPut: thisClass name , ' initialize'. aFileStream cr]! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'! nonTrivial "Answer whether the receiver has any methods or instance variables." ^ self instVarNames size > 0 or: [self methodDict size > 0]! ! !Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" thisClass == nil ifTrue:[^true] ifFalse:[^thisClass canZapMethodDictionary]! ! !Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'! isObsolete "Return true if the receiver is obsolete" ^thisClass == nil "Either no thisClass" or:[thisClass class ~~ self "or I am not the class of thisClass" or:[thisClass isObsolete]] "or my instance is obsolete"! ! !Metaclass methodsFor: 'enumerating' stamp: 'ar 7/15/1999 16:43'! allInstancesDo: aBlock "There should be only one" thisClass class == self ifTrue:[^aBlock value: thisClass]. ^super allInstancesDo: aBlock! ! !Metaclass class methodsFor: 'anti-corruption' stamp: 'di 11/24/1999 13:30'! isScarySelector: newbieSelector "Return true if newbieSelector is already a part of Metaclass protocol." (Metaclass includesSelector: newbieSelector) ifTrue: [^ true]. (ClassDescription includesSelector: newbieSelector) ifTrue: [^ true]. (Behavior includesSelector: newbieSelector) ifTrue: [^ true]. ^ false ! ! MethodChangeRecords are used to record method changes. Here is a simple summary of the relationship between the changeType symbol and the recording of prior state | prior == nil | prior not nil --------- |---------------------------- |-------------------- add | add | change --------- |---------------------------- |-------------------- remove | addedThenRemoved | remove Structure: changeType symbol -- as summarized above currentMethod method This is the current version of the method. It can be used to assert this change upon entry to a layer. infoFromRemoval -- an array of size 2. The first element is the source index of the last version of the method. The second element is the category in which it was defined, so it can be put back there if re-accepted from a version browser. Note that the above states each have an associated revoke action: add --> remove change --> change back remove --> add back addedThenRemoved --> no change However all of these are accomplished trivially by restoring the original method dictionary.! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! changeType ^ changeType! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:34'! currentMethod ^ currentMethod! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! methodInfoFromRemoval "Return an array with the source index of the last version of the method, and the category in which it was defined (so it can be put back there if re-accepted from a version browser)." (changeType == #remove or: [changeType == #addedThenRemoved]) ifTrue: [^ infoFromRemoval] ifFalse: [^ nil]! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/4/2000 11:05'! noteChangeType: newChangeType (changeType == #addedThenRemoved and: [newChangeType == #change]) ifTrue: [changeType _ #add] ifFalse: [changeType _ newChangeType]! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 11:05'! noteMethodInfoFromRemoval: info "Store an array with the source index of the last version of the method, and the category in which it was defined (so it can be put back there if re-accepted from a version browser)." infoFromRemoval _ info! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 3/28/2000 23:32'! noteNewMethod: newMethod currentMethod _ newMethod! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! printOn: strm super printOn: strm. strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! ! !MethodChangeRecord methodsFor: 'as yet unclassified' stamp: 'di 4/1/2000 10:47'! priorMethod: ignored "We do not save original versions of changed methods because we only revoke changes at the level of entire classes, and that is done by restoration of the entire methodDictionary."! ! My instances hold all the dynamic state associated with the execution of a CompiledMethod. In addition to their inherited state, this includes the receiver, a method, and temporary space in the variable part of the context. MethodContexts, though normal in their variable size, are actually only used in two sizes, small and large, which are determined by the temporary space required by the method being executed. MethodContexts must only be created using the method newForMethod:. Note that it is impossible to determine the real object size of a MethodContext except by asking for the frameSize of its method. Any fields above the stack pointer (stackp) are truly invisible -- even (and especially!!) to the garbage collector. Any store into stackp other than by the primitive method stackp: is potentially fatal.! !MethodContext methodsFor: 'initialize-release' stamp: 'di 1/11/1999 10:24'! restart "Reinitialize the receiver so that it is in the state it was at its creation." pc _ method initialPC. self stackp: method numTemps! ! !MethodContext methodsFor: 'private' stamp: 'di 1/14/1999 22:30'! instVarAt: index put: value index = 3 ifTrue: [self stackp: value. ^ value]. ^ super instVarAt: index put: value! ! !MethodContext methodsFor: 'private' stamp: 'di 1/11/1999 10:23'! setSender: s receiver: r method: m arguments: args "Create the receiver's initial state." sender _ s. receiver _ r. method _ m. pc _ method initialPC. self stackp: method numTemps. 1 to: args size do: [:i | self at: i put: (args at: i)]! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 6/7/1999 20:46'! cannotReturn: result Debugger openContext: thisContext label: 'computation has been terminated' contents: thisContext printString! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 3/23/1999 13:00'! receiver: r receiver := r! ! !MethodContext class methodsFor: 'instance creation' stamp: 'di 10/23/1999 17:06'! sender: s receiver: r method: m arguments: args "Answer an instance of me with attributes set to the arguments." ^(self newForMethod: m) setSender: s receiver: r method: m arguments: args! ! I am just like a normal Dictionary, except that I am implemented differently. Each Class has an instances of MethodDictionary to hold the correspondence between selectors (names of methods) and methods themselves. In a normal Dictionary, the instance variable 'array' holds an array of Associations. Since there are thousands of methods in the system, these Associations waste space. Each MethodDictionary is a variable object, with the list of keys (selector Symbols) in the variable part of the instance. The variable 'array' holds the values, which are CompiledMethods.! !MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:17'! keyAtIdentityValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." | theKey | 1 to: self basicSize do: [:index | value == (array at: index) ifTrue: [(theKey _ self basicAt: index) == nil ifFalse: [^ theKey]]]. ^ exceptionBlock value! ! !MethodDictionary methodsFor: 'accessing' stamp: 'ar 2/13/1999 21:00'! keyAtValue: value ifAbsent: exceptionBlock "Answer the key whose value equals the argument, value. If there is none, answer the result of evaluating exceptionBlock." | theKey | 1 to: self basicSize do: [:index | value = (array at: index) ifTrue: [(theKey _ self basicAt: index) == nil ifFalse: [^ theKey]]]. ^ exceptionBlock value! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 08:05'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys and values passed to the block" | key | tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (key _ self basicAt: i) == nil ifFalse: [aBlock value: key value: (array at: i)] ]! ! !MethodDictionary methodsFor: 'enumeration' stamp: 'ar 7/11/1999 07:29'! valuesDo: aBlock | value | tally = 0 ifTrue: [^ self]. 1 to: self basicSize do: [:i | (value _ array at: i) == nil ifFalse: [aBlock value: value]]! ! I am the root of the parse tree.! !MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'! block ^ block! ! !MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:48'! generate: trailer "The receiver is the root of a parse tree. Answer a CompiledMethod. The argument, trailer, is the references to the source code that is stored with every CompiledMethod." | blkSize nLits stack strm nArgs method | self generate: trailer ifQuick: [:m | method _ m. method cacheTempNames: self tempNames. ^ method]. nArgs _ arguments size. blkSize _ block sizeForEvaluatedValue: encoder. literals _ encoder allLiterals. (nLits _ literals size) > 255 ifTrue: [^self error: 'Too many literals referenced']. method _ CompiledMethod "Dummy to allocate right size" newBytes: blkSize trailerBytes: trailer nArgs: nArgs nTemps: encoder maxTemp nStack: 0 nLits: nLits primitive: primitive. strm _ ReadWriteStream with: method. strm position: method initialPC - 1. stack _ ParseStack new init. block emitForEvaluatedValue: stack on: strm. stack position ~= 1 ifTrue: [^self error: 'Compiler stack discrepancy']. strm position ~= (method size - trailer size) ifTrue: [^self error: 'Compiler code size discrepancy']. method needsFrameSize: stack size. 1 to: nLits do: [:lit | method literalAt: lit put: (literals at: lit)]. method cacheTempNames: self tempNames. ^ method! ! !MethodNode methodsFor: 'code generation' stamp: 'di 5/25/2000 06:45'! generate: trailer ifQuick: methodBlock | v | (primitive = 0 and: [arguments size = 0 and: [block isQuick]]) ifFalse: [^ self]. v _ block code. v < 0 ifTrue: [^ self]. v = LdSelf ifTrue: [^ methodBlock value: (CompiledMethod toReturnSelfTrailerBytes: trailer)]. (v between: LdTrue and: LdMinus1 + 3) ifTrue: [^ methodBlock value: (CompiledMethod toReturnConstant: v - LdSelf trailerBytes: trailer)]. v < ((CodeBases at: LdInstType) + (CodeLimits at: LdInstType)) ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v trailerBytes: trailer)]. v // 256 = 1 ifTrue: [^ methodBlock value: (CompiledMethod toReturnField: v \\ 256 trailerBytes: trailer)]! ! !MethodNode methodsFor: 'printing' stamp: 'sw 11/17/1999 13:57'! printOn: aStream | args | precedence = 1 ifTrue: [aStream nextPutAll: self selector] ifFalse: [args _ ReadStream on: arguments. self selector keywords do: [:s | aStream nextPutAll: s; space. aStream withAttributes: (Preferences syntaxAttributesFor: #methodArgument) do: [aStream nextPutAll: args next key]. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1. aStream nextPutAll: '| '. aStream withAttributes: (Preferences syntaxAttributesFor: #temporaryVariable) do: [temporaries do: [:temp | aStream nextPutAll: temp key. aStream space]]. aStream nextPut: $|]. primitive > 0 ifTrue: [(primitive between: 255 and: 519) ifFalse: " Dont decompile <prim> for, eg, ^ self " [aStream crtab: 1. self printPrimitiveOn: aStream]]. aStream crtab: 1. ^ block printStatementsOn: aStream indent: 0! ! !MethodNode methodsFor: 'printing' stamp: 'ar 11/28/1999 19:38'! printPrimitiveOn: aStream "Print the primitive on aStream" | primIndex primDecl | primIndex _ primitive. primIndex = 0 ifTrue:[^self]. primIndex = 120 "External call spec" ifTrue:[^aStream print: encoder literals first]. aStream nextPutAll: '<primitive: '. primIndex = 117 ifTrue:[ primDecl _ encoder literals at: 1. aStream nextPut: $'; nextPutAll: (primDecl at: 2); nextPut:$'. (primDecl at: 1) notNil ifTrue:[ aStream nextPutAll:' module:'; nextPut:$'; nextPutAll: (primDecl at: 1); nextPut:$'. ]. ] ifFalse:[aStream print: primIndex]. aStream nextPut: $>.! ! !MethodNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:56'! asTMethodFromClass: aClass ^ TMethod new setSelector: selectorOrFalse args: arguments locals: encoder tempsAndBlockArgs block: block primitive: primitive ! ! !MicroSqueak class methodsFor: 'space analysis' stamp: 'jm 1/11/2004 08:55'! analyzeLiterals "MicroSqueak analyzeLiterals" | results floats smallInts bigInts arrayBytes stringBytes symbolBytes oldCount | results _ Dictionary new. floats _ smallInts _ bigInts _ arrayBytes _ stringBytes _ symbolBytes _ 0. self allLiteralsAndClassVars do: [:o | o isNumber ifTrue: [ o isFloat ifTrue: [floats _ floats + 1] ifFalse: [ ((o >= -16384) and: [o <= 16383]) ifTrue: [smallInts _ smallInts + 1] ifFalse: [bigInts _ bigInts + 1]]] ifFalse: [ o class == Array ifTrue: [arrayBytes _ arrayBytes + (4 * o size)]. o class == String ifTrue: [stringBytes _ stringBytes + o size]. o class == Symbol ifTrue: [symbolBytes _ symbolBytes + o size]. oldCount _ results at: o class name ifAbsent: [0]. results at: o class name put: oldCount + 1]]. results at: #Float put: floats. results at: #SmallInteger put: smallInts. results at: #LargeInteger put: bigInts. results at: 'string bytes' put: stringBytes. results at: 'symbol bytes' put: symbolBytes. results at: 'array bytes' put: arrayBytes. ^ results ! ! !MicroSqueak class methodsFor: 'space analysis' stamp: 'jm 11/2/2003 20:12'! codeSize "Size of MethodDictionaries and CompiledMethods. Not including literals, classes, class variables, globals, or anything else." | result | result _ 0. MObject withAllSubclassesDo: [:c | result _ result + (self codeSizeFor: c methodDict) + (self codeSizeFor: c class methodDict)]. ^ result ! ! !MicroSqueak class methodsFor: 'space analysis' stamp: 'jm 11/11/2002 17:56'! stats | classVarCount methodCount literalCount bytecodeCount classes | classVarCount _ methodCount _ literalCount _ bytecodeCount _ 0. classes _ MObject withAllSubclasses asArray. classes do: [:c | classVarCount _ classVarCount + c classPool size. (c methodDict asArray, c class methodDict asArray) do: [:m | methodCount _ methodCount + 1. literalCount _ literalCount + m literals size. bytecodeCount _ bytecodeCount + (m endPC - m initialPC + 1)]]. ^ 'MicroSqueak Stats: classes: ', classes size printString, ' class vars: ', classVarCount printString, ' methods: ', methodCount printString, ' literals: ', literalCount printString, ' bytecodes: ', bytecodeCount printString, ' '. ! ! !MicroSqueak class methodsFor: 'message analysis' stamp: 'jm 10/28/2003 12:50'! implemented | result | result _ Set new. MObject withAllSubclassesDo: [:c | result addAll: c methodDict keys. result addAll: c class methodDict keys]. ^ result asArray sort ! ! !MicroSqueak class methodsFor: 'message analysis' stamp: 'jm 11/3/2003 20:49'! selectorsReachableFrom: initialList "(MicroSqueak selectorsReachableFrom: #(+)) size" "(MicroSqueak selectorsReachableFrom: #(isEmpty)) size" "(MicroSqueak selectorsReachableFrom: #(printString)) size" | selectorMap addBlock sel entry reachable toDo | selectorMap _ Dictionary new: 1000. addBlock _ [:a | entry _ selectorMap at: a key ifAbsent: [Set new]. entry addAll: a value messages. selectorMap at: a key put: entry]. MObject withAllSubclasses do: [:cl | cl methodDict associationsDo: addBlock. cl class methodDict associationsDo: addBlock]. reachable _ Set new: 1000. toDo _ OrderedCollection withAll: initialList. [toDo size > 0] whileTrue: [ sel _ toDo removeFirst. (reachable includes: sel) ifFalse: [ reachable add: sel. toDo addAll: (selectorMap at: sel ifAbsent: [#()])]]. ^ reachable asArray sort ! ! !MicroSqueak class methodsFor: 'message analysis' stamp: 'jm 10/28/2003 12:52'! sent | result | result _ IdentitySet new. MObject withAllSubclassesDo: [:c | (c methodDict asArray, c class methodDict asArray) do: [:m | m literals do: [:lit | (lit isKindOf: Symbol) ifTrue: [result add: lit]]]]. ^ result asArray sort ! ! !MicroSqueak class methodsFor: 'message analysis' stamp: 'jm 12/17/2003 21:47'! unimplemented | result | result _ self sent asSet. self implemented do: [:sel | result remove: sel ifAbsent: []]. result remove: #DoIt ifAbsent: []. ^ result asArray ! ! !MicroSqueak class methodsFor: 'message analysis' stamp: 'jm 12/31/2003 14:35'! unsent | result reservedSelectors | result _ self implemented asSet. self sent do: [:sel | result remove: sel ifAbsent: []]. reservedSelectors _ #( ifError: ifFalse: ifTrue: ifTrue:ifFalse: ifNil: ifNil:ifNotNil: ifNotNil: ifNotNil:ifNil: isNil from:to: timesRepeat: to:by: to:by:do: to:do: and: or: yourself doesNotUnderstand: halt mustBeBoolean perform: perform:with:). Smalltalk specialSelectors, reservedSelectors do: [:el | el isNumber ifFalse: [result remove: el ifAbsent: []]]. ^ result asArray sort ! ! !MicroSqueak class methodsFor: 'class and variable analysis' stamp: 'jm 11/26/2003 18:58'! allLiteralsAndClassVars "MicroSqueak allLiteralsAndClassVars" | result | result _ OrderedCollection new. MObject withAllSubclassesDo: [:c | result addAll: c classPool. (c methodDict asArray, c class methodDict asArray) do: [:m | result addAll: m literals]]. ^ result asArray select: [:o | o ~~ nil] "don't include nil values" ! ! !MicroSqueak class methodsFor: 'class and variable analysis' stamp: 'jm 12/17/2003 21:43'! classAndGlobalRefs | refs | refs _ Set new. MObject withAllSubclasses do: [:c | (c methodDict asArray, c class methodDict asArray) do: [:m | m literals do: [:lit | (lit class = Association and: [lit key notNil]) ifTrue: [refs add: lit key]]]]. MObject withAllSubclasses do: [:c | refs remove: c name ifAbsent: []. c classPool keys do: [:classVar | refs remove: classVar ifAbsent: []]]. refs remove: #Processor ifAbsent: []. ^ refs asArray sort ! ! !MicroSqueak class methodsFor: 'class and variable analysis' stamp: 'jm 11/2/2003 20:32'! classStats "Answer a string describing all the MicroSqueak classes and their stats." | s | s _ WriteStream on: (String new: 10000). self writeClassStatsFor: MObject indent: 0 on: s. ^ s contents ! ! !MicroSqueak class methodsFor: 'class and variable analysis' stamp: 'jm 11/17/2003 09:24'! classVarValues | result | result _ OrderedCollection new. MObject withAllSubclassesDo: [:c | result addAll: c classPool]. ^ result asArray select: [:o | o ~~ nil] "don't include nil values" ! ! !MicroSqueak class methodsFor: 'class and variable analysis' stamp: 'jm 12/2/2003 06:20'! unusedClasses "Answer a collection of usued MicroSqueak classes." | classes | classes _ MObject withAllSubclasses. "remove referenced classes" self allLiteralsAndClassVars do: [:v | ((v isKindOf: Association) and: [v key notNil]) ifTrue: [ classes remove: v value ifAbsent: []]]. "remove system classes" #(MClass MMetaclass MCompiledMethod MTrue MFalse MBlockContext MMethodContext MProcessorScheduler) do: [:n | classes remove: (Smalltalk at: n) ifAbsent: []]. "remove classes with subclasses" classes _ classes reject: [:c | c subclasses size > 0]. ^ classes! ! !MicroSqueak class methodsFor: 'file out' stamp: 'jm 12/4/2003 21:28'! fileOutClasses "File out the MicroSqueak class library. Does not include system building and support categories." "self fileOutClasses" | f | f _ FileStream newFileNamed: 'MicroSqueakClasses.st'. SystemOrganization fileOutCategoriesMatching: 'MSqueak-*' on: f. f close. ! ! !MicroSqueak class methodsFor: 'private' stamp: 'jm 11/2/2003 20:12'! codeSizeFor: methDict "Size of the given MethodDictionary and all its methods." | result | result _ 4 + 4 + (4 * methDict class instSize). "inst vars + object headers for dict and array" result _ result + (8 * (2 raisedTo: (methDict size highBit))). "indexable fields in dict and array" methDict do: [:m | result _ result + (self sizeOfMethod: m)]. ^ result ! ! !MicroSqueak class methodsFor: 'private' stamp: 'jm 11/3/2003 20:49'! methodsReachableFrom: initialList "MicroSqueak methodsReachableFrom: #(+)" "MicroSqueak methodsReachableFrom: #(clone)" "MicroSqueak methodsReachableFrom: #(printString)" | reachable count | reachable _ (self selectorsReachableFrom: initialList) asSet. count _ 0. MObject withAllSubclasses do: [:cl | cl methodDict keys asArray, cl class methodDict keys asArray do: [:sel | (reachable includes: sel) ifTrue: [count _ count + 1]]]. ^ count ! ! !MicroSqueak class methodsFor: 'private' stamp: 'jm 11/2/2003 20:04'! sizeOfMethod: meth "Answer the size of the given compiled method in bytes." | result | result _ 4 * 2. "object header and method header word" result _ result + (4 * meth literals size). result _ result + ((meth endPC - meth initialPC + 1) roundUpTo: 4). ^ result ! ! !MicroSqueak class methodsFor: 'private' stamp: 'jm 11/2/2003 20:33'! writeClassStatsFor: aClass indent: indent on: aStream "Write class stats onto the given stream for the given class and it's subclasses." | mCount mBytes subclassList | mCount _ aClass methodDict size + aClass class methodDict size. mBytes _ (self codeSizeFor: aClass methodDict) + (self codeSizeFor: aClass class methodDict). indent timesRepeat: [aStream tab]. aStream nextPutAll: aClass name; space. aStream nextPutAll: mCount printString, ' (', mBytes printString, ' bytes)'; cr. subclassList _ aClass subclasses asArray sort: [:c1 :c2 | c1 name < c2 name]. subclassList do: [:c | self writeClassStatsFor: c indent: indent + 1 on: aStream]. ! ! !MicroSqueakImageBuilder methodsFor: 'entry points' stamp: 'jm 11/30/2003 19:10'! buildImageNamed: fileName "MicroSqueakImageBuilder new buildImageNamed: 'JUNKMicroSqueak.image'" Smalltalk forgetDoIts. "a DoIt left in one of subclasses of MObject can be a problem!!" self checkLayoutOfVMClasses. self collectClasses. self fixGlobalReferences. self buildScheduler. specialObjectsArray _ self buildSpecialObjectsArray. self collectObjectsFrom: specialObjectsArray. self writeImageFileNamed: fileName. ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 12/31/2003 10:01'! buildCompactClassArray "Build and answer the compact classes array, an Array of size 31 containing pointers to compact classes. The MicroSqueak classes must have already been created and recorded in 'globals'; this method installs the compact class index into these new class objects." | ccNames c | ccNames _ #( CompiledMethod Symbol Array ByteArray LargePositiveInteger LargeNegativeInteger MethodDictionary Association Metaclass Character String Float BlockContext MethodContext Dictionary ). (ccNames indexOf: #BlockContext) = (Smalltalk compactClassesArray indexOf: BlockContext) ifFalse: [self error: 'The VM depends on BlockContext''s compact class index']. (ccNames indexOf: #MethodContext) = (Smalltalk compactClassesArray indexOf: MethodContext) ifFalse: [self error: 'The VM depends on MethodContext''s compact class index']. "fix the compact class index in the class format words" ccNames withIndexDo: [:cName :i | c _ globals at: cName ifAbsent: [nil]. c ifNotNil: [c setCompactClassIndex: i]]. ^ (ccNames collect: [:cName | globals at: cName ifAbsent: [nil]]), (Array new: (31 - ccNames size) withAll: nil). ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 11/30/2003 19:11'! buildScheduler "Create new MProcessScheduler and install it as global 'Processor'." | scheduler | scheduler _ (globals at: #ProcessorScheduler) basicNew initProcessLists. globals at: #Processor put: scheduler. scheduler installIdleProcess. scheduler installStartProcess. ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 12/31/2003 10:23'! buildSpecialObjectsArray "Build and answer the 'special objects' array, an array of all the objects needed by the Smalltalk virtual machine." | compactClasses specialObjects | compactClasses _ self buildCompactClassArray. specialObjects _ Array new: 48. specialObjects at: 1 put: nil. specialObjects at: 2 put: false. specialObjects at: 3 put: true. specialObjects at: 4 put: (globals associationAt: #Processor). specialObjects at: 5 put: nil. "Bitmap" specialObjects at: 6 put: (globals at: #SmallInteger). specialObjects at: 7 put: (globals at: #String). specialObjects at: 8 put: (globals at: #Array). specialObjects at: 9 put: globals. specialObjects at: 10 put: (globals at: #Float ifAbsent: [nil]). specialObjects at: 11 put: (globals at: #MethodContext). specialObjects at: 12 put: (globals at: #BlockContext). specialObjects at: 13 put: (globals at: #Association). "replacement for Point" specialObjects at: 14 put: (globals at: #LargePositiveInteger). specialObjects at: 15 put: nil. "Display" specialObjects at: 16 put: (globals at: #Message). specialObjects at: 17 put: (globals at: #CompiledMethod). specialObjects at: 18 put: nil. "low space Semaphore" specialObjects at: 19 put: nil. "(globals at: #Semaphore)" specialObjects at: 20 put: (globals at: #Character). specialObjects at: 21 put: #doesNotUnderstand:. specialObjects at: 22 put: #cannotReturn:. specialObjects at: 23 put: nil. "unused" "the 32 selectors that are compiled as special bytecodes, with the number of arguments of each" specialObjects at: 24 put: #( + 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0). specialObjects at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]). "table of Characters in ascii order" specialObjects at: 26 put: #mustBeBoolean. specialObjects at: 27 put: (globals at: #ByteArray). specialObjects at: 28 put: (globals at: #Process). specialObjects at: 29 put: compactClasses. "array of up to 31 classes whose instances can have compact headers" specialObjects at: 30 put: nil. "delay semaphore" specialObjects at: 31 put: nil. "user input semaphore" "Prototype instances that can be copied for fast initialization" specialObjects at: 32 put: ((globals includesKey: #Float) ifTrue: [Float new: 2] ifFalse: [LargePositiveInteger new: 4]). specialObjects at: 33 put: (LargePositiveInteger new: 4). specialObjects at: 34 put: (Association new). "replacement for Point new" specialObjects at: 35 put: #cannotInterpret:. "Note: This must be fixed once we start using context prototypes" specialObjects at: 36 put: ((globals at: #MethodContext) new: 56). "size is CompiledMethod fullFrameSize" specialObjects at: 37 put: nil. specialObjects at: 38 put: ((globals at: #BlockContext) new: 56). "size is CompiledMethod fullFrameSize" specialObjects at: 39 put: Array new. "array of objects referred to by C support code" specialObjects at: 40 put: nil. "was PseudoContext" specialObjects at: 41 put: nil. "was TranslatedMethod" specialObjects at: 42 put: nil. "finalization Semaphore" specialObjects at: 43 put: (globals at: #LargeNegativeInteger). "44-48 are are reserved for the foreign function interface (they are nil here)" ^ specialObjects ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 12/18/2003 08:18'! checkLayoutOfVMClasses "Verify that the layout of classes that the VM depends on is the same as the corresponding Squeak class." "MicroSqueakImageBuilder new checkLayoutOfVMClasses" | sClass mClass | #( Behavior MethodDictionary Association BlockContext MethodContext Array ByteArray String Character Symbol Dictionary LargePositiveInteger LargeNegativeInteger Float Point Process ProcessorScheduler Semaphore ) do: [:n | sClass _ Smalltalk at: n. mClass _ Smalltalk at: ('M', n) asSymbol ifAbsent: [nil]. mClass ifNotNil: [ (sClass instSpec = mClass instSpec) ifFalse: [self error: 'Bad VM class layout: ', n]]]. "compiled method is special" ((MCompiledMethod instSpec = 8) & (MCompiledMethod instSize = 0)) ifFalse: [self error: 'Bad VM class layout: CompiledMethod'].! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 12/1/2003 22:33'! classFromSqueak: squeakClass "Answer a new MicroSqueak class copied from the given Squeak class." | newMeta | newMeta _ MMetaclass new initMethodDict: (self methodDictFromSqueak: squeakClass class methodDict). newMeta soleInstance initFrom: squeakClass methodDict: (self methodDictFromSqueak: squeakClass methodDict). squeakClass == MCompiledMethod ifTrue: [ newMeta soleInstance setFormat: (CompiledMethod format bitAnd: 16r7FF)]. ^ newMeta soleInstance ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 11/26/2003 19:25'! collectClasses "Collect the entire class hierarchy for MicroSqueak, converting each Squeak class into a MicroSqueak MMetaClass object. Remove the leading 'M' from the class names and add all classes to the new globals dictionary." "MicroSqueakImageBuilder new collectClasses" | classMap inverseMap newClass oldSuper | globals _ Dictionary new. classMap _ IdentityDictionary new. inverseMap _ IdentityDictionary new. MObject withAllSubclasses do: [:oldClass | newClass _ self classFromSqueak: oldClass. globals at: newClass name put: newClass. classMap at: oldClass put: newClass. inverseMap at: newClass put: oldClass]. globals asArray do: [:newCl | 'Object' = newCl name ifTrue: [ newCl superclass: nil. newCl class superclass: (classMap at: MClass)] ifFalse: [ oldSuper _ (inverseMap at: newCl) superclass. newCl superclass: (classMap at: oldSuper). newCl class superclass: (classMap at: oldSuper) class]]. ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 12/14/2003 12:32'! fixGlobalReferences "Add a globals entry for Processor, then fix all Associations in CompileMethod literals that refer to Squeak globals (classes and Processor) to refer to my globals." | classes lit | globals at: #Processor put: nil. "filled in later" classes _ globals asArray select: [:o | o isNil not and: [o isBehavior]]. classes do: [:cl | cl methodDict asArray, cl class methodDict asArray do: [:m | 1 to: m numLiterals do: [:i | lit _ m objectAt: i + 1. "offset by 1 for the method header word" (lit isKindOf: Association) ifTrue: [ m objectAt: i + 1 put: (self mapGlobalAssociation: lit)]]]]. ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 11/30/2003 10:13'! mapGlobalAssociation: anAssociation "Answer either the given Association or a new Association to replace it." "Note: There may be some Associations that have 'nil' as a key. These are used for super sends in metaclasses. Fix the value parts of these associations." | k nonMetaName | #Processor = anAssociation key ifTrue: [^ globals associationAt: #Processor]. anAssociation value isBehavior ifFalse: [^ anAssociation]. anAssociation key ifNil: [ "association used in a 'super' call" nonMetaName _ anAssociation value soleInstance name. nonMetaName _ nonMetaName copyFrom: 2 to: nonMetaName size. "remove leading 'M'" ^ nil -> (globals at: nonMetaName asSymbol) class]. "new association for the new metatclass" anAssociation key ifNil: [k _ anAssociation value name. self halt: 'nil key, value: ', k] ifNotNil: [k _ (anAssociation key copyFrom: 2 to: anAssociation key size) asSymbol]. ^ globals associationAt: k ifAbsent: [self halt: 'Ref to a class not in globals: ', k. ^ (k -> nil)]. ! ! !MicroSqueakImageBuilder methodsFor: 'object creation' stamp: 'jm 11/27/2003 11:00'! methodDictFromSqueak: aMethodDictionary "Answer a new method dictionary created from the given Squeak method dictionary." "Note: The contents of the new MMethodDictionary are Squeak CompiledMethod objects. They will be converted into MicroSqueak CompiledMethods when the image file is built." | sz result meth | aMethodDictionary size = 0 ifTrue: [sz _ 1] ifFalse: [sz _ 2 raisedTo: (aMethodDictionary size log: 2) ceiling]. result _ (MethodDictionary basicNew: sz) init: sz. aMethodDictionary keys do: [:sel | meth _ (aMethodDictionary at: sel) copyWithTrailerBytes: #(). result at: sel put: meth]. ^ result ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/30/2003 22:19'! extraWordsIfContext: anObject "Answer the number of extra words to allocate for the given object if it is a BlockContext or MethodContext object. Answer zero if the object is not a context object." | className | className _ (self newClassFor: anObject) name. ((className = #BlockContext) or: [className = #MethodContext]) ifTrue: [^ 56 - anObject basicSize] ifFalse: [^ 0]. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/29/2003 21:11'! headerAndTotalWordsFor: anObject "Answer an array containing the number of header words (1-3) and the number of words needed to store the contents of the given object." | cl contentsWords headerWords | cl _ self newClassFor: anObject. contentsWords _ cl instSize + (self extraWordsIfContext: anObject). cl isVariable ifTrue: [ contentsWords _ contentsWords + (cl isBytes ifTrue: [(anObject basicSize + 3) // 4] ifFalse: [anObject basicSize])]. headerWords _ contentsWords > 63 ifTrue: [3] ifFalse: [(cl indexIfCompact > 0) ifTrue: [1] ifFalse: [2]]. ^ Array with: headerWords with: (headerWords + contentsWords) ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 12/2/2003 07:55'! newClassFor: anObject "Answer the object that will be the given object's class in the new image." | cl newClass | cl _ anObject class. ((cl = MMetaclass) | (cl = MProcessList) | (cl = MProcessorScheduler) | (cl = MProcess) | (cl = MMethodContext)) ifTrue: [newClass _ globals at: (cl name copyFrom: 2 to: cl name size) asSymbol ifAbsent: [nil]] ifFalse: [newClass _ globals at: cl name ifAbsent: [nil]]. newClass ifNil: [ "a metaclass; the new metaclass is the class of the new class with my sole instance's name" newClass _ (globals at: cl soleInstance name) class. self assert: [newClass == cl]]. ^ newClass ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/28/2003 10:06'! oopFor: anObject map: oopMap "Answer an object pointer or SmallInteger encoding for the given object or SmallInteger." ^ anObject isSmallInteger ifTrue: [(anObject bitShift: 1) + 1] ifFalse: [oopMap at: anObject]. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/28/2003 09:32'! padToNextWord: aStream "Append zero to three bytes of zeros to the given stream to make its position be an even multiple of four bytes." [(aStream position \\ 4) = 0] whileFalse: [aStream nextPut: 0]. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/28/2003 11:14'! sortedObjects "Answer a sorted list of objects to be stored in the image. Certain types of immutable objects (e.g., Booleans, Symbols, Characters, and CompiledMethods) are stored before other objects." | result characters symbols compiledMethods floats other isOther objClass | result _ OrderedCollection new: objects size + 3. result add: nil. objects remove: nil ifAbsent: []. result add: true. objects remove: true ifAbsent: []. result add: false. objects remove: false ifAbsent: []. characters _ OrderedCollection new: 256. symbols _ OrderedCollection new: 2000. compiledMethods _ OrderedCollection new: 2000. floats _ OrderedCollection new: 100. other _ OrderedCollection new: objects size. objects do: [:o | isOther _ true. objClass _ o class. Character = objClass ifTrue: [characters add: o. isOther _ false]. Symbol = objClass ifTrue: [symbols add: o. isOther _ false]. CompiledMethod = objClass ifTrue: [compiledMethods add: o. isOther _ false]. Float = objClass ifTrue: [floats add: o. isOther _ false]. isOther ifTrue: [other add: o]]. result addAll: characters; addAll: symbols; addAll: compiledMethods; addAll: floats; addAll: other. ^ result asArray ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/29/2003 20:41'! writeImageFileNamed: fileName | objList oopMap nextOop hdrAndTotalWords s | objList _ self sortedObjects. oopMap _ IdentityDictionary new: 5000. "pass 1: assign oops" nextOop _ 0. "nil is alway the first oop" objList do: [:o | hdrAndTotalWords _ self headerAndTotalWordsFor: o. oopMap at: o put: (nextOop + (4 * (hdrAndTotalWords first - 1))). "oop is addr of last header word" nextOop _ nextOop + (4 * hdrAndTotalWords second)]. "pass 2: write objects" s _ WriteStream on: (ByteArray new: 100000). objList do: [:o | self writeObject: o map: oopMap on: s]. s position = nextOop ifFalse: [self error: 'first and second passes yielded different image sizes']. specialObjectsOop _ self oopFor: specialObjectsArray map: oopMap. self writeMemoryImage: s contents toFileNamed: fileName. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 12/29/2003 19:21'! writeMemoryImage: aByteArray toFileNamed: fileName | f | f _ (FileStream newFileNamed: fileName) binary. "write squeak image file header (64 bytes)" f int32: 6502. "image format and version id" f int32: 64. "header size (bytes)" f int32: aByteArray size. "image size (bytes)" f int32: 0. "location of start of image in memory" f int32: specialObjectsOop. "oop of the special objects array" f int32: 999. "last identity hash value" f int32: ((256 << 16) + 128). "size of Display" f int32: 0. "flag indicating full-screen mode" 1 to: 8 do: [:i | f int32: 0]. "fill remaining 8 header words with zeros" "write the image data and close the file" f nextPutAll: aByteArray. f close. FileDirectory default setMacFileNamed: f name type: 'STim' creator: 'FAST'. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/29/2003 21:33'! writeObjHeaderFor: anObject map: oopMap on: aStream "Write the one to three word object header for the given object on the given stream." "Base header word format: gc (3 bits) (highest bits) identity hash (12 bits) compact class index (5 bits) format (4 bits) size in words, including the base header word (6 bits) object header type (2 bits) (lowest bits)" | cl baseHeader indexableWords extraBytes totalWords hdrTypeBits | cl _ self newClassFor: anObject. baseHeader _ ((anObject identityHash bitAnd: 16rFFF) << 17) bitOr: "hash bits" ((cl format << 1) bitAnd: 16r1FF00). "format bits and cc index" indexableWords _ 0. cl isVariable ifTrue: [ cl isBytes ifTrue: [ "two low bits of the format field are the # of bytes to subtract from rounded-up size" indexableWords _ (anObject basicSize + 3) // 4. extraBytes _ ((4 * indexableWords) - anObject basicSize) bitAnd: 3. baseHeader _ baseHeader bitOr: (extraBytes << 8)] ifFalse: [ indexableWords _ anObject basicSize]]. self assert: [(baseHeader bitAnd: 3) = 0]. totalWords _ cl instSize + indexableWords + (self extraWordsIfContext: anObject) + 1. totalWords > 63 ifTrue: [ "3-word header" hdrTypeBits _ 0. baseHeader _ baseHeader - (baseHeader bitAnd: 16rFF). "set size field to zero" aStream uint32: ((4 * totalWords) bitOr: hdrTypeBits). aStream uint32: ((oopMap at: cl) bitOr: hdrTypeBits). aStream uint32: (baseHeader bitOr: hdrTypeBits)] ifFalse: [ baseHeader _ baseHeader + (4 * totalWords). self assert: [(baseHeader bitAnd: 16rFF) = (4 * totalWords)]. cl indexIfCompact = 0 ifTrue: [ "2-word header" hdrTypeBits _ 1. aStream uint32: ((oopMap at: cl) bitOr: hdrTypeBits). aStream uint32: (baseHeader bitOr: hdrTypeBits)] ifFalse: [ "1-word header" hdrTypeBits _ 3. aStream uint32: (baseHeader bitOr: hdrTypeBits)]]. ! ! !MicroSqueakImageBuilder methodsFor: 'image creation' stamp: 'jm 11/29/2003 21:37'! writeObject: anObject map: oopMap on: aStream "Write the given object onto the given stream using the given dictionary to map object references to memory addresses." | objClass nilOop | objClass _ anObject class. self writeObjHeaderFor: anObject map: oopMap on: aStream. self assert: [((oopMap at: anObject) + 4) = aStream position]. "position is oop + base header size" "special case for CompiledMethod" objClass instSpec = CompiledMethod instSpec ifTrue: [ 1 to: anObject numLiterals + 1 do: [:i | "write literals" aStream int32: (self oopFor: (anObject objectAt: i) map: oopMap)]. anObject initialPC to: anObject size do: [:i | aStream nextPut: (anObject at: i)]. self padToNextWord: aStream. ^ self]. "write instance variables, if any" 1 to: objClass instSize do: [:i | aStream int32: (self oopFor: (anObject instVarAt: i) map: oopMap)]. objClass isVariable ifTrue: [ objClass isPointers ifTrue: [ "write pointer fields" 1 to: anObject basicSize do: [:i | aStream int32: (self oopFor: (anObject basicAt: i) map: oopMap)]] ifFalse: [ "write byte or word fields" objClass isBytes ifTrue: [ 1 to: anObject basicSize do: [:i | aStream nextPut: (anObject basicAt: i)]. self padToNextWord: aStream] ifFalse: [ 1 to: anObject basicSize do: [:i | aStream uint32: (anObject basicAt: i)]]]]. nilOop _ self oopFor: nil map: oopMap. (self extraWordsIfContext: anObject) timesRepeat: [aStream int32: nilOop]. "allocate stack space for contexts" ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/26/2003 21:26'! check: anObject "Ensure that the given object is either a SmallInteger or appears in the objects set." anObject isSmallInteger ifTrue: [^ self]. anObject ifNil: [^ self]. (objects includes: anObject) ifFalse: [self error: 'bad object ref:', anObject printString]. ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/26/2003 21:22'! checkRefsOf: anObject "Check that all pointers in the given object appear in the objects dictionary." | objClass | objClass _ anObject class. 1 to: objClass instSize do: [:i | "scan the instance variables" self check: (anObject instVarAt: i)]. (objClass isVariable and: [objClass isPointers]) ifTrue: [ 1 to: anObject basicSize do: [:i | "scan the indexed fields" self check: (anObject basicAt: i)]]. objClass == CompiledMethod ifTrue: [ "scan the CompiledMethod literals" anObject literals do: [:lit | self check: lit]]. ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/24/2003 07:30'! collectObjects "MicroSqueakImageBuilder new collectObjects" | toDo obj | objects _ IdentitySet new: 5000. toDo _ OrderedCollection new: 5000. self record: MObject in: toDo from: nil. [toDo isEmpty] whileFalse: [ obj _ toDo removeFirst. self scan: obj into: toDo]. ^ objects ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/24/2003 16:09'! collectObjectsFrom: root | toDo obj | objects _ IdentitySet new: 5000. toDo _ OrderedCollection new: 5000. self record: root in: toDo from: nil. [toDo isEmpty] whileFalse: [ obj _ toDo removeFirst. self trace: obj into: toDo]. ^ objects ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 10/27/2003 12:33'! record: obj in: toDo from: srcObj | objClass | (obj isNil or: [obj isSmallInteger]) ifTrue: [^ self]. obj isSmallInteger ifTrue: [^ self]. objClass _ obj class. (objects includes: obj) ifTrue: [^ self]. "already processed" obj == Smalltalk ifTrue: [^ self]. objClass == ClassOrganizer ifTrue: [^ self]. obj == Processor ifTrue: [^ self]. objClass == LinkedList ifTrue: [self halt. ^ self]. "did we encounter a process?" obj isBehavior ifTrue: [ ((obj == MObject) or: [(obj == MObject class) or: [(obj inheritsFrom: MObject) or: [obj inheritsFrom: MObject class]]]) ifFalse: [^ self]]. objects add: obj. toDo add: obj. ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 10/27/2003 11:31'! scan: anObject into: toDo | objClass | objClass _ anObject class. 1 to: objClass instSize do: [:i | "scan the instance variables" self record: (anObject instVarAt: i) in: toDo from: anObject]. (objClass isVariable and: [objClass isPointers]) ifTrue: [ 1 to: anObject basicSize do: [:i | "scan the indexed fields" self record: (anObject basicAt: i) in: toDo from: anObject]]. objClass == CompiledMethod ifTrue: [ anObject literals do: [:literal | "scan the CompiledMethod literals" self record: literal in: toDo from: anObject]]. self record: objClass in: toDo from: anObject. ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/24/2003 16:09'! trace: anObject into: toDo | objClass | objClass _ anObject class. 1 to: objClass instSize do: [:i | "scan the instance variables" self trace: (anObject instVarAt: i) into: toDo from: anObject]. (objClass isVariable and: [objClass isPointers]) ifTrue: [ 1 to: anObject basicSize do: [:i | "scan the indexed fields" self trace: (anObject basicAt: i) into: toDo from: anObject]]. objClass == CompiledMethod ifTrue: [ anObject literals do: [:literal | "scan the CompiledMethod literals" self trace: literal into: toDo from: anObject]]. self trace: objClass into: toDo from: anObject. ! ! !MicroSqueakImageBuilder methodsFor: 'object tracing' stamp: 'jm 11/28/2003 20:28'! trace: obj into: toDo from: srcObj "Add the given object to objects and to the toDo list except if it is: - nil - a SmallInteger - already in objects (i.e., it has already been processed) - a Squeak class object (i.e., an instance of MMetaclass) - the Squeak 'Processor' object" obj ifNil: [^ self]. obj isSmallInteger ifTrue: [^ self]. (objects includes: obj) ifTrue: [^ self]. "already processed" (obj isBehavior and: [obj inheritsFrom: Object]) ifTrue: [^ self]. "don't trace Squeak classes" obj == Processor ifTrue: [^ self halt]. "don't trace references to the Squeak global 'Processor'" objects add: obj. toDo add: obj. ! ! !MixedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:05'! duration "Answer the duration of this sound in seconds." | dur | dur _ 0. sounds do: [:snd | dur _ dur max: snd duration]. ^ dur ! ! !MixedSound methodsFor: 'accessing' stamp: 'jm 7/20/2003 22:21'! isEmpty ^ sounds size = 0 ! ! !MixedSound methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:23'! isStereo ^ true ! ! !MixedSound methodsFor: 'accessing' stamp: 'jm 8/23/2003 15:59'! setPan: leftRightPan volume: volume for: index "Set the pan left-right pan and volume for the sound with the given index, where 0.0 is full left, 1.0 is full right, and 0.5 is centered. Volume ranges from 0 to 1.0." | pan vol | (index < 1 or: [index > leftVols size]) ifTrue: [^ self]. pan _ ((leftRightPan * ScaleFactor) asInteger max: 0) min: ScaleFactor. vol _ ((volume * ScaleFactor) asInteger max: 0) min: ScaleFactor. leftVols at: index put: ((ScaleFactor - pan) * vol) // ScaleFactor. rightVols at: index put: (pan * vol) // ScaleFactor. ! ! !MixedSound methodsFor: 'sound generation' stamp: 'jm 1/10/1999 08:45'! stopGracefully "End this note with a graceful decay. If the note has envelopes, determine the decay time from its envelopes." super stopGracefully. sounds do: [:s | s stopGracefully]. ! ! I am a view for a Modal System Window. I vary from StandardSystemView, of which I am a subclass in a few ways: (1) I use ModalController as my default controller; (2) When asked to update with the symbol #close, I direct the controller to close; (3) I display a slightly different title bar with no control boxes.! !ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/18/2000 20:41'! borderWidth: anObject modalBorder _ false. ^super borderWidth: anObject! ! !ModalSystemWindowView methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 00:50'! initialize "Refer to the comment in View|initialize." super initialize. self borderWidth: 5. self noLabel. modalBorder _ true.! ! !ModalSystemWindowView methodsFor: 'modal dialog' stamp: 'acg 2/18/2000 23:47'! doModalDialog | savedArea | self resizeInitially. self resizeTo: ((self windowBox) align: self windowBox center with: Display boundingBox aboveCenter). savedArea _ Form fromDisplay: self windowBox. self display. self controller startUp. self release. savedArea displayOn: Display at: self windowOrigin. ! ! !ModalSystemWindowView methodsFor: 'controller access' stamp: 'acg 2/9/2000 00:58'! defaultControllerClass ^ModalController! ! !ModalSystemWindowView methodsFor: 'label access' stamp: 'acg 2/9/2000 08:35'! backgroundColor ^Color lightYellow! ! !ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/18/2000 20:24'! display super display. self displayLabelBackground: false. self displayLabelText. ! ! !ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/19/2000 00:59'! displayBorder "Display the receiver's border (using the receiver's borderColor)." modalBorder ifFalse: [^super displayBorder]. Display border: self displayBox widthRectangle: (1@1 corner: 2@2) rule: Form over fillColor: Color black. Display border: (self displayBox insetBy: (1@1 corner: 2@2)) widthRectangle: (4@4 corner: 3@3) rule: Form over fillColor: (Color r: 16rEA g: 16rEA b: 16rEA). ! ! !ModalSystemWindowView methodsFor: 'displaying' stamp: 'acg 2/9/2000 07:21'! displayLabelBoxes "Modal dialogs don't have closeBox or growBox." ! ! !ModalSystemWindowView methodsFor: 'model access' stamp: 'acg 2/9/2000 00:57'! update: aSymbol aSymbol = #close ifTrue: [^self controller close]. ^super update: aSymbol! ! Provides a superclass for classes that function as models. The only behavior provided is fast dependents maintentance, which bypasses the generic DependentsFields mechanism. 1/23/96 sw! !Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:26'! canDiscardEdits "Answer true if none of the views on this model has unaccepted edits that matter." dependents ifNil: [^ true]. ^ super canDiscardEdits ! ! !Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'! myDependents ^ dependents! ! !Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'! myDependents: aCollectionOrNil dependents _ aCollectionOrNil! ! !Model methodsFor: 'dependents' stamp: 'jm 10/19/2002 09:05'! topView "Find the first top view on me. Is there any danger of their being two with the same model? Any danger from ungarbage collected old views? Ask if schedulled?" dependents ifNil: [^ nil]. Smalltalk isMorphic ifTrue: [ dependents do: [:v | ((v isKindOf: SystemWindow) and: [v isInWorld]) ifTrue: [^ v]. ((v owner isKindOf: SystemWindow) and: [v owner isInWorld]) ifTrue: [^ v owner]]. ^ nil]. dependents do: [:v | v superView ifNil: [v model == self ifTrue: [^ v]]]. ^ nil ! ! !Month methodsFor: 'converting' stamp: 'LC 7/26/1998 12:49'! asDate ^ Date newDay: 1 month: self name year: self year! ! !Month methodsFor: 'converting' stamp: 'LC 7/26/1998 12:53'! next ^ self class fromDate: (self addDays: self duration)! ! !Month methodsFor: 'converting' stamp: 'LC 7/26/1998 02:43'! previous ^ self class fromDate: (self subtractDays: 1) ! ! !Month methodsFor: 'inquiries' stamp: 'LC 7/27/1998 04:38'! duration ^ self daysInMonth! ! !Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 02:53'! firstDate ^ self asDate! ! !Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:51'! index ^ self monthIndex! ! !Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:52'! lastDate ^ self firstDate addDays: self duration - 1! ! !Month methodsFor: 'inquiries' stamp: 'LC 7/26/1998 12:50'! name ^ self monthName! ! !Month methodsFor: 'enumerationg' stamp: 'LC 7/27/1998 04:36'! eachWeekDo: aBlock | week | week _ self firstDate week. [week firstDate <= self lastDate] whileTrue: [aBlock value: week. week _ week next]! ! !Month methodsFor: 'printing' stamp: 'LC 7/26/1998 02:24'! printOn: aStream aStream nextPutAll: self monthName, ' ', self year printString! ! !Month class methodsFor: 'instance creation' stamp: 'LC 7/26/1998 12:47'! fromDate: aDate ^ self newDay: 1 month: aDate monthName year: aDate year! ! !Month class methodsFor: 'instance creation' stamp: 'LC 7/26/1998 12:48'! readFrom: aStream | m y c | m _ (ReadWriteStream with: '') reset. [(c _ aStream next) isSeparator] whileFalse: [m nextPut: c]. [(c _ aStream next) isSeparator] whileTrue. y _ (ReadWriteStream with: '') reset. y nextPut: c. [aStream atEnd] whileFalse: [y nextPut: aStream next]. ^ self fromDate: (Date newDay: 1 month: m contents asSymbol year: y contents asNumber) " Month readFrom: (ReadWriteStream with: 'July 1998') reset "! ! A morph (from the Greek "shape" or "form") is an interactive graphical object. The 'bounds' of a morph is a rectangle that just encloses its visual representation on the screen. A morph's drawOn: method should not write pixels outside of the bounds rectangle. This rectangle is used both to keep track of screen areas that need to be repainted and as the first approximation for mouse-click hit detection. Simple morphs can be combined to create a compound morph. In such a structure, one morph forms the root of the hierarchy, each morph has a list of zero or morph submorphs, and each morph knows which morph has it as a submorph (i.e., its 'owner'). All coordinates are in global screen coordinates. (Except in the case of morphs within a TransformMorph, but TransformMorph's are being phased out.) Morphs have a set of flags (such as 'hidden') and an optional list of properties. ! !Morph methodsFor: 'initialization' stamp: 'jm 10/14/2002 08:40'! initialize bounds _ 0@0 corner: 50@40. owner _ nil. submorphs _ Array empty. fullBounds _ nil. color _ Color blue. flags _ 0. properties _ nil. ! ! !Morph methodsFor: 'initialization' stamp: 'jm 7/5/1998 12:40'! openInMVC MorphWorldView openWorldWith: self labelled: self defaultLabelForInspector. ! ! !Morph methodsFor: 'initialization' stamp: 'djp 10/24/1999 17:13'! openInWindowLabeled: aString inWorld: aWorld | window extent | window _ (SystemWindow labelled: aString) model: nil. window " guess at initial extent" bounds: (RealEstateAgent initialFrameFor: window initialExtent: self fullBounds extent); addMorph: self frame: (0@0 extent: 1@1); updatePaneColors. " calculate extent after adding in case any size related attributes were changed. Use fullBounds in order to trigger re-layout of layout morphs" extent _ self fullBounds extent + (window borderWidth@window labelHeight) + window borderWidth. window extent: extent. aWorld addMorph: window. window activate. aWorld startSteppingSubmorphsOf: window. ^window ! ! !Morph methodsFor: 'initialization' stamp: 'sma 4/30/2000 10:43'! openInWorld "Add this morph to the world. If in MVC, then provide a Morphic window for it." Smalltalk isMorphic ifTrue: [self openInWorld: self currentWorld] ifFalse: [self openInMVC]! ! !Morph methodsFor: 'initialization' stamp: 'bf 1/5/2000 19:57'! openInWorld: aWorld "Add this morph to the requested World." (aWorld viewBox origin ~= (0@0) and: [self position = (0@0)]) ifTrue: [self position: aWorld viewBox origin]. aWorld addMorph: self. aWorld startSteppingSubmorphsOf: self! ! !Morph methodsFor: 'classification' stamp: 'jm 10/14/2002 09:14'! isColorable "Answer true if my color can be changed using the color: message. Subclasses whose color cannot be changes this way (e.g., those based on a Form) should override this to return false." ^ true ! ! !Morph methodsFor: 'accessing' stamp: 'jm 8/11/2003 21:09'! balloonHelpTextFor: aSelector #( (chooseEmphasisOrAlignment 'Emphasis & alignment') (chooseFont 'Change font') (chooseStyle 'Change style') (dismiss 'Remove') (doDebug:with: 'Debug') (doDirection:with: 'Choose forward direction') (doDup:with: 'Duplicate') (doMenu:with: 'Menu') (doGrab:with: 'Pick up') (doRecolor:with: 'Change color') (editDrawing 'Repaint') (maybeDoDup:with: 'Duplicate') (mouseDownInDimissHandle:with: 'Delete') (mouseDownInCollapseHandle:with: 'Collapse morph') (mouseDownOnHelpHandle: 'Help') (prepareToTrackCenterOfRotation:with: 'Set center of rotation') (startDrag:with: 'Move') (startGrow:with: 'Change size') (trackCenterOfRotation:with: 'Set center of rotation') ) do: [:pair | aSelector = pair first ifTrue: [^ pair last]]. ^ aSelector asString "this is best we can do; gives some information at least" ! ! !Morph methodsFor: 'accessing' stamp: 'jm 10/13/2002 20:09'! balloonText "Answer balloon help text or nil, if no help is available." ^ self valueOfProperty: #balloonText ! ! !Morph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:25'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." ^ color isColor and: [color isTranslucentColor] ! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'! highlight "The receiver is being asked to appear in a highlighted state. Mostly used for textual morphs" self color: self highlightColor! ! !Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'! highlightColor | val | ^ (val _ self valueOfProperty: #highlightColor) ifNotNil: [val ifNil: [self error: 'nil highlightColor']] ifNil: [owner ifNil: [self color] ifNotNil: [owner highlightColor]]! ! !Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! highlightColor: aColor self setProperty: #highlightColor toValue: aColor! ! !Morph methodsFor: 'accessing' stamp: 'sw 3/6/1999 02:09'! regularColor | val | ^ (val _ self valueOfProperty: #regularColor) ifNotNil: [val ifNil: [self error: 'nil regularColor']] ifNil: [owner ifNil: [self color] ifNotNil: [owner regularColor]]! ! !Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! regularColor: aColor self setProperty: #regularColor toValue: aColor! ! !Morph methodsFor: 'accessing' stamp: 'sw 11/30/1998 12:44'! unHighlight self color: self regularColor! ! !Morph methodsFor: 'accessing' stamp: 'jm 10/14/2002 09:04'! unlockContents self submorphsDo: [:m | m isLocked: false]. ! ! !Morph methodsFor: 'access properties' stamp: 'jm 10/13/2002 21:06'! hasProperty: propName "Return true if my properties list includes a property with the given name." properties ifNil: [^ false]. ^ (properties propertyForName: propName asSymbol) notNil ! ! !Morph methodsFor: 'access properties' stamp: 'jm 10/13/2002 21:06'! removeProperty: propName "Remove the property with the given name from my properties list." properties ifNil: [^ self]. properties _ properties copyWithoutName: propName asSymbol. ! ! !Morph methodsFor: 'access properties' stamp: 'jm 10/13/2002 21:07'! setProperty: propName toValue: anObject | entry newEntry | anObject ifNil: [^ self removeProperty: propName]. properties ifNil: [ properties _ MorphProperty new name: propName value: anObject. ^ self]. entry _ properties propertyForName: propName asSymbol. entry ifNil: [ "create and add a new entry at start of properties list" newEntry _ MorphProperty new name: propName value: anObject. newEntry nextLink: properties. properties _ newEntry] ifNotNil: [ "update the existing entry" entry value: anObject]. ! ! !Morph methodsFor: 'access properties' stamp: 'jm 10/13/2002 20:49'! valueOfProperty: propName "Return the value of the property with the given name in my properties list, or nil if I have no property with that name." ^ self valueOfProperty: propName ifAbsent: [nil] ! ! !Morph methodsFor: 'access properties' stamp: 'jm 10/13/2002 21:07'! valueOfProperty: propName ifAbsent: aBlock "Return the value of the property with the given name in my properties list, or the value of the given block if I have no property with that name." | prop | properties ifNil: [^ aBlock value]. prop _ properties propertyForName: propName asSymbol. prop ifNil: [^ aBlock value] ifNotNil: [^ prop value]. ! ! !Morph methodsFor: 'copying' stamp: 'jm 10/13/2002 21:23'! copyRecordingIn: dict "Recursively copy this entire composite morph, recording the correspondence between old and new morphs in the given dictionary. This dictionary will be used to update intra-composite references in the copy. See updateReferencesUsing:. Note: This default implementation copies ONLY morphs in the submorph hierarchy. If a subclass stores morphs in instance variables that it wants to copy, then it should override this method to do so. The same goes for subclasses that contain other data that should be copied when the morph is duplicated." | new | new _ self copy. dict at: self put: new. submorphs size > 0 ifTrue: [ new privateSubmorphs: (submorphs collect: [:m | (m copyRecordingIn: dict) privateOwner: new])]. properties ifNotNil: [new privateProperties: properties copyAll]. ^ new ! ! !Morph methodsFor: 'copying' stamp: 'jm 10/13/2002 21:27'! copyWithoutSubmorphs ^ self clone privateOwner: nil; privateSubmorphs: Array empty; privateBounds: (bounds origin corner: bounds corner) "deep-copy bounds" ! ! !Morph methodsFor: 'copying' stamp: 'jm 10/7/2002 06:43'! deepCopy ^ self fullCopy ! ! !Morph methodsFor: 'copying' stamp: 'jm 10/13/2002 21:25'! fullCopy "Produce a copy of me with my entire tree of submorphs. Morphs mentioned more than once are all directed to a single new copy. Simple inst vars are not copied, so you must override to copy Arrays, Forms, editable text, etc." | dict new | dict _ IdentityDictionary new: 1000. new _ self copyRecordingIn: dict. new allMorphsDo: [:m | m updateReferencesUsing: dict]. ^ new! ! !Morph methodsFor: 'copying' stamp: 'jm 10/13/2002 21:01'! updateReferencesUsing: aDictionary "Update intra-morph references within a composite morph that has been copied. For example, if a button refers to morph X in the orginal composite then the copy of that button in the new composite should refer to the copy of X in new composite, not the original X. This default implementation updates the contents of any morph-bearing slot. It may be overridden to avoid this behavior if so desired." | old prop | Morph instSize + 1 to: self class instSize do: [:i | old _ self instVarAt: i. old isMorph ifTrue: [self instVarAt: i put: (aDictionary at: old ifAbsent: [old])]]. "map morph values in my properties list" prop _ properties. [prop == nil] whileFalse: [ old _ prop value. old isMorph ifTrue: [ prop value: (aDictionary at: old ifAbsent: [old])]. prop _ prop nextLink]. ! ! !Morph methodsFor: 'structure' stamp: 'LC 12/22/1998 12:41'! activeHand ^ (self world ifNil: [^ nil]) activeHand! ! !Morph methodsFor: 'structure' stamp: 'sw 12/29/1999 12:27'! hasInOwnerChain: aMorph "If aMorph is somewhere in the receiver's owner chain, respond true" self eachStepInOwnerChainDo: [:anOwner | anOwner == aMorph ifTrue: [^ true]]. ^ false! ! !Morph methodsFor: 'structure' stamp: 'sw 7/1/1998 18:02'! pasteUpMorph "Answer the closest containing morph that is a PasteUp morph" ^ self ownerThatIsA: PasteUpMorph! ! !Morph methodsFor: 'structure' stamp: 'di 6/7/1999 15:39'! primaryHand ^ self activeHand ifNil: [self world firstHand]! ! !Morph methodsFor: 'structure' stamp: 'di 8/4/1999 15:41'! rootAt: location "Just return myself, unless I am a WorldWindow. If so, then return the appropriate root in that world" ^ self! ! !Morph methodsFor: 'structure' stamp: 'di 6/7/1999 20:04'! world ^ owner == nil ifTrue: [nil] ifFalse: [owner world]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'jm 8/3/2003 14:07'! morphsAt: aPoint addTo: mList "Return a collection of all morphs in this morph structure that contain the given point, possibly including the receiver itself. Must do this recursively because of transforms. " (self fullBounds containsPoint: aPoint) ifFalse: [^ mList]. "quick elimination" submorphs size > 0 ifTrue: [ submorphs do: [:m | m morphsAt: aPoint addTo: mList]]. (self containsPoint: aPoint) ifTrue: [mList addLast: self]. ^ mList ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'ar 11/8/1999 00:08'! rootMorphsAt: aPoint "Return the list of root morphs containing the given point, excluding the receiver. ar 11/8/1999: Moved into morph for an incredibly ugly hack in 3D worlds" ^ self submorphs select: [:m | (m fullContainsPoint: aPoint) and: [m isLocked not]]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 12/22/1998 17:00'! submorphOfClass: aClass ^ self submorphs detect: [:p | p isKindOf: aClass] ifNone: [nil]! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'tk 12/15/1998 14:23'! abandon "Like delete, but we really intend not to use this morph again. Clean up a few things." self delete! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 4/2/1999 16:56'! addAllMorphs: aCollection after: anotherMorph | index | index _ submorphs indexOf: anotherMorph ifAbsent: [submorphs size]. aCollection do: [:m | m owner ifNotNil: [m owner privateRemoveMorph: m]. m layoutChanged. m privateOwner: self]. submorphs _ (submorphs copyFrom: 1 to: index), aCollection, (submorphs copyFrom: index+1 to: submorphs size). self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 5/29/1998 15:39'! addMorphFront: aMorph | newSubmorphs | aMorph owner ifNotNil: [aMorph owner privateRemoveMorph: aMorph]. aMorph layoutChanged. aMorph privateOwner: self. newSubmorphs _ submorphs species new: submorphs size + 1. newSubmorphs at: 1 put: aMorph. newSubmorphs replaceFrom: 2 to: newSubmorphs size with: submorphs startingAt: 1. submorphs _ newSubmorphs. aMorph changed. self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 11/15/1998 23:42'! addMorphFront: aMorph fromWorldPosition: wp self addMorphFront: aMorph. aMorph position: (self transformFromWorld globalPointToLocal: wp)! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 10/15/2002 17:20'! comeToFront | myOwner | myOwner _ self owner. (myOwner == nil or: [myOwner hasSubmorphs not]) ifTrue: [^ self]. myOwner firstSubmorph == self ifFalse: [myOwner addMorphFront: self]. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 10/3/2002 19:23'! delete "Remove the receiver as a submorph of its owner and make its new owner be nil." owner ifNotNil: [ owner privateRemoveMorph: self. owner _ nil]. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 10/11/2002 07:23'! goBehind owner addMorphBack: self. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'jm 10/13/2002 17:37'! removeAllMorphs self changed. submorphs do: [:m | m privateOwner: nil]. submorphs _ Array empty. self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'RAA 10/6/1999 12:23'! removeAllMorphsIn: aCollection "greatly speeds up the removal of *lots* of submorphs" | set | self changed. aCollection do: [:m | m privateOwner: nil]. set _ IdentitySet new: aCollection size * 4 // 3. aCollection do: [:each | set add: each]. submorphs _ submorphs reject: [ :each | set includes: each]. self layoutChanged. ! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'sw 10/25/1999 23:34'! replaceSubmorph: oldMorph by: newMorph | index itsPosition w | oldMorph stopStepping. itsPosition _ oldMorph referencePositionInWorld. index _ submorphs indexOf: oldMorph. oldMorph privateDelete. self privateAddMorph: newMorph atIndex: index. newMorph referencePositionInWorld: itsPosition. (w _ newMorph world) ifNotNil: [w startSteppingSubmorphsOf: newMorph]! ! !Morph methodsFor: 'drawing' stamp: 'di 6/24/1998 14:10'! areasRemainingToFill: aRectangle "May be overridden by any subclasses with opaque regions" ^ Array with: aRectangle! ! !Morph methodsFor: 'drawing' stamp: 'jm 10/13/2002 18:24'! basicFullDrawOn: aCanvas "Draw the full Morphic structure on the given Canvas. This duplicates the implementation of fullDrawOn: (which could invoke this if it cared) but this method is never overridden, so that it can be invoked by subclass implementations of #fullDrawOn: without getting snagged by the complexities of intervening implementations of #fullDrawOn:" self isHidden ifTrue: [^ self]. (self hasProperty: #errorOnDraw) ifTrue: [^ self drawErrorOn: aCanvas]. aCanvas drawMorph: self. self drawSubmorphsOn: aCanvas ! ! !Morph methodsFor: 'drawing' stamp: 'ar 4/2/1999 13:13'! drawErrorOn: aCanvas "The morph (or one of its submorphs) had an error in its drawing method." aCanvas frameAndFillRectangle: bounds fillColor: Color red borderWidth: 1 borderColor: Color yellow. aCanvas line: bounds topLeft to: bounds bottomRight width: 1 color: Color yellow. aCanvas line: bounds topRight to: bounds bottomLeft width: 1 color: Color yellow.! ! !Morph methodsFor: 'drawing' stamp: 'jm 11/24/2002 10:35'! drawOn: aCanvas aCanvas fillRectangle: self bounds color: color. ! ! !Morph methodsFor: 'drawing' stamp: 'ar 5/29/1999 05:23'! drawSubmorphsOn: aCanvas "Display submorphs back to front" submorphs reverseDo:[:m | aCanvas fullDrawMorph: m]. ! ! !Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 10:23'! flash | c w | c _ self color. self color: Color black. (w _ self world) ifNotNil: [w displayWorldSafely]. self color: c ! ! !Morph methodsFor: 'drawing' stamp: 'jm 10/13/2002 18:18'! fullBounds fullBounds ifNil: [ fullBounds _ self bounds. submorphs size > 0 ifTrue: [ submorphs do: [:m | m isHidden ifFalse: [ fullBounds _ fullBounds quickMerge: m fullBounds]]]]. ^ fullBounds ! ! !Morph methodsFor: 'drawing' stamp: 'jm 10/13/2002 19:07'! fullDrawOn: aCanvas "Draw my full Morphic structure on the given Canvas" self isHidden ifTrue: [^ self]. (self hasProperty: #errorOnDraw) ifTrue:[^ self drawErrorOn: aCanvas]. aCanvas drawMorph: self. self drawSubmorphsOn:aCanvas. ! ! !Morph methodsFor: 'drawing' stamp: 'jm 7/4/2003 10:34'! imageForm ^ self imageForm: Display depth forRectangle: self fullBounds ! ! !Morph methodsFor: 'drawing' stamp: 'jm 11/29/2002 10:12'! imageForm: depth forRectangle: rect | canvas | canvas _ FormCanvas extent: rect extent depth: depth. canvas translateBy: rect topLeft negated during: [:c | self fullDrawOn: c]. ^ canvas form offset: 0@0 ! ! !Morph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:25'! refreshWorld | aWorld | (aWorld _ self world) ifNotNil: [aWorld displayWorldSafely] ! ! !Morph methodsFor: 'drawing' stamp: 'jm 11/24/2002 10:49'! shadowForm "Return a form representing the 'shadow' of the receiver - e.g., all pixels that are occupied by the receiver are one, all others are zero." | canvas | canvas _ (FormCanvas extent: bounds extent depth: 1) asShadowDrawingCanvas: Color black. "Color black represents one for 1bpp" canvas translateBy: bounds topLeft negated during: [:tempCanvas| self fullDrawOn: tempCanvas]. ^ canvas form offset: bounds topLeft ! ! !Morph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:44'! boundsInWorld owner ifNil: [^ bounds]. ^ (owner transformFrom: self world) localBoundsToGlobal: bounds. ! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'! center: aPoint self position: (aPoint - (self extent // 2))! ! !Morph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:44'! fullBoundsInWorld owner ifNil: [^ self fullBounds]. ^ (owner transformFrom: self world) localBoundsToGlobal: self fullBounds. ! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/4/2000 21:59'! minimumExtent | ext | "This returns the minimum extent that the morph may be shrunk to. Not honored in too many places yet, but respected by the resizeToFit feature, at least. copied up from SystemWindow 6/00" (ext _ self valueOfProperty: #minimumExtent) ifNotNil: [^ ext]. ^ 100 @ 80! ! !Morph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:42'! pointFromWorld: aPoint owner ifNil: [^ aPoint]. ^ (owner transformFrom: self world) globalPointToLocal: aPoint. ! ! !Morph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:43'! pointInWorld: aPoint owner ifNil: [^ aPoint]. ^ (owner transformFrom: self world) localPointToGlobal: aPoint. ! ! !Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'! positionInWorld ^ self pointInWorld: self position. ! ! !Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'! positionSubmorphs self submorphsDo: [:aMorph | aMorph snapToEdgeIfAppropriate]! ! !Morph methodsFor: 'geometry' stamp: 'jm 10/15/2002 17:20'! setConstrainedPositionFrom: aPoint "Change the position of this morph and and all of its submorphs to aPoint, but don't let me go outside my owner's bounds." | trialRect delta boundingMorph | trialRect _ aPoint extent: self bounds extent. boundingMorph _ self owner. delta _ boundingMorph ifNil: [0@0] ifNotNil: [trialRect amountToTranslateWithin: boundingMorph bounds]. self position: aPoint + delta. self layoutChanged "So that, eg, surrounding text will readjust" ! ! !Morph methodsFor: 'geometry' stamp: 'sw 4/27/2000 13:53'! worldBoundsForHalo "To restore older behavior, change this to return self fullBoundsInWorld" ^ self boundsInWorld ! ! !Morph methodsFor: 'geometry-rotate scale and flex' stamp: 'jm 10/13/2002 19:15'! addTransparentSpacerOfSize: aPoint self addMorphBack: ((Morph new extent: aPoint) color: Color transparent) ! ! !Morph methodsFor: 'geometry-rotate scale and flex' stamp: 'sw 10/25/1999 16:49'! referencePositionInWorld ^ self pointInWorld: self referencePosition ! ! !Morph methodsFor: 'geometry-rotate scale and flex' stamp: 'sw 10/25/1999 23:33'! referencePositionInWorld: aPoint | localPosition | localPosition _ owner ifNil: [aPoint] ifNotNil: [(owner transformFrom: self world) globalPointToLocal: aPoint]. self referencePosition: localPosition ! ! !Morph methodsFor: 'geometry-testing' stamp: 'di 5/3/2000 19:05'! fullContainsPoint: aPoint (self fullBounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination" (self containsPoint: aPoint) ifTrue: [^ true]. "quick acceptance" submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]]. ^ false ! ! !Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'! permitsThumbnailing ^ true! ! !Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:34'! representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight "Return a morph representing the receiver but which is no taller than aHeight. If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth" self permitsThumbnailing ifFalse: [^ self]. (self height <= maxHeight and: [self width <= maxWidth]) ifTrue: [^ self]. ^ MorphThumbnail new extent: maxWidth @ (thumbnailHeight min: self height); morphRepresented: self! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'jm 3/16/2003 11:03'! aboutToBeGrabbedBy: aHand "The receiver is being grabbed by a hand. Perform necessary adjustments (if any) and return the morph that should be added to the hand. This default implementation just returns the reciver." ^ self ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:51'! allowSubmorphExtraction "Return true if this morph allows its submorphs to be extracted just by grabbing them. This default implementation returns false." ^self dragNDropEnabled or: [self dragEnabled]! ! !Morph methodsFor: 'dropping/grabbing'! asDraggableMorph ^self! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! dragEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^(self valueOfProperty: #dragEnabled) == true ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:48'! dragNDropEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^(self valueOfProperty: #dragNDropEnabled) == true ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! dropEnabled "Get this morph's ability to add and remove morphs via drag-n-drop." ^(self valueOfProperty: #dropEnabled) == true ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! enableDrag: aBoolean self setProperty: #dragEnabled toValue: aBoolean! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:54'! enableDragNDrop: aBoolean self enableDrag: aBoolean. self enableDrop: aBoolean. self setProperty: #dragNDropEnabled toValue: aBoolean! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! enableDrop: aBoolean self setProperty: #dropEnabled toValue: aBoolean! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 10/11/1999 13:20'! justDroppedInto: aMorph event: anEvent "This message is sent to a dropped morph after it has been dropped on--and been accepted by--a drop-sensitive morph" | aWindow partsBinCase | (partsBinCase _ aMorph isPartsBin) ifFalse: [self isPartsDonor: false]. (aWindow _ aMorph ownerThatIsA: SystemWindow) ifNotNil: [aWindow isActive ifFalse: [aWindow activate]]. (self isInWorld and: [partsBinCase not]) ifTrue: [self world startSteppingSubmorphsOf: self] "Note an unhappy inefficiency here: the startStepping... call will often have already been called in the sequence leading up to entry to this method, but unfortunately the isPartsDonor: call often will not have already happened, with the result that the startStepping... call will not have resulted in the startage of the steppage." ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'! repelsMorph: aMorph event: ev ^ false! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 6/30/1998 17:02'! rootForGrabOf: aMorph ^ (self isSticky and: [self isPartsDonor not]) ifTrue: [nil] ifFalse: [(owner = nil or: [owner isWorldOrHandMorph]) ifTrue: [self] ifFalse: [owner allowSubmorphExtraction ifTrue: [self] ifFalse: [owner rootForGrabOf: aMorph]]]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'jm 8/3/2003 10:06'! slideBackToFormerSituation: evt | slideForm formerOwner formerPosition aWorld startPoint endPoint trans | (formerOwner _ evt hand formerOwner) ifNil: [^ self]. formerPosition _ evt hand formerPosition. aWorld _ self world. trans _ formerOwner transformFromWorld. slideForm _ self imageForm offset: 0@0. startPoint _ evt hand fullBounds origin. endPoint _ trans localPointToGlobal: formerPosition. owner privateRemoveMorph: self. aWorld displayWorld. slideForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15. formerOwner addMorph: self. self position: formerPosition. self justDroppedInto: formerOwner event: evt. ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:46'! toggleDragNDrop "Toggle this morph's ability to add and remove morphs via drag-n-drop." self enableDragNDrop: self dragNDropEnabled not. ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'jm 10/11/2002 16:55'! vanishAfterSlidingTo: aPosition event: evt | aForm aWorld startPoint endPoint | aForm _ self imageForm offset: 0@0. aWorld _ self world. startPoint _ evt hand fullBounds origin. self delete. aWorld displayWorld. endPoint _ aPosition. aForm slideFrom: startPoint to: endPoint nSteps: 12 delay: 15. ! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:51'! wantsDroppedMorph: aMorph event: evt "Return true if the receiver wishes to accept the given morph, which is being dropped by a hand in response to the given event. The default implementation returns false. NOTE: the event is assumed to be in global (world) coordinates." ^self dragNDropEnabled or: [self dropEnabled]! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'sw 5/9/2000 02:56'! willingToBeEmbeddedUponLanding "Answer whether the receiver, when dropped over a container that is open to drag-and-drop, is eager to be embedded in the it. SystemWindows and MenuMorphs are examples of morphs that are reluctant in this regard." ^ true! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:21'! click: evt "Handle a single-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'sw 3/8/1999 00:17'! cursorPoint ^ self currentHand lastEvent cursorPoint! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:22'! doubleClick: evt "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:24'! handlesMouseDown: evt "Return true if this morph wants to receive mouseDown events (i.e., mouseDown:, mouseMove:, mouseUp:). The default response is false; subclasses that implement mouse messages should override this to return true." ^ false ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:32'! handlesMouseOver: evt "Return true if I want to receive mouseEnter: and mouseLeave: when the button is up and the hand is empty. The default response is false; subclasses that implement mouse mouseEnter messages should override this to return true." ^ false ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:31'! handlesMouseOverDragging: evt "Return true if I want to receive mouseEnterDragging: and mouseLeaveDragging: when the hand drags something over me (button up or button down), or when the mouse button is down but there is no mouseDown recipient. The default response is false; subclasses that implement mouse mouseEnterDragging messages should override this to return true." "NOTE: If the hand state matters in these cases, it may be tested by constructs such as event anyButtonPressed event hand hasSubmorphs" ^ false ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:25'! keyStroke: anEvent "Handle a keystroke event. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 11/1/2002 10:45'! keyboardFocusChange: aBoolean "The message is sent to a morph when its keyboard focus change. The argument is true if the receiver is gaining (versus losing) the keyboard focus. Morphs that accept keystrokes should change their appearance in some way when they are the current keyboard focus. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:25'! mouseDown: evt "Handle a mouse down event. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:26'! mouseEnter: evt "Handle a mouseEnter event. The mouse just entered my bounds with no button pressed. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:26'! mouseEnterDragging: evt "Handle a mouseEnterDragging event. The mouse just entered my bounds with a button pressed or laden with submorphs. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:27'! mouseLeave: evt "Handle a mouseLeave event. The mouse just left my bounds with no button pressed. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:27'! mouseLeaveDragging: evt "Handle a mouseLeaveLaden event. The mouse just left my bounds with a button pressed or laden with submorphs. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:28'! mouseMove: evt "Handle a mouse move event as part of the sequence mouseDown, mouseMove(s), mouseUp. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:29'! mouseUp: evt "Handle a mouse up event. This default implementation does nothing." ! ! !Morph methodsFor: 'event handling' stamp: 'jm 8/24/2003 10:44'! startDrag: evt "Handle a double-click event. This message is only sent to clients that request it by sending #waitForClicksOrDrag:event: to the initiating hand in their mouseDown: method. This default implementation grabs me." | frontM rootForGrab | frontM _ (self unlockedMorphsAt: evt cursorPoint) first. rootForGrab _ frontM rootForGrabOf: frontM. rootForGrab ifNil: [^ self]. rootForGrab position: rootForGrab position + (evt hand position - evt cursorPoint). evt hand grabMorph: rootForGrab. ! ! !Morph methodsFor: 'naming' stamp: 'jm 10/13/2002 20:07'! externalName ^ self valueOfProperty: #externalName ifAbsent: [self innocuousName] ! ! !Morph methodsFor: 'naming' stamp: 'jm 10/7/2002 07:22'! innocuousName "Choose an innocuous name for the receiver -- one that does not end in the word Morph" | myName | myName _ self class name asString copy. (myName size > 5 and: [myName endsWith: 'Morph']) ifTrue: [^ myName copyFrom: 1 to: myName size - 5] ifFalse: [^ myName]. ! ! !Morph methodsFor: 'naming' stamp: 'jm 10/13/2002 20:54'! setNameTo: aName self setProperty: #externalName toValue: aName asString. ! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:27'! arrangeToStartStepping "Arrange to start getting sent the 'step' message, but don't do that initial #step call that startStepping does" self arrangeToStartSteppingIn: self world! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 3/22/2000 14:26'! arrangeToStartSteppingIn: aWorld "Start getting sent the 'step' message in aWorld. Like startSteppingIn:, but without the initial one to get started'" aWorld ifNotNil: [aWorld startStepping: self. self changed]! ! !Morph methodsFor: 'stepping and presenter' stamp: 'jm 10/7/2002 07:39'! step "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. This default implementation does nothing." ! ! !Morph methodsFor: 'stepping and presenter' stamp: 'sw 10/20/1999 15:20'! stepAt: millisecondClockValue "Do some periodic activity. Use startStepping/stopStepping to start and stop getting sent this message. The time between steps is specified by this morph's answer to the stepTime message. The millisecondClockValue parameter gives the value of the millisecond clock at the moment of dispatch. Default is to dispatch to the parameterless step method for the morph, but this protocol makes it possible for some morphs to do differing things depending on the clock value" self step ! ! !Morph methodsFor: 'stepping and presenter' stamp: 'jm 10/7/2002 07:40'! stepTime "Answer the desired time between steps in milliseconds. This default implementation requests that the 'step' method be called once every second." ^1000 ! ! !Morph methodsFor: 'stepping and presenter' stamp: 'jm 10/7/2002 07:40'! wantsSteps "Return true if the receiver overrides the default Morph step method." "Details: Find the first class in superclass chain that implements #step and return true if it isn't class Morph." | c | self isPartsDonor ifTrue: [^ false]. c _ self class. [c includesSelector: #step] whileFalse: [c _ c superclass]. ^ c ~= Morph ! ! !Morph methodsFor: 'menus' stamp: 'jm 3/20/2003 21:39'! addAddHandMenuItemsForHalo: aMenu hand: aHandMorph "Add halo menu items to be handled by the invoking hand. The halo menu is invoked by clicking on the menu-handle of the receiver's halo." aMenu addLine. self owner isWorldMorph ifTrue: [aMenu add: #collapse target: self action: #collapse]. aMenu add: 'copy to paste buffer' action: #copyToPasteBuffer. aMenu add: 'change color...' target: self action: #changeColor. aMenu addLine. aHandMorph potentialEmbeddingTargets size > 1 ifTrue: [aMenu add: 'embed...' action: #placeArgumentIn]. aMenu defaultTarget: self. (owner == nil) ifFalse: [ aMenu add: 'send to back' action: #goBehind. aMenu add: 'bring to front' action: #comeToFront]. aMenu addLine. aMenu defaultTarget: aHandMorph. ! ! !Morph methodsFor: 'menus' stamp: 'jm 3/20/2003 21:35'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add morph-specific items to the given menu which was invoked by the given hand." Preferences noviceMode ifFalse: [self addDebuggingItemsTo: aCustomMenu hand: aHandMorph]. ! ! !Morph methodsFor: 'menus' stamp: 'sw 6/19/1999 23:15'! addTitleForHaloMenu: aMenu aMenu addTitle: self externalName! ! !Morph methodsFor: 'menus' stamp: 'sw 2/7/2000 10:57'! adhereToEdge: edgeSymbol (owner == nil or: [owner isHandMorph]) ifTrue: [^ self]. self perform: (edgeSymbol, ':') asSymbol withArguments: (Array with: (owner perform: edgeSymbol))! ! !Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:14'! adjustedCenter "Provides a hook for objects to provide a reference point other than the receiver's center,for the purpose of centering a submorph under special circumstances, such as BalloonMorph" ^ self center! ! !Morph methodsFor: 'menus' stamp: 'sw 2/3/2000 00:12'! adjustedCenter: c "Set the receiver's position based on the #adjustedCenter protocol for adhereToEdge. By default this simply sets the receiver's center. Though there are (at its inception anyway) no other implementors of this method, it is required in use with the #adhereToEdge when the centering of a submorph is to be with reference to a rectangle other than the receiver's center." self center: c! ! !Morph methodsFor: 'menus' stamp: 'di 9/3/1999 10:17'! changeColor ColorPickerMorph new sourceHand: self activeHand; target: self; selector: #color:; originalColor: self color; addToWorld: self world near: self fullBounds! ! !Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'! collapse CollapsedMorph new beReplacementFor: self! ! !Morph methodsFor: 'menus' stamp: 'sw 2/16/1999 14:32'! inspectInMorphic self currentHand attachMorph: ((Inspector openAsMorphOn: self) extent: 300@200)! ! !Morph methodsFor: 'menus' stamp: 'sw 6/17/1998 14:25'! setToAdhereToEdge: anEdge anEdge ifNil: [^ self]. anEdge == #none ifTrue: [^ self removeProperty: #edgeToAdhereTo]. self setProperty: #edgeToAdhereTo toValue: anEdge. self layoutChanged! ! !Morph methodsFor: 'menus' stamp: 'sw 8/30/1998 09:42'! snapToEdgeIfAppropriate | edgeSymbol oldBounds aWorld | (edgeSymbol _ self valueOfProperty: #edgeToAdhereTo) ifNotNil: [oldBounds _ bounds. self adhereToEdge: edgeSymbol. bounds ~= oldBounds ifTrue: [(aWorld _ self world) ifNotNil: [aWorld viewBox ifNotNil: [aWorld displayWorld]]]]! ! !Morph methodsFor: 'menus' stamp: 'sw 9/27/1999 09:37'! stickinessString ^ self isSticky ifTrue: ['stop being sticky'] ifFalse: ['start being sticky'] ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 9/30/2003 00:13'! addHalo: evt | halo | halo _ HaloMorph new bounds: self worldBoundsForHalo. self world addMorphFront: halo. halo target: self. halo startStepping. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 10/11/2002 15:54'! addHandlesTo: aHaloMorph box: box aHaloMorph haloBox: box. Preferences haloSpecifications do: [:aSpec | aHaloMorph perform: aSpec addHandleSelector with: aSpec]. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 14:11'! balloonColor ^ Display depth <= 2 ifTrue: [Color white] ifFalse: [Color r: 1.0 g: 1.0 b: 0.6]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:27'! balloonHelpAligner "Answer the morph to which the receiver's balloon help should point" ^ (self valueOfProperty: #balloonTarget) ifNil: [self]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/3/2000 15:20'! classForHalo "Answer the name of the desired kind of HaloMorph to launch on behalf of the receiver" ^ #HaloMorph ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 9/30/2003 00:18'! comeToFrontAndAddHalo self comeToFront. self addHalo: nil. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/11/2000 18:24'! defersHaloOnClickTo: aSubMorph "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" "May want to add a way (via a property) for morphs to assert true here -- this would let certain kinds of morphs that are unusually reluctant to take the halo on initial click" ^ false ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/28/1999 12:06'! halo self currentWorld haloMorphs do: [:h | h target == self ifTrue: [^ h]]. ^ nil! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 10/8/2002 08:53'! mouseDownOnHelpHandle: anEvent "The mouse went down in the show-balloon handle" | str | str _ self balloonText. str ifNil: [str _ self noHelpString]. self showBalloon: str ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 12/30/1999 19:51'! seeksOutHalo "Answer whether the receiver is an eager recipient of the halo" ^ true! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 10/13/2002 20:13'! setBalloonText: stringOrText "Set receiver's balloon help text. Pass nil to remove the help." | wrapped | stringOrText ifNil: [self removeProperty: #balloonText] ifNotNil: [ wrapped _ stringOrText withNoLineLongerThan: Preferences maxBalloonHelpLineLength. self setProperty: #balloonText toValue: wrapped]. ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 2/7/2000 11:28'! showBalloon: msgString "Pop up a balloon containing the given string, first removing any existing BalloonMorphs in the world." | w balloon worldBounds | (w _ self world) ifNil: [^ self]. w submorphsDo: [:m | (m isKindOf: BalloonMorph) ifTrue: [m delete]]. balloon _ BalloonMorph string: msgString for: self balloonHelpAligner. balloon lock. w addMorphFront: balloon. "So that if the translation below makes it overlap the receiver, it won't interfere with the rootMorphsAt: logic and hence cause flashing. Without this, flashing happens, believe me!!" ((worldBounds _ w bounds) containsRect: balloon bounds) ifFalse: [balloon bounds: (balloon bounds translatedToBeWithin: worldBounds)]. self setProperty: #balloon toValue: balloon! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 12/23/1999 13:24'! wantsBalloon "Answer true if receiver wants to show a balloon help text is a few moments." ^ self balloonText notNil! ! !Morph methodsFor: 'halos and balloon help' stamp: 'jm 10/15/2002 17:21'! wantsHalo ^ self owner ~~ nil and: [self owner wantsHaloFor: self] ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'! wantsHaloFromClick ^ true! ! !Morph methodsFor: 'change reporting' stamp: 'jm 10/13/2002 20:51'! invalidRect: damageRect owner ifNotNil: [owner invalidRect: damageRect]. ! ! !Morph methodsFor: 'change reporting' stamp: 'di 11/16/97 15:15'! layoutChanged "Note that something has changed about the size, shape, or location of the receiver or one of its submorphs, so that fullBounds must be recomputed." fullBounds _ nil. owner ifNotNil: [owner layoutChanged]. submorphs size > 0 ifTrue: ["Let submorphs know about a change above" submorphs do: [:m | m ownerChanged]]. ! ! !Morph methodsFor: 'change reporting' stamp: 'jm 7/24/2003 18:06'! mayNeedLayout "Answer true if something has occured that might require my layout to change That is, if layoutChanged has been sent to me or any of my submorphs." ^ fullBounds isNil ! ! !Morph methodsFor: 'change reporting' stamp: 'sw 7/8/1998 13:21'! ownerChanged "The receiver's owner, some kind of a pasteup, has changed its layout." self snapToEdgeIfAppropriate! ! !Morph methodsFor: 'e-toy support' stamp: 'jm 10/13/2002 11:22'! adaptToWorld: aWorld "The receiver finds itself operating in a possibly-different new world. If any of the receiver's parts are world-dependent (such as a target of a SimpleButtonMorph, etc.), then have them adapt accordingly" submorphs do: [:m | m adaptToWorld: aWorld]. ! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 5/23/2000 03:42'! containingWindow ^ self ownerThatIsA: SystemWindow! ! !Morph methodsFor: 'e-toy support' stamp: 'jm 10/15/2002 17:15'! definePath | points lastPoint aForm offset currentPoint dwell ownerPosition | points _ OrderedCollection new: 70. lastPoint _ nil. aForm _ self imageForm. offset _ aForm extent // 2. ownerPosition _ owner position. Cursor move show. Sensor waitButton. [Sensor anyButtonPressed and: [points size < 100]] whileTrue: [currentPoint _ Sensor cursorPoint. dwell _ 0. currentPoint = lastPoint ifTrue: [dwell _ dwell + 1. ((dwell \\ 1000) = 0) ifTrue: [self beep]] ifFalse: [self position: (currentPoint - offset). self world displayWorld. (Delay forMilliseconds: 20) wait. points add: currentPoint. lastPoint _ currentPoint]]. points size > 1 ifFalse: [self inform: 'no path obtained'] ifTrue: [points size = 100 ifTrue: [self playSoundNamed: 'croak']. Transcript cr; show: 'path defined with ', points size printString, ' points'. self setProperty: #pathPoints toValue: (points collect: [:p | p - ownerPosition])]. Cursor normal show. ! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 1/5/1999 10:05'! deletePath self removeProperty: #pathPoints! ! !Morph methodsFor: 'e-toy support' stamp: 'jm 10/9/2002 05:10'! embedInWindow | w window | w _ self world. window _ (SystemWindow labelled: self defaultLabelForInspector) model: nil. window bounds: ((self position - ((0@window labelHeight) + window borderWidth)) corner: self bottomRight + window borderWidth). window addMorph: self frame: (0@0 extent: 1@1). window updatePaneColors. w addMorph: window. window activate.! ! !Morph methodsFor: 'e-toy support' stamp: 'sw 10/26/1999 23:32'! embeddedInMorphicWindowLabeled: labelString | window | window _ (SystemWindow labelled: labelString) model: nil. window setStripeColorsFrom: nil defaultBackgroundColor. window addMorph: self frame: (0@0 extent: 1@1). ^ window! ! !Morph methodsFor: 'e-toy support' stamp: 'jm 10/15/2002 17:16'! followPath | pathPoints offset | (pathPoints _ self valueOfProperty: #pathPoints) ifNil: [^ self beep]. offset _ owner position - (self extent // 2). pathPoints do: [:p | self position: p + offset. self world displayWorld. (Delay forMilliseconds: 20) wait]. ! ! !Morph methodsFor: 'e-toy support' stamp: 'jm 10/14/2002 09:05'! unlockOneSubpart | unlockables aMenu reply | unlockables _ self submorphs select: [:m | m isLocked]. unlockables size <= 1 ifTrue: [^ self unlockContents]. aMenu _ SelectionMenu labelList: (unlockables collect: [:m | m externalName]) selections: unlockables. reply _ aMenu startUpWithCaption: 'Who should be be unlocked?'. reply ifNil: [^ self]. reply isLocked: false. ! ! !Morph methodsFor: 'e-toy support' stamp: 'tk 10/19/1999 07:16'! updateCachedThumbnail "If I have a cached thumbnail, then update it. Copied up from Dan's original version in PasteUpMorph so it can be used by all morphs." | cachedThumbnail | (cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil: [(cachedThumbnail respondsTo: #computeThumbnail) ifTrue: [cachedThumbnail computeThumbnail] ifFalse: [self removeProperty: #computeThumbnail]]. "Test and removal are because the thumbnail is being replaced by another Morph. We don't know why. Need to fix that at the source."! ! !Morph methodsFor: 'e-toy support' stamp: 'tk 9/3/1999 11:46'! wrappedInWindow: aSystemWindow | aWindow | aWindow _ aSystemWindow model: Model new. aWindow addMorph: self frame: (0@0 extent: 1@1). aWindow extent: self extent. ^ aWindow! ! !Morph methodsFor: 'e-toy support' stamp: 'tk 9/3/1999 11:46'! wrappedInWindowWithTitle: aTitle | aWindow | aWindow _ (SystemWindow labelled: aTitle) model: Model new. aWindow addMorph: self frame: (0@0 extent: 1@1). aWindow extent: self extent + (2 @ 18). ^ aWindow! ! !Morph methodsFor: 'parts bin' stamp: 'di 8/11/1998 12:48'! inPartsBin | o | self isPartsDonor ifTrue: [^ true]. o _ self owner. [o == nil] whileFalse: [o isPartsBin ifTrue: [^ true]. o _ o owner]. ^ false ! ! !Morph methodsFor: 'printing' stamp: 'jm 10/4/2002 07:22'! printOn: aStream | m | super printOn: aStream. m _ self findA: StringMorph. aStream nextPutAll: '('. m ifNotNil: [aStream print: m contents; space]. aStream print: self identityHash; nextPutAll: ')'. ! ! !Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 18:00'! printStructureOn: aStream indent: tabCount tabCount timesRepeat: [aStream tab]. self printOn: aStream. aStream cr. self submorphsDo: [:m | m printStructureOn: aStream indent: tabCount + 1]. ! ! !Morph methodsFor: 'printing' stamp: 'jm 5/28/1998 17:58'! structureString "Return a string that showing this morph and all its submorphs in an indented list that reflects its structure." | s | s _ WriteStream on: (String new: 1000). self printStructureOn: s indent: 0. ^ s contents ! ! !Morph methodsFor: 'caching' stamp: 'jm 10/13/2002 20:51'! releaseCachedState "Release any state that can be recomputed on demand, such as the pixel values for a color gradient or the editor state for a TextMorph. This method may be called to save space when a morph becomes inaccessible. Implementations of this method should do 'super releaseCachedState'." ! ! !Morph methodsFor: 'debug and other' stamp: 'sw 10/21/1998 09:29'! addDebuggingItemsTo: aMenu hand: aHandMorph aMenu add: 'debug...' subMenu: (self debuggingMenuFor: aHandMorph)! ! !Morph methodsFor: 'debug and other' stamp: 'jm 10/27/2003 15:12'! blink Display reverse: self bounds. Delay waitMSecs: 50. Display reverse: self bounds. ! ! !Morph methodsFor: 'debug and other' stamp: 'jm 10/14/2002 18:25'! debuggingMenuFor: aHandMorph | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. (self hasProperty: #errorOnDraw) ifTrue: [ aMenu add: 'start drawing again' action: #resumeAfterDrawError. aMenu addLine]. (self hasProperty: #errorOnStep) ifTrue: [ aMenu add: 'start stepping again' action: #resumeAfterStepError. aMenu addLine]. aMenu add: 'inspect morph' action: #inspectInMorphic. Smalltalk isMorphic ifFalse: [aMenu add: 'inspect morph (in MVC)' action: #inspect]. aMenu add: 'explore morph' target: self selector: #explore. aMenu addLine. aMenu add: 'browse morph class' target: self selector: #browseHierarchy. aMenu add: 'make own subclass' target: aHandMorph action: #subclassMorph. aMenu addLine. aMenu add: 'control-menu...' target: aHandMorph selector: #invokeMetaMenuFor: argument: self. ^ aMenu ! ! !Morph methodsFor: 'debug and other' stamp: 'ar 4/2/1999 15:11'! resumeAfterDrawError self changed. self removeProperty:#errorOnDraw. self changed.! ! !Morph methodsFor: 'debug and other' stamp: 'ar 4/2/1999 15:22'! resumeAfterStepError "Resume stepping after an error has occured." self startStepping. "Will #step" self removeProperty:#errorOnStep. "Will remove prop only if #step was okay" ! ! !Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'! privateColor: aColor color _ aColor. ! ! !Morph methodsFor: 'private' stamp: 'jm 10/9/2002 05:37'! privateMoveBy: delta "Private!! Use 'position:' instead." fullBounds == bounds ifTrue: ["optimization: avoids recomputing fullBounds" fullBounds _ bounds _ bounds translateBy: delta] ifFalse: [ bounds _ bounds translateBy: delta. fullBounds _ nil]. ! ! !Morph methodsFor: 'private' stamp: 'jm 10/13/2002 21:22'! privateProperties: aMorphPropertyOrNil "Private!! Used when copying." properties _ aMorphPropertyOrNil. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 17:50'! getFlag: maskInteger "Return the boolean flag for the given mask. The maskInteger is assumed to be an integer with only a single bit set, the bit corresponding to the flag to be read." ^ (flags bitAnd: maskInteger) ~= 0 ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:25'! isHidden ^ self getFlag: HiddenFlag ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/31/2002 10:18'! isHidden: aBoolean self setFlag: HiddenFlag to: aBoolean. self changed. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:29'! isLocked ^ self getFlag: LockedFlag ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:27'! isLocked: aBoolean self setFlag: LockedFlag to: aBoolean. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:29'! isPartsDonor ^ self getFlag: PartsDonorFlag ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/14/2002 08:54'! isPartsDonor: aBoolean self setFlag: PartsDonorFlag to: aBoolean. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:29'! isSticky ^ self getFlag: StickyFlag ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/14/2002 08:54'! isSticky: aBoolean self setFlag: StickyFlag to: aBoolean. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:27'! lock self isLocked: true. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 17:49'! setFlag: maskInteger to: aBoolean "Set the given flag bit to the given boolean value (false = 0, true = 1). The maskInteger is assumed to be an integer with only as single bit set, the bit corresponding to the flag to be modified." "Details: Morphs have a number of boolean properties that are most efficiently stored as a bit-vector packed into a single 31-bit Squeak SmallInteger." aBoolean ifTrue: [flags _ flags bitOr: maskInteger] ifFalse: [flags _ flags bitAnd: maskInteger bitInvert]. ! ! !Morph methodsFor: 'flags' stamp: 'jm 10/13/2002 18:07'! toggleStickiness self isSticky: self isSticky not. ! ! !Morph class methodsFor: 'class initialization' stamp: 'jm 10/13/2002 17:58'! initialize "Morph initialize" "flag masks: integers with a single bit set used as masks for the flags field" HiddenFlag _ 1. StickyFlag _ 2. LockedFlag _ 4. PartsDonorFlag _ 8. ! ! !Morph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 19:52'! includeInNewMorphMenu "Answer true for all classes that can be instantiated from the new morph menu." ^ false ! ! !Morph class methodsFor: 'instance creation' stamp: 'jm 5/29/1998 21:28'! newBounds: bounds color: color ^ (self new privateBounds: bounds) privateColor: color ! ! !Morph class methodsFor: 'instance creation' stamp: 'jm 6/28/2003 09:37'! open "Answer an instance of me and add it to the world." ^ self new openInWorld ! ! I represent one (name, value) pair in a singly-linked list of properties. Note: A linked list representation was chosen to hold optional Morph properties because we expect there to be no more than ten properties associated with any given morph (more typically, just one or two). In this case, a linked list has lower space overhead and is just as fast as an IdentityDictionary. (The cross-over point is around 8 entries; the linked list is faster, on the average, than a dictionary for fewer entries.) ! !MorphProperty methodsFor: 'accessing' stamp: 'jm 10/13/2002 20:26'! name ^ name ! ! !MorphProperty methodsFor: 'accessing' stamp: 'jm 10/14/2002 08:02'! name: aStringOrSymbol value: anObject "Initialize this property. The name is always converted to a Symbol for faster comparisons." name _ aStringOrSymbol asSymbol. value _ anObject. ! ! !MorphProperty methodsFor: 'accessing' stamp: 'jm 10/13/2002 20:26'! value ^ value ! ! !MorphProperty methodsFor: 'accessing' stamp: 'jm 10/14/2002 08:03'! value: anObject value _ anObject. ! ! !MorphProperty methodsFor: 'list operations' stamp: 'jm 8/18/2003 21:57'! copyAll "Return a copy of this entire property list." nextLink ifNil: [^ self clone] ifNotNil: [^ self clone nextLink: nextLink copyAll; yourself]. ! ! !MorphProperty methodsFor: 'list operations' stamp: 'jm 10/14/2002 08:19'! copyWithoutName: aStringOrSymbol "Return a copy of this property list without entries of the given name. Return nil if that leaves the list empty." | dup | name = aStringOrSymbol ifTrue: [ "omit myself from the copy" nextLink ifNil: [^ nil]. ^ nextLink copyWithoutName: aStringOrSymbol] ifFalse: [ "make a shallow copy of myself" dup _ self clone. nextLink ifNil: [^ dup]. dup nextLink: (nextLink copyWithoutName: aStringOrSymbol). ^ dup]. ! ! !MorphProperty methodsFor: 'list operations' stamp: 'jm 10/14/2002 08:09'! do: aBlock "Evaluate the given block on each of my elements." | this | this _ self. [this isNil] whileFalse: [ aBlock value: this. this _ this nextLink]. ! ! !MorphProperty methodsFor: 'list operations' stamp: 'jm 10/13/2002 20:28'! propertyForName: aStringOrSymbol "Answer the first MorphProperty with the given name in this linked list of properties, or nil if there isn't one." | this | this _ self. [this == nil] whileFalse: [ this name = aStringOrSymbol ifTrue: [^ this]. this _ this nextLink]. ^ nil ! ! !MorphProperty methodsFor: 'list operations' stamp: 'jm 10/14/2002 08:24'! size "Answer the number of properties in this list." | n | n _ 0. self do: [:prop | n _ n + 1]. ^ n ! ! !MorphProperty methodsFor: 'printing' stamp: 'jm 10/14/2002 08:04'! printOn: aStream name printOn: aStream. aStream nextPutAll: '=>'. value printOn: aStream. ! ! A morph whose appearance is a thumbnail of some other morph.! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:07'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'reveal original morph' action: #revealOriginal. aCustomMenu add: 'grab original morph' action: #grabOriginal. ! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'jm 7/17/2003 22:57'! computeThumbnail "Assumption on entry: The receiver's width represents the maximum width allowable. The receiver's height represents the exact height desired." | f scaleX scaleY | f _ morphRepresented imageForm. morphRepresented allMorphsDo: [:m | m releaseCachedState]. scaleY _ self height / f height. "keep height invariant" scaleX _ ((morphRepresented width * scaleY) <= self width) ifTrue: [scaleY] "the usual case; same scale factor, to preserve aspect ratio" ifFalse: [self width / f width]. self form: (f magnify: f boundingBox by: (scaleX @ scaleY) smoothing: 2). self extent: originalForm extent! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:08'! grabOriginal self primaryHand attachMorph: morphRepresented! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 07:05'! initialize | f | super initialize. color _ Color lightGray. "background color" f _ Form extent: 60@80 depth: Display depth. f fill: f boundingBox fillColor: color. self form: f ! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'bf 3/31/1999 12:24'! innocuousName ^ morphRepresented isNil ifTrue: [super innocuousName] ifFalse: [morphRepresented innocuousName]! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'jm 11/17/97 17:30'! morphRepresented ^ morphRepresented ! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'bf 3/31/1999 12:38'! morphRepresented: aMorph morphRepresented _ aMorph. self computeThumbnail. ! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'bf 3/31/1999 07:54'! representativeNoTallerThan: maxHeight norWiderThan: maxWidth thumbnailHeight: thumbnailHeight "Return a morph representing the receiver but which is no taller than aHeight. If the receiver is already small enough, just return it, else return a MorphThumbnail companioned to the receiver, enforcing the maxWidth" (self height <= maxHeight and: [self width <= maxWidth]) ifTrue: [^ self]. ^ MorphThumbnail new extent: maxWidth @ (thumbnailHeight min: self height); morphRepresented: morphRepresented! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 7/6/1998 22:04'! revealOriginal ((owner isKindOf: PasteUpMorph) and: [owner alwaysShowThumbnail]) ifTrue: [^ self beep]. morphRepresented owner == nil ifTrue: [^ owner replaceSubmorph: self by: morphRepresented]. self beep.! ! !MorphThumbnail methodsFor: 'as yet unclassified' stamp: 'sw 8/10/1998 07:05'! smaller self form: (self form copy: (0@0 extent: self form extent // 2))! ! I am a controller for SceneViews. I support gestures for scrolling, click-selection, and area selection of scene glyphs. (See the class comment in GestureController for more details about gestures.) I also support construction operations such as inserting new glyphs and merging glyphs to make them share a common point. The mapping of gestures to actions is as follows (see GestureController comment for more about gestures): Click: click on glyph select glyph shift-click on glyph toggle selection of that glyph click on background clear selection Double click: double-click on glyph inspect glyph double-click on background select all Hold/Drag/Sweep: hold (no movement) yellow-button menu drag (up/left movement) scrolling hand sweep (down/right movement) select glyphs in region shift-sweep toggle selection of glyphs in region ! !MorphWorldController methodsFor: 'control sequence' stamp: 'di 11/26/1999 10:00'! controlInitialize "This window is becoming active." true ifTrue: [model becomeTheActiveWorldWith: nil]. model canvas ifNil: [ "i.e., only on first entry" "In case of, eg, inspect during balloon help..." model submorphsDo: [:m | "delete any existing balloons" (m isKindOf: BalloonMorph) ifTrue: [m delete]]. model handsDo: [:h | h initForEvents]. view displayView]. "initializes the WorldMorph's canvas" ! ! I am a view used to display a Scene. I may be scrolled by adjusting my offset. My default controller is SceneController. SceneViews encapsulate the notion of a changing foreground and a fixed background during interactive updates. During an interaction (such as dragging), some of the glyphs will not change location or appearance. These are part of the "background". All glyphs that may change (the "foreground" glyphs) are painted against this unchanging backdrop during the interaction. Instance Variables: offset the current offset of this view (used for scrolling) enclosingRect a rectangle large enough to contain all the objects in the scene, plus a small border (this is a cache that must be recomputed when glyphs are moved, added, or removed from the scene) backgroundForm a <Form> containing the fixed background visibleForeground the glyphs that are changing but not selected during an interaction selectedForeground the selected glyphs that are changing during an interaction! !MorphWorldView methodsFor: 'as yet unclassified' stamp: 'dew 11/8/1999 02:00'! computeInsetDisplayBox "This overrides the same method in View. (It avoids using displayTransform: because it can return inaccurate results, causing a MorphWorldView's inset display box to creep inward when resized.)" ^superView insetDisplayBox insetBy: borderWidth! ! !MorphWorldView methodsFor: 'as yet unclassified' stamp: 'jm 7/17/2003 22:58'! deEmphasizeView "This window is becoming inactive." Cursor normal show. model handsDo: [:h | h newKeyboardFocus: nil]. model canvas: nil. "free model's canvas to save space" model allMorphsDo: [:m | m releaseCachedState]. self topView cacheBitsAsTwoTone ifTrue: [ "draw deEmphasized as a two-tone (monochrome) form" model displayWorldAsTwoTone]. ! ! !MorphWorldView methodsFor: 'as yet unclassified' stamp: 'dew 11/8/1999 02:01'! displayView "This method is called by the system when the top view is framed or moved." | topView | model viewBox: self insetDisplayBox. self updateSubWindowExtent. topView _ self topView. (topView == ScheduledControllers scheduledControllers first view or: [topView cacheBitsAsTwoTone not]) ifTrue: [model displayWorldSafely] ifFalse: [model displayWorldAsTwoTone]. "just restoring the screen"! ! !MorphWorldView methodsFor: 'as yet unclassified' stamp: 'RAA 11/25/1999 09:19'! updateSubWindowExtent "If this MorphWorldView represents a single Morphic SystemWindow, then update that window to match the size of the WorldView." | numMorphs subWindow scrollBarWidth | numMorphs _ model submorphs size. "(Allow for the existence of an extra NewHandleMorph (for resizing).)" (numMorphs = 0 or: [numMorphs > 2]) ifTrue: [^ self]. subWindow _ model submorphs detect: [:ea | ea respondsTo: #label] ifNone: [^ self]. superView label = subWindow label ifFalse: [^ self]. (Preferences valueOfFlag: #inboardScrollbars) ifTrue: [scrollBarWidth _ 0] ifFalse: [scrollBarWidth _ 14]. subWindow position: model position + (scrollBarWidth@-16). "adjust for WiW changes" subWindow extent: model extent - (scrollBarWidth@-16). subWindow isActive ifFalse: [subWindow activate].! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'RAA 11/25/1999 23:43'! convertToMVCWiWPasteUpMorph " MorphWorldView convertToMVCWiWPasteUpMorph " | current w newModel topView | Smalltalk isMorphic ifTrue: [^self inform: 'do this in MVC']. current _ self allInstances select: [ :each | each model class == PasteUpMorph]. current do: [ :oldWorldView | w _ MVCWiWPasteUpMorph newWorldForProject: nil. w color: oldWorldView model color; addAllMorphs: oldWorldView model submorphs. newModel _ CautiousModel new initialExtent: 300@300. topView _ self fullColorWhenInactive ifTrue: [ColorSystemView new] ifFalse: [StandardSystemView new]. topView model: newModel; label: oldWorldView topView label; borderWidth: 1; addSubView: (self new initialize model: w); backgroundColor: w color. topView controller openNoTerminate. topView reframeTo: (oldWorldView topView expandedFrame expandBy: (0@0 extent: (0@topView labelHeight))). oldWorldView topView controller closeAndUnscheduleNoTerminate. ]. ScheduledControllers restore. Processor terminateActive.! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'sw 9/21/1998 17:54'! openOn: aWorldMorph label: aString cautionOnClose: aBoolean "Open a view with the given label on the given WorldMorph." | aModel | aModel _ aBoolean ifTrue: [CautiousModel new] ifFalse: [WorldViewModel new]. ^ self openOn: aWorldMorph label: aString model: (aModel initialExtent: aWorldMorph initialExtent)! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'di 11/26/1999 11:46'! openWorld | w | (w _ MVCWiWPasteUpMorph newWorldForProject: nil). w bounds: (0@0 extent: 400@300). self openOn: w label: 'A Morphic World' extent: w fullBounds extent + 2. ! ! !MorphWorldView class methodsFor: 'instance creation' stamp: 'sma 6/12/2000 14:18'! openWorldWith: aMorph labelled: labelString | w | (w _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aMorph. w extent: aMorph fullBounds extent. w startSteppingSubmorphsOf: aMorph. self openOn: w label: labelString extent: w fullBounds extent + 2. ! ! I describe Morphic input events such as keystrokes and mouse movements. type -- a Symbol identifying the type of event (#mouse, #keyboard, etc.) cursorPoint -- the coordinates of the mouse cursor buttons -- bit-packed integer indicating the state of the mouse buttons and modifier keys keyValue -- ASCII value of the key pressed sourceHand -- the HandMorph that generated this event MorphicEvents are created when a HandMorph receives the message processEvents. ! !MorphicEvent methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:58'! blueButtonPressed "Answer true if the blue mouse button is being pressed. This is the third mouse button or cmd+click on the Mac." ^ buttons anyMask: 1! ! !MorphicEvent methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:41'! redButtonPressed "Answer true if the red mouse button is being pressed. This is the first mouse button." ^ buttons anyMask: 4! ! !MorphicEvent methodsFor: 'mouse' stamp: 'ar 11/15/1998 23:42'! transformedBy: aMorphicTransform "Return a copy of the receiver transformed by the given transformation." aMorphicTransform isIdentity ifTrue: [^ self]. "no transformation needed" ^ self copy setCursorPoint: (aMorphicTransform globalPointToLocal: cursorPoint) ! ! !MorphicEvent methodsFor: 'mouse' stamp: 'jm 11/22/2002 11:43'! translatedBy: delta "Answer a new event whose cursorPoint is is offset by the given delta." ^ self shallowCopy setCursorPoint: cursorPoint + delta ! ! !MorphicEvent methodsFor: 'mouse' stamp: 'bf 9/22/1999 12:42'! yellowButtonPressed "Answer true if the yellow mouse button is being pressed. This is the second mouse button or option+click on the Mac." ^ buttons anyMask: 2! ! !MorphicEvent methodsFor: 'keyboard' stamp: 'di 9/28/1999 08:29'! anyModifierKeyPressed "ignore, however, the shift keys 'cause that's not REALLY a command key " ^ self buttons anyMask: 16r70 "cmd | opt | ctrl"! ! !MorphicEvent methodsFor: 'keyboard' stamp: 'jm 5/29/1998 14:20'! shiftPressed "Answer true if the shift key on the keyboard was being held down when this event occurred." ^ buttons anyMask: 8 ! ! !MorphicEvent methodsFor: 'private' stamp: 'tk 3/10/1999 11:24'! setButtons: mask buttons _ mask! ! !MorphicEvent methodsFor: 'private' stamp: 'ar 6/2/1999 14:35'! setCursorPoint: aPoint cursorPoint _ aPoint.! ! !MorphicEvent class methodsFor: 'instance creation' stamp: 'di 2/6/1999 12:42'! readFrom: aStream "Read a MorphicEvent from the given stream." | type x y buttons keyValue typeString c | typeString _ String streamContents: [:s | [(c _ aStream next) isLetter] whileTrue: [s nextPut: c]]. typeString = 'mouseMove' ifTrue: [type _ #mouseMove "fast treatment of common case"] ifFalse: [type _ typeString asSymbol]. x _ Integer readFrom: aStream. aStream skip: 1. y _ Integer readFrom: aStream. aStream skip: 1. buttons _ Integer readFrom: aStream. aStream skip: 1. keyValue _ Integer readFrom: aStream. ^ self basicNew setType: type cursorPoint: x@y buttons: buttons keyValue: keyValue ! ! This class implements simple translation, scaling and rotation for points, as well as inverse transformations. These transformations are used in TransformMorphs (clipping scrollers) and TransformationMorphs (general flex-morph wrappers) to map, eg, global mouse coords into local coords, and to invert, eg, local damage rectangles into global damage rectangles.! !MorphicTransform methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:33'! inverseTransformation "Return the inverse transformation of the receiver" ^MorphicTransform offset: (self transform: 0@0) - (self transform: offset) angle: angle negated scale: scale reciprocal! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:10'! invert: aPoint "Transform the given point from local to global coordinates." | p3 p2 | self isPureTranslation ifTrue: [^ aPoint - offset]. p3 _ aPoint * scale. p2 _ ((p3 x * angle cos) + (p3 y * angle sin)) @ ((p3 y * angle cos) - (p3 x * angle sin)). ^ (p2 - offset) ! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'! invertBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from local back to global coordinates. NOTE: if the transformation is not just a translation, then it will compute the bounding box in global coordinates." | outerRect | self isPureTranslation ifTrue: [^ (self invert: aRectangle topLeft) corner: (self invert: aRectangle bottomRight)] ifFalse: [outerRect _ Rectangle encompassing: (aRectangle innerCorners collect: [:p | self invert: p]). "Following asymmetry due to likely subsequent truncation" ^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/2/1998 08:54'! invertRect: aRectangle self error: 'method name changed to emphasize enclosing bounds'. ^ self invertBoundsRect: aRectangle! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/28/1999 09:05'! transform: aPoint "Transform the given point from global to local coordinates." | p2 p3 | self isPureTranslation ifTrue: [^ aPoint + offset]. p2 _ aPoint + offset. p3 _ (((p2 x * angle cos) - (p2 y * angle sin)) @ ((p2 y * angle cos) + (p2 x * angle sin))) / scale. ^ p3! ! !MorphicTransform methodsFor: 'transformations' stamp: 'di 10/3/1998 00:18'! transformBoundsRect: aRectangle "Return a rectangle whose coordinates have been transformed from global to local coordinates. NOTE: if the transformation is not just a translation, then it will compute the bounding box in global coordinates." | outerRect | self isPureTranslation ifTrue: [^ (self transform: aRectangle topLeft) corner: (self transform: aRectangle bottomRight)] ifFalse: [outerRect _ Rectangle encompassing: (aRectangle innerCorners collect: [:p | self transform: p]). "Following asymmetry due to likely subsequent truncation" ^ outerRect topLeft - (1@1) corner: outerRect bottomRight + (2@2)]! ! !MorphicTransform methodsFor: 'initialize' stamp: 'ar 11/2/1998 20:58'! setIdentiy scale _ 1.0. offset _ 0@0. angle _ 0.0.! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! isIdentity "Return true if the receiver is the identity transform; that is, if applying to a point returns the point itself." ^ self isPureTranslation and: [offset = (0@0)] ! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 19:51'! isMorphicTransform ^true! ! !MorphicTransform methodsFor: 'testing' stamp: 'ar 11/2/1998 20:57'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^ angle = 0.0 and: [scale = 1.0] ! ! !MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:13'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self transform: aPoint! ! !MorphicTransform methodsFor: 'transforming points' stamp: 'ar 11/2/1998 16:32'! localPointToGlobal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self invert: aPoint! ! !MorphicTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:14'! asMatrixTransform2x3 ^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal: (MatrixTransform2x3 withScale: scale)) offset: offset negated! ! !MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! asMorphicTransform ^ self! ! !MorphicTransform methodsFor: 'printing' stamp: 'ar 5/19/1999 18:21'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll:'angle = '; print: angle; nextPutAll:'; scale = '; print: scale; nextPutAll:'; offset = '; print: offset; nextPut:$).! ! !MorphicTransform methodsFor: 'encoding' stamp: 'ls 10/9/1999 19:06'! encodeForRemoteCanvas "encode this transform into a string for use by a RemoteCanvas" ^String streamContents: [ :str | str nextPutAll: 'Morphic,'; print: offset x truncated; nextPut: $,; print: offset y truncated; nextPut: $,; print: scale; nextPut: $,; print: angle ]! ! !MorphicTransform class methodsFor: 'instance creation' stamp: 'jm 6/20/2003 10:12'! fromRemoteCanvasEncoding: encoded | rs type offsetXEnc offsetYEnc scaleEnc angleEnc offsetX offsetY scale angle | "separate the numbers" rs _ ReadStream on: encoded. type _ rs upTo: $,. offsetXEnc _ rs upTo: $,. offsetYEnc _ rs upTo: $,. scaleEnc _ rs upTo: $,. angleEnc _ rs upToEnd. "decode the numbers" offsetX _ Integer readFrom: (ReadStream on: offsetXEnc). offsetY _ Integer readFrom: (ReadStream on: offsetYEnc). scale _ Number readFrom: (ReadStream on: scaleEnc). angle _ Number readFrom: (ReadStream on: angleEnc). "create an instance" ^ self offset: offsetX@offsetY angle: angle scale: scale ! ! A draggable handle used by Polygon morph and Halos. ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 12:00'! argument ^ argument ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 15:36'! mouseDownSelector ^ mouseDownSelector ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 12:01'! mouseDownSelector: sel mouseDownSelector _ sel asSymbol. ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 12:48'! mouseMoveSelector: sel mouseMoveSelector _ sel asSymbol. ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 12:01'! mouseUpSelector: sel mouseUpSelector _ sel asSymbol. ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 14:46'! mouseUpTarget ^ mouseUpTarget ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 15:02'! mouseUpTarget: anObject "Set the secondary target to notify instead of the normal target on mouse up." mouseUpTarget _ anObject. ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 11:58'! target ^ target ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 11:58'! target: anObject target _ anObject. ! ! !MouseHandleMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 12:00'! target: anObject argument: argOrNil target _ anObject. argument _ argOrNil. ! ! !MouseHandleMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 12:46'! handlesMouseDown: evt ^ true ! ! !MouseHandleMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 14:48'! mouseDown: evt self send: mouseDownSelector to: target withEvent: evt. ! ! !MouseHandleMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 14:48'! mouseMove: evt self send: mouseMoveSelector to: target withEvent: evt. ! ! !MouseHandleMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 15:01'! mouseUp: evt "If mouseUpTarget is not nil, notify it rather than the normal target." | client | client _ mouseUpTarget ifNil: [target] ifNotNil: [mouseUpTarget]. self send: mouseUpSelector to: client withEvent: evt. ! ! !MouseHandleMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 14:47'! send: selector to: client withEvent: event "Send the given selector to the given object with the given event. The selector can take up to three arguments." | argCount | client isNil | selector isNil ifTrue: [^ self]. argCount _ selector numArgs. argCount = 0 ifTrue: [^ client perform: selector]. argCount = 1 ifTrue: [^ client perform: selector with: event]. argCount = 2 ifTrue: [^ client perform: selector with: event with: self]. argCount = 3 ifTrue: [^ client perform: selector with: event with: self with: argument]. self error: 'selector must take 0-3 arguments'. ! ! I am a Controller that modifies the scheduling of user activities so that the three mouse buttons can be used to make selections or display menus. The menu items are unary messages to the value of sending my instance the message menuMessageReceiver.! !MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'! release super release. redButtonMenu release! ! !MouseMenuController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 15:54'! reset "Eliminate references to all mouse button menus." redButtonMenu _ nil. redButtonMessages _ nil! ! !MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:28'! controlActivity "Refer to the comment in Controller|controlActivity." | cursorPoint | cursorPoint _ sensor cursorPoint. super controlActivity. (cursorPoint = sensor cursorPoint and: [self viewHasCursor]) ifTrue: [sensor redButtonPressed ifTrue: [^ self redButtonActivity]. sensor yellowButtonPressed ifTrue: [^ self yellowButtonActivity]. sensor blueButtonPressed ifTrue: [^ self blueButtonActivity]]! ! !MouseMenuController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 11:24'! isControlActive "In contrast to class Controller, only blue button but not yellow button events will end the receiver's control loop." ^ self viewHasCursor and: [sensor blueButtonPressed not]! ! !MouseMenuController methodsFor: 'menu setup'! redButtonMenu: aSystemMenu redButtonMessages: anArray "Initialize the pop-up menu that should appear when the user presses the red mouse button to be aSystemMenu. The corresponding messages that should be sent are listed in the array, anArray." redButtonMenu release. redButtonMenu _ aSystemMenu. redButtonMessages _ anArray! ! !MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 15:01'! blueButtonActivity "This normally opens the window menu. It is a no-op here as only the StandardSystemController deals with that kind of menus."! ! !MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:56'! redButtonActivity "Determine which item in the red button pop-up menu is selected. If one is selected, then send the corresponding message to the object designated as the menu message receiver." | index | redButtonMenu ~~ nil ifTrue: [index _ redButtonMenu startUp. index ~= 0 ifTrue: [self perform: (redButtonMessages at: index)]] ifFalse: [super controlActivity]! ! !MouseMenuController methodsFor: 'menu messages' stamp: 'sma 3/11/2000 14:59'! yellowButtonActivity "This normally opens a popup menu. Determine the selected item and, if one is selected, then send the corresponding message to either the model or the receiver." ^ self pluggableYellowButtonActivity: sensor leftShiftDown! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:36'! getPluggableYellowButtonMenu: shiftKeyState ^ view getMenu: shiftKeyState! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:38'! pluggableYellowButtonActivity: shiftKeyState "Invoke the model's popup menu." | menu selector | (menu _ self getPluggableYellowButtonMenu: shiftKeyState) ifNil: [sensor waitNoButton] ifNotNil: [(selector _ menu startUp) ifNil: [^ self]. self terminateAndInitializeAround: [model perform: selector orSendTo: self]]! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'! shiftedYellowButtonActivity "Invoke the model's special popup menu." ^ self pluggableYellowButtonActivity: true! ! !MouseMenuController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 12:37'! unshiftedYellowButtonActivity "Invoke the model's normal popup menu." ^ self pluggableYellowButtonActivity: false! ! I implement an abstract server for message-based, request/reply interactions. In a "message-based" client/server interaction, the unit of communication is messages, not strings or data streams. A message in this context is simply a ByteArray or String of arbitrary size. The server follows a request/reply interaction model in which the server is passive until it receives a request message. For each request, it computes a reply message which is returned to the client. Every request must generate a reply of some sort, even if it is merely a zero-length message. Requests from a given client are handled sequentially. The request/reply model is similar to procedure call/return, which is familiar and easy to reason about. The message-based server abstraction hides most of the details of transmitting and receiving data over a socket, allowing the programmer to focus on designing the requests/reply interactions needed for a specific application. Although this server can handle messages up to 2^32 bytes, there is a practical limit on the size of messages and replies, since messages are buffered in memory. Thus this server design is not appropriate for serving larger files or for streaming audio or movie data. The server performs the following tasks: assembles incoming data into complete messages dispatching each message for processing transmits the reply message back to the client To create a new kind of server, one typically makes a subclass of this class and implements: o the instance method "processMessage:" to process incoming messages o the class method "portNumber" to return port number on which the server will listen While servers can interpret messages any way they like, one useful convention is to use the first byte to identify the type of the request or reply message. To start and stop a server use: o forkServerProcess to run the server in the background or runServer to run it in the UI thread o stopServer to stop the server, kill it's thread (if any), and clean up all sockets ! !MsgServer methodsFor: 'initialization' stamp: 'jm 9/5/2001 07:48'! initialize "Initialize my state." serverSocket _ nil. serverProcess _ nil. connections _ OrderedCollection new. ! ! !MsgServer methodsFor: 'accessing' stamp: 'jm 9/5/2001 12:07'! portNumber "Answer the number of the port on which this server listens." ^ self class portNumber ! ! !MsgServer methodsFor: 'start/stop' stamp: 'jm 7/22/2002 14:27'! forkServerProcess "Fork a process to run the server. This is useful if you want to run the client and the server in the same Squeak image, or if you need to run multiple servers. For debugging, you can run the server synchronously in the UI thread using 'runServer'. In this case, any errors will halt the server in a debugger." self stopServer. self serverStartup. self openServerSocket. serverProcess _ [self serverLoop] newProcess. serverProcess priority: Processor userInterruptPriority; resume. Transcript show: 'Server started.'; cr. ! ! !MsgServer methodsFor: 'start/stop' stamp: 'jm 9/26/2001 15:16'! runServer "Run the server loop synchronously in the Squeak UI thread. This is useful to debugging, since if the server gets an error you can debug it and proceed. To stop the server, hit the interrupt key, then send it 'stopServer'. You can also run the server in the background using forkServerProcess, allowing clients to be run in the same Squeak image." self stopServer. self serverStartup. self openServerSocket. self serverLoop. ! ! !MsgServer methodsFor: 'start/stop' stamp: 'jm 9/26/2001 13:21'! serverShutdown "Sent when the server is shutting down. Subclasses can override this message to do their own shutdown actions." ! ! !MsgServer methodsFor: 'start/stop' stamp: 'jm 9/26/2001 13:20'! serverStartup "Sent when the server is starting up. Subclasses can override this message to do their own initialization at startup time." ! ! !MsgServer methodsFor: 'start/stop' stamp: 'jm 9/26/2001 14:19'! stopServer "Stop this server and destroy all sockets. If the server was started using 'forkServerProcess', terminate the server process." serverProcess ifNotNil: [serverProcess terminate]. serverProcess _ nil. serverSocket ifNotNil: [serverSocket destroy]. serverSocket _ nil. connections do: [:sock | sock destroy]. connections _ OrderedCollection new. self serverShutdown. Transcript show: 'Server stopped.'; cr. ! ! !MsgServer methodsFor: 'request handling' stamp: 'jm 1/7/2003 10:45'! processMessage: aByteArray "Process the given message and return a String or ByteArray to be sent back to the client as the response. Typically, the first byte of the argument determines the operation to be performed. This method should be overridden by subclasses to provide their own server behavior. This default implementation simply answer the null (zero length) message." "Note: If this method return nil or self, the null message is returned to the client." ^ '' ! ! !MsgServer methodsFor: 'request handling' stamp: 'jm 1/18/2003 11:00'! processMessage: aByteArray requestSocket: aSocket "Process the given message and return a String or ByteArray to be sent back to the client as the response. Overriding this method allows a subclass to access the requesting socket, but message servers that don't need that socket should implement processMessage: instead. See additional comments in processMessage:." "Details: The request socket will be destroyed when this method returns." ^ self processMessage: aByteArray ! ! !MsgServer methodsFor: 'private' stamp: 'jm 9/26/2001 15:10'! forkRequestLoopOnSocket: aSocket "Fork a process to handle requests on the given socket." [self requestLoopWithErrorRecoveryOnSocket: aSocket] fork. ! ! !MsgServer methodsFor: 'private' stamp: 'jm 6/27/2002 13:04'! openServerSocket "Open a socket on my port and get ready to accept requests. If I am already running, clear the state of any current client connections and close their sockets." Socket initializeNetwork. serverSocket _ Socket new. serverSocket listenOn: self portNumber backlogSize: self class backlogSize. ! ! !MsgServer methodsFor: 'private' stamp: 'jm 1/18/2003 10:58'! requestLoopOnSocket: aSocket "This is the request handling loop." "Details: This loop terminates and destroys the message socket if the connection is broken, either by the client or by a network failure." | requestSock busy msg reply | requestSock _ MessageSocket new on: aSocket. [requestSock isConnected] whileTrue: [ busy _ requestSock sendData. msg _ requestSock nextMessage. msg ifNotNil: [ busy _ true. reply _ self processMessage: msg requestSocket: requestSock. ((reply == nil) or: [reply == self]) ifTrue: [reply _ ByteArray new]. requestSock sendMessage: reply]. busy ifFalse: [(Delay forMilliseconds: 10) wait]]. "sleep a while if idle" requestSock socket destroy. connections remove: aSocket ifAbsent: []. ! ! !MsgServer methodsFor: 'private' stamp: 'jm 9/26/2001 15:10'! requestLoopWithErrorRecoveryOnSocket: aSocket "Process requests on the given socket. If there are any errors, destroy the socket and return." [self requestLoopOnSocket: aSocket] ifError: [:err :rcvr | aSocket destroy. connections remove: aSocket ifAbsent: []]. ! ! !MsgServer methodsFor: 'private' stamp: 'jm 9/26/2001 15:22'! serverLoop "This is the main server loop. It's job is to accept incoming connections on the server socket and to respond to the sequence of requests on each connection accepted." "Details: If running the background, fork a new thread to handle requests on each connection. Otherwise, handle requests on only one connection at a time, all in the same thread, to allow server errors to be debugged. This loop terminates and destroys the server socket if the primary socket becomes invalid (e.g. after a snapshot)." | thisConnection | serverSocket ifNil: [^ self]. [serverSocket isUnconnectedOrInvalid] whileFalse: [ (serverSocket waitForConnectionUntil: (Socket deadlineSecs: 5)) ifTrue: [ thisConnection _ serverSocket accept. connections addLast: thisConnection. serverProcess ifNil: [self requestLoopOnSocket: thisConnection] ifNotNil: [self forkRequestLoopOnSocket: thisConnection]. thisConnection _ nil]]. serverSocket destroy. serverSocket _ nil. connections do: [:sock | sock destroy]. connections _ OrderedCollection new. ! ! !MsgServer class methodsFor: 'constants' stamp: 'jm 7/30/2001 20:38'! backlogSize "Answer the connection backlog size for this server." ^ 4 ! ! !MsgServer class methodsFor: 'constants' stamp: 'jm 7/30/2001 20:38'! portNumber "Answer the port number that this server will listen on. The subclass should override this method to change the port number." ^ 54321 ! ! I am an example server using the MsgServer framework. I implement the four basic arithmetic functions. The first byte of the request message determines the operation: 1 -- add 2 -- subtract 3 -- multiply 4 -- divide The 8 bytes following the operation byte are two 32-bit signed integer operands. Obviously, it doesn't take a server to do arithmetic, but it illustrates one way dispatch different server operations, how to pass arguments and results, and how to deal with errors. To try this server, copy the remainder of this comment into a workspace and follow the step-by-step directions. First start the server: server _ MsgServerTest new. server forkServerProcess. Next, create a client socket and connect it to the server: sock _ MessageSocket new. sock connectTo: NetNameResolver localHostAddress port: MsgServerTest portNumber waitSecs: 10. sock isConnected ifFalse: [self error: 'could not connect']. You can now build a request message, send it to the server, and decode the reply. Select and print the following four lines: "operations: 1 - add, 2 - subtract, 3 - multiply, 4 - integer divide" request _ MsgServerTest msgOp: 1 int1: 7 int2: 3. result _ sock request: request. (ReadStream on: result) int32. When you are done, you can close the client socket stop the server: sock destroy. server stopServer. That's all there is to it!! ! !MsgServerTest methodsFor: 'request handling' stamp: 'jm 7/29/2001 10:52'! processMessage: aByteArray "This server implements a very simple four-function calculator." | op s arg1 arg2 result | aByteArray size = 9 ifFalse: [^ 'bad message size']. "read operation and arguments" s _ ReadStream on: aByteArray. op _ s next. arg1 _ s int32. arg2 _ s int32. (op >= 1 and: [op <= 4]) ifFalse: [^ 'bad op']. "compute result" op = 1 ifTrue: [result _ arg1 + arg2]. op = 2 ifTrue: [result _ arg1 - arg2]. op = 3 ifTrue: [result _ arg1 * arg2]. op = 4 ifTrue: [ arg2 = 0 ifTrue: [^ 'divide by zero error'] ifFalse: [result _ arg1 // arg2]]. (result isKindOf: SmallInteger) ifFalse: [^ 'result is not a SmallInteger']. "create and answer result message" s _ WriteStream on: (ByteArray new: 4). s int32: result. ^ s contents ! ! !MsgServerTest class methodsFor: 'port number' stamp: 'jm 7/30/2001 20:31'! portNumber ^ 54322 ! ! !MsgServerTest class methodsFor: 'utilities' stamp: 'jm 1/7/2003 11:50'! msgOp: op int1: int1 int2: int2 "Answer a request message (a ByteArray) for a command to perform the given operation on the two arguments." | s | s _ WriteStream on: (ByteArray new: 9). s nextPut: op. s int32: int1. s int32: int2. ^ s contents ! ! I represent a mu-law (u-law) codec. I compress sound data by a factor of 2:1 by encoding the most significant 12 bits of each 16-bit sample as a signed, exponentially encoded byte. The idea is to use more resolution for smaller lower sample values. This encoding was developed for the North American phone system and a variant of it, a-law, is a European phone standard. It is a popular sound encoding on Unix platforms (.au files). ! !MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:15'! bytesPerEncodedFrame "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size." ^ 1 ! ! !MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 14:10'! decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." | dst | dst _ dstIndex. srcIndex to: srcIndex + frameCount - 1 do: [:src | dstSoundBuffer at: dst put: (DecodingTable at: (srcByteArray at: src) + 1). dst _ dst + 1]. ^ Array with: frameCount with: frameCount ! ! !MuLawCodec methodsFor: 'subclass responsibility' stamp: 'di 2/8/1999 22:25'! encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." srcIndex to: srcIndex + frameCount - 1 do: [:i | dstByteArray at: i put: (self uLawEncodeSample: (srcSoundBuffer at: i))]. ^ Array with: frameCount with: frameCount ! ! !MuLawCodec methodsFor: 'subclass responsibility' stamp: 'jm 2/2/1999 09:11'! samplesPerFrame "Answer the number of sound samples per compression frame." ^ 1 ! ! !MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:28'! uLawDecodeSample: byte "Decode a 16-bit signed sample from 8 bits using uLaw decoding" ^ DecodingTable at: byte + 1! ! !MuLawCodec methodsFor: 'external access' stamp: 'di 2/8/1999 22:30'! uLawEncodeSample: sample "Encode a 16-bit signed sample into 8 bits using uLaw encoding" | s | s _ sample // 8. "drop 3 least significant bits" s < 0 ifTrue: [^ (self uLawEncode12Bits: 0-s) + 16r80] ifFalse: [^ (self uLawEncode12Bits: s)]. ! ! !MuLawCodec methodsFor: 'private' stamp: 'di 2/9/1999 13:25'! uLawEncode12Bits: s "Encode a 12-bit unsigned sample (0-4095) into 7 bits using uLaw encoding. This gets called by a method that scales 16-bit signed integers down to a 12-bit magnitude, and then ORs in 16r80 if they were negative. Detail: May get called with s >= 4096, and this works fine." s < 496 ifTrue: [ s < 112 ifTrue: [ s < 48 ifTrue: [ s < 16 ifTrue: [^ 16r70 bitOr: (15 - s)] ifFalse: [^ 16r60 bitOr: (15 - ((s - 16) bitShift: -1))]]. ^ 16r50 bitOr: (15 - ((s - 48) bitShift: -2))]. s < 240 ifTrue: [^ 16r40 bitOr: (15 - ((s - 112) bitShift: -3))] ifFalse: [^ 16r30 bitOr: (15 - ((s - 240) bitShift: -4))]]. s < 2032 ifTrue: [ s < 1008 ifTrue: [^ 16r20 bitOr: (15 - ((s - 496) bitShift: -5))] ifFalse: [^ 16r10 bitOr: (15 - ((s - 1008) bitShift: -6))]]. s < 4080 ifTrue: [^ 15 - ((s - 2032) bitShift: -7)] ifFalse: [^ 0]. ! ! !MuLawCodec class methodsFor: 'class initialization' stamp: 'di 2/9/1999 14:57'! initialize "Build the 256 entry table to be used to decode 8-bit uLaw-encoded samples." "MuLawCodec initialize" | encoded codec lastEncodedPos lastEncodedNeg | DecodingTable _ Array new: 256. codec _ self new. lastEncodedPos _ nil. lastEncodedNeg _ nil. 4095 to: 0 by: -1 do: [:s | encoded _ codec uLawEncode12Bits: s. lastEncodedPos = encoded ifFalse: [ DecodingTable at: (encoded + 1) put: (s bitShift: 3). lastEncodedPos _ encoded]. encoded _ encoded bitOr: 16r80. lastEncodedNeg = encoded ifFalse: [ DecodingTable at: (encoded + 1) put: (s bitShift: 3) negated. lastEncodedNeg _ encoded]]. ! ! This class implements TCP/IP style network name lookup and translation facilities. Attempt to keep track of whether there is a network available. HaveNetwork true if last attempt to contact the network was successful. LastContact Time of that contact (totalSeconds). haveNetwork returns true, false, or #expired. True means there was contact in the last 30 minutes. False means contact failed or was false last time we asked. Get out of false state by making contact with a server in some way (FileList or updates).! !NetNameResolver class methodsFor: 'lookups' stamp: 'ls 9/5/1998 01:14'! addressForName: aString ^self addressForName: aString timeout: 60! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 17:35'! addressForName: hostName timeout: secs "Look up the given host name and return its address. Return nil if the address is not found in the given number of seconds." "NetNameResolver addressForName: 'create.ucsb.edu' timeout: 30" "NetNameResolver addressForName: '100000jobs.de' timeout: 30" "NetNameResolver addressForName: '1.7.6.4' timeout: 30" "NetNameResolver addressForName: '' timeout: 30 (This seems to return nil?)" | deadline ready success result | "check if this is a valid numeric host address (e.g. 1.2.3.4)" result _ self addressFromString: hostName. result isNil ifFalse: [^result]. "Look up a host name, including ones that start with a digit (e.g. 100000jobs.de or squeak.org)" deadline _ Time millisecondClockValue + (secs * 1000). ready _ self waitForResolverReadyUntil: deadline. ready ifFalse: [^ nil]. self primStartLookupOfName: hostName. success _ self waitForCompletionUntil: deadline. success ifTrue: [^ self primNameLookupResult] ifFalse: [^ nil]. ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverError ^self primNameResolverError ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverStatus ^self primNameResolverStatus ! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'tk 2/15/1999 14:35'! haveNetwork "Our best estimate of whether a network is available. Caller will want to ask user if we should try this time." HaveNetwork ifFalse: [^ false]. Time totalSeconds - LastContact > 1800 "30 min" ifTrue: [^ #expired]. ^ true "are current"! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'tk 2/15/1999 14:47'! haveNetwork: boolean "Allow user to say we don't want to try to start a connection. Not enforced. Only for caller's information when he asks." HaveNetwork _ boolean. LastContact _ Time totalSeconds.! ! !NetNameResolver class methodsFor: 'network initialization' stamp: 'JMM 5/3/2000 11:35'! initializeNetworkIfFail: errorBlock "Initialize the network drivers and record the semaphore to be used by the resolver. Do nothing if the network is already initialized. Evaluate the given block if network initialization fails." "NetNameResolver initializeNetworkIfFail: [self error: 'network initialization failed']" | semaIndex result | self resolverStatus = ResolverUninitialized ifFalse: [ LastContact _ Time totalSeconds. HaveNetwork _ true. ^ self]. "network is already initialized" LastContact _ Time totalSeconds. HaveNetwork _ false. "in case abort" ResolverSemaphore _ Semaphore new. semaIndex _ Smalltalk registerExternalObject: ResolverSemaphore. Utilities informUser: 'Initializing the network drivers; this may take up to 30 seconds and can''t be interrupted' during: [result _ self primInitializeNetwork: semaIndex]. Smalltalk isMorphic ifTrue: [World displayWorld]. "take the informer down" "result is nil if network initialization failed, self if it succeeds" result ifNil: [errorBlock value] ifNotNil: [HaveNetwork _ true]. ! ! !NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 13:57'! readDecimalByteFrom: aStream "Read a positive, decimal integer from the given stream. Stop when a non-digit or end-of-stream is encountered. Return nil if stream is not positioned at a decimal digit or if the integer value read exceeds 255. JMM - 000503 fixed didn't work correctly" | digitSeen value digit | digitSeen _ false. value _ 0. [aStream atEnd] whileFalse: [digit _ aStream next digitValue. (digit < 0 or: [digit > 9]) ifTrue: [ aStream skip: -1. (digitSeen not or: [value > 255]) ifTrue: [^ nil]. ^ value]. digitSeen _ true. value _ (value * 10) + digit]. (digitSeen not or: [value > 255]) ifTrue: [^ nil]. ^ value ! ! !NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:35'! waitForCompletionUntil: deadline "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is ready, false if the network is not initialized or the resolver does not become free within the given time period." | status | status _ self resolverStatus. [(status = ResolverBusy) and: [Time millisecondClockValue < deadline]] whileTrue: [ "wait for resolver to be available" ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). status _ self resolverStatus]. status = ResolverReady ifTrue: [^ true] ifFalse: [ status = ResolverBusy ifTrue: [self primAbortLookup]. ^ false]. ! ! !NetNameResolver class methodsFor: 'private' stamp: 'JMM 5/3/2000 11:36'! waitForResolverReadyUntil: deadline "Wait up to the given number of seconds for the resolver to be ready to accept a new request. Return true if the resolver is not busy, false if the network is not initialized or the resolver does not become free within the given time period." | status | status _ self resolverStatus. status = ResolverUninitialized ifTrue: [^ false]. [(status = ResolverBusy) and: [Time millisecondClockValue < deadline]] whileTrue: [ "wait for resolver to be available" ResolverSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). status _ self resolverStatus]. ^ status ~= ResolverBusy ! ! A handle used for resizing SystemWindows and their panes. ! !NewHandleMorph methodsFor: 'all' stamp: 'sw 11/5/1998 10:24'! initialize waitingForClickInside _ true. super initialize. Preferences noviceMode ifTrue: [self setBalloonText: 'stretch']! ! !NewHandleMorph methodsFor: 'all' stamp: 'di 4/30/1999 14:06'! justDroppedInto: aMorph event: anEvent "No dropping behavior because stepping will delete me. Moreover it needs to be done that way to evaluate lastPointBlock" ! ! A Paragraph represents text that has been laid out, or composed, in some container. text A Text with encoded per-character emphasis. textStyle A TextStyle with font set, line height and horizontal alignment. firstCharacterIndex The starting index in text for this paragraph, allowing composition of a long text into a number of containers. container A Rectangle or TextContainer that determines where text can go. lines An Array of TextLines comprising the final layout of the text after it has been composed within its container. positionWhenComposed As its name implies. Allows display at new locations without the need to recompose the text. Lines are ordered vertically. However, for a given y, there may be several lines in left to right order. Lines must never be empty, even if text is empty.! !NewParagraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'! numberOfLines ^lines size! ! !NewParagraph methodsFor: 'composition' stamp: 'di 4/28/1999 10:26'! composeAll self composeLinesFrom: firstCharacterIndex to: text size delta: 0 into: OrderedCollection new priorLines: Array new atY: container top! ! !NewParagraph methodsFor: 'composition' stamp: 'ar 5/18/2000 18:34'! composeLinesFrom: start to: stop delta: delta into: lineColl priorLines: priorLines atY: startingY "While the section from start to stop has changed, composition may ripple all the way to the end of the text. However in a rectangular container, if we ever find a line beginning with the same character as before (ie corresponding to delta in the old lines), then we can just copy the old lines from there to the end of the container, with adjusted indices and y-values" | charIndex lineY lineHeight scanner line row firstLine lineHeightGuess saveCharIndex hitCR maybeSlide sliding bottom priorIndex priorLine | charIndex _ start. lines _ lineColl. lineY _ startingY. lineHeightGuess _ textStyle lineGrid. maxRightX _ container left. maybeSlide _ stop < text size and: [container isMemberOf: Rectangle]. sliding _ false. priorIndex _ 1. bottom _ container bottom. scanner _ CompositionScanner new text: text textStyle: textStyle. firstLine _ true. [charIndex <= text size and: [(lineY + lineHeightGuess) <= bottom]] whileTrue: [sliding ifTrue: ["Having detected the end of rippling recoposition, we are only sliding old lines" priorIndex < priorLines size ifTrue: ["Adjust and re-use previously composed line" priorIndex _ priorIndex + 1. priorLine _ (priorLines at: priorIndex) slideIndexBy: delta andMoveTopTo: lineY. lineColl addLast: priorLine. lineY _ priorLine bottom. charIndex _ priorLine last + 1] ifFalse: ["There are no more priorLines to slide." sliding _ maybeSlide _ false]] ifFalse: [lineHeight _ lineHeightGuess. saveCharIndex _ charIndex. hitCR _ false. row _ container rectanglesAt: lineY height: lineHeight. 1 to: row size do: [:i | (charIndex <= text size and: [hitCR not]) ifTrue: [line _ scanner composeFrom: charIndex inRectangle: (row at: i) firstLine: firstLine leftSide: i=1 rightSide: i=row size. lines addLast: line. (text at: line last) = Character cr ifTrue: [hitCR _ true]. lineHeight _ lineHeight max: line lineHeight. "includes font changes" charIndex _ line last + 1]]. row size >= 1 ifTrue: [lineY _ lineY + lineHeight. lineY > bottom ifTrue: ["Oops -- the line is really too high to fit -- back out" charIndex _ saveCharIndex. row do: [:r | lines removeLast]] ifFalse: ["It's OK -- the line still fits." maxRightX _ maxRightX max: scanner rightX. 1 to: row size - 1 do: "Adjust heights across row if necess" [:i | (lines at: lines size - row size + i) lineHeight: lines last lineHeight baseline: lines last baseline]. charIndex > text size ifTrue: ["end of text" hitCR ifTrue: ["If text ends with CR, add a null line at the end" ((lineY + lineHeightGuess) <= container bottom) ifTrue: [row _ container rectanglesAt: lineY height: lineHeightGuess. row size > 0 ifTrue: [line _ (TextLine start: charIndex stop: charIndex-1 internalSpaces: 0 paddingWidth: 0) rectangle: row first; lineHeight: lineHeightGuess baseline: textStyle baseline. lines addLast: line]]]. lines _ lines asArray. ^ maxRightX]. firstLine _ false]] ifFalse: [lineY _ lineY + lineHeight]. (maybeSlide and: [charIndex > stop]) ifTrue: ["Check whether we are now in sync with previously composed lines" [priorIndex < priorLines size and: [(priorLines at: priorIndex) first < (charIndex - delta)]] whileTrue: [priorIndex _ priorIndex + 1]. (priorLines at: priorIndex) first = (charIndex - delta) ifTrue: ["Yes -- next line will have same start as prior line." priorIndex _ priorIndex - 1. maybeSlide _ false. sliding _ true] ifFalse: [priorIndex = priorLines size ifTrue: ["Weve reached the end of priorLines, so no use to keep looking for lines to slide." maybeSlide _ false]]]]]. firstLine ifTrue: ["No space in container or empty text" line _ (TextLine start: start stop: start-1 internalSpaces: 0 paddingWidth: 0) rectangle: (container topLeft extent: 0@lineHeightGuess); lineHeight: lineHeightGuess baseline: textStyle baseline. lines _ Array with: line]. "end of container" lines _ lines asArray. ^ maxRightX! ! !NewParagraph methodsFor: 'composition' stamp: 'di 4/28/1999 10:13'! recomposeFrom: start to: stop delta: delta "Recompose this paragraph. The altered portion is between start and stop. Recomposition may continue to the end of the text, due to a ripple effect. Delta is the amount by which the current text is longer than it was when its current lines were composed." | startLine newLines | "Have to recompose line above in case a word-break was affected." startLine _ (self lineIndexForCharacter: start) - 1 max: 1. [startLine > 1 and: [(lines at: startLine-1) top = (lines at: startLine) top]] whileTrue: [startLine _ startLine - 1]. "Find leftmost of line pieces" newLines _ OrderedCollection new: lines size + 1. 1 to: startLine-1 do: [:i | newLines addLast: (lines at: i)]. self composeLinesFrom: (lines at: startLine) first to: stop delta: delta into: newLines priorLines: lines atY: (lines at: startLine) top! ! !NewParagraph methodsFor: 'selection' stamp: 'ar 5/18/2000 18:33'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for the character in the text at aPoint." | line | line _ lines at: (self lineIndexForPoint: aPoint). ^ (CharacterBlockScanner new text: text textStyle: textStyle) characterBlockAtPoint: aPoint index: nil in: line! ! !NewParagraph methodsFor: 'selection' stamp: 'ar 5/18/2000 18:33'! characterBlockForIndex: index "Answer a CharacterBlock for the character in text at index." | line | line _ lines at: (self lineIndexForCharacter: index). ^ (CharacterBlockScanner new text: text textStyle: textStyle) characterBlockAtPoint: nil index: ((index max: line first) min: text size+1) in: line! ! !NewParagraph methodsFor: 'selection' stamp: 'di 10/5/1998 12:59'! defaultCharacterBlock ^ (CharacterBlock new stringIndex: firstCharacterIndex text: text topLeft: lines first topLeft extent: 0 @ 0) textLine: lines first! ! !NewParagraph methodsFor: 'selection' stamp: 'di 6/7/2000 16:52'! selectionRectsFrom: characterBlock1 to: characterBlock2 "Return an array of rectangles representing the area between the two character blocks given as arguments." | line1 line2 rects cb1 cb2 w | characterBlock1 <= characterBlock2 ifTrue: [cb1 _ characterBlock1. cb2 _ characterBlock2] ifFalse: [cb2 _ characterBlock1. cb1 _ characterBlock2]. cb1 = cb2 ifTrue: [w _ self caretWidth. ^ Array with: (cb1 topLeft - (w@0) corner: cb1 bottomLeft + ((w+1)@0))]. line1 _ self lineIndexForCharacter: cb1 stringIndex. line2 _ self lineIndexForCharacter: cb2 stringIndex. line1 = line2 ifTrue: [^ Array with: (cb1 topLeft corner: cb2 bottomRight)]. rects _ OrderedCollection new. rects addLast: (cb1 topLeft corner: (lines at: line1) bottomRight). (container isMemberOf: Rectangle) ifTrue: [(line1+1) <= (line2-1) ifTrue: [rects addLast: ((lines at: line1+1) topLeft corner: (lines at: line2-1) bottomRight)]] ifFalse: [(line1+1) to: (line2-1) do: [:i | rects addLast: (lines at: i) rectangle]]. rects addLast: ((lines at: line2) topLeft corner: cb2 bottomLeft). ^ rects! ! !NewParagraph methodsFor: 'editing' stamp: 'sw 12/7/1999 11:34'! clickAt: clickPoint for: model controller: editor "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | startBlock action target | action _ false. startBlock _ self characterBlockAtPoint: clickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) do: [:att | att mayActOnClick ifTrue: [ " range _ text rangeOf: att startingAt: startBlock stringIndex. boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) to: (self characterBlockForIndex: range last). box _ boxes detect: [:each | each containsPoint: clickPoint]. *This doesn't work in morphic* Need to replace by a highlighting morph that waits for moueUp. Utilities awaitMouseUpIn: (editor transform invertRect: box) repeating: [] ifSucceed: [(att actOnClickFor: model) ifTrue: [action _ true]]. " (target _ model) ifNil: [target _ editor morph]. (att actOnClickFor: target) ifTrue: [Sensor waitNoButton. "FIX THIS" action _ true]]]. ^ action! ! !NewParagraph methodsFor: 'editing' stamp: 'di 4/28/1999 10:14'! replaceFrom: start to: stop with: aText displaying: displayBoolean "Edit the text, and then recompose the lines." text replaceFrom: start to: stop with: aText. self recomposeFrom: start to: start + aText size - 1 delta: aText size - (stop-start+1)! ! !NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:05'! displaySelectionInLine: line on: aCanvas | leftX rightX w caretColor | selectionStart ifNil: [^ self]. "No selection" selectionStart = selectionStop ifTrue: ["Only show caret on line where clicked" selectionStart textLine ~= line ifTrue: [^ self]] ifFalse: ["Test entire selection before or after here" (selectionStop stringIndex < line first or: [selectionStart stringIndex > (line last+1)]) ifTrue: [^ self]. "No selection on this line" (selectionStop stringIndex = line first and: [selectionStop textLine ~= line]) ifTrue: [^ self]. "Selection ends on line above" (selectionStart stringIndex = (line last+1) and: [selectionStop textLine ~= line]) ifTrue: [^ self]]. "Selection begins on line below" selectionStart stringIndex < line first ifTrue: [leftX _ line left] ifFalse: [leftX _ selectionStart left]. (selectionStop stringIndex > (line last+1) or: [selectionStop stringIndex = (line last+1) and: [selectionStop textLine ~= line]]) ifTrue: [rightX _ line right] ifFalse: [rightX _ selectionStop left]. selectionStart = selectionStop ifTrue: [rightX _ rightX + 1. w _ self caretWidth. caretColor _ self insertionPointColor. 1 to: w do: [:i | "Draw caret triangles at top and bottom" aCanvas fillRectangle: ((leftX-w+i-1)@(line top+i-1) extent: (w-i*2+3)@1) color: caretColor. aCanvas fillRectangle: ((leftX-w+i-1)@(line bottom-i) extent: (w-i*2+3)@1) color: caretColor]. aCanvas fillRectangle: (leftX@line top corner: rightX@line bottom) color: caretColor] ifFalse: [aCanvas fillRectangle: (leftX@line top corner: rightX@line bottom) color: self selectionColor] ! ! !NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:04'! insertionPointColor ^ Display depth <= 2 ifTrue: [Color black] ifFalse: [Preferences insertionPointColor]! ! !NewParagraph methodsFor: 'display' stamp: 'sw 9/7/1999 13:03'! selectionColor Display depth = 1 ifTrue: [^ Color veryLightGray]. Display depth = 2 ifTrue: [^ Color gray]. ^ Preferences textHighlightColor! ! !NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:30'! indentationOfLineIndex: lineIndex ifBlank: aBlock "Answer the number of leading tabs in the line at lineIndex. If there are no visible characters, pass the number of tabs to aBlock and return its value. If the line is word-wrap overflow, back up a line and recur." | arrayIndex first last cr | cr _ Character cr. arrayIndex _ lineIndex. [first _ (lines at: arrayIndex) first. first > 1 and: [(text string at: first - 1) ~~ cr]] whileTrue: "word wrap" [arrayIndex _ arrayIndex - 1]. last _ (lines at: arrayIndex) last. ^(text string copyFrom: first to: last) indentationIfBlank: aBlock. ! ! !NewParagraph methodsFor: 'private' stamp: 'RAA 8/30/1998 15:04'! lineIndexOfCharacterIndex: characterIndex "Answer the line index for a given characterIndex." "apparently the selector changed with NewParagraph" ^self lineIndexForCharacter: characterIndex ! ! I represent a controller that never wants control. I am the controller for views that are non-interactive.! !NoteEvent methodsFor: 'accessing' stamp: 'jm 8/27/1998 16:38'! endTime ^ time + duration ! ! !NoteEvent methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:06'! pitch "Convert my MIDI key number to a pitch and return it." ^ AbstractSound pitchForMIDIKey: midiKey ! ! !NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:58'! endNoteOnMidiPort: aMidiPort "Output a noteOff event to the given MIDI port. (Actually, output a noteOff event with zero velocity. This does the same thing, but allows running status to be used when sending a mixture of note on and off commands.)" aMidiPort midiCmd: 16r90 channel: channel byte: midiKey byte: 0. ! ! !NoteEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 15:56'! startNoteOnMidiPort: aMidiPort "Output a noteOn event to the given MIDI port." aMidiPort midiCmd: 16r90 channel: channel byte: midiKey byte: velocity. ! ! I am an abstract representation of a number. My subclasses Float, Fraction, and Integer, and their subclasses, provide concrete representations of a numeric quantity. All my subclasses participate in a simple type coercion mechanism that supports mixed-mode arithmetic and comparisons. It works as follows: If self<typeA> op: arg<typeB> fails because of incompatible types, then it is retried in the following guise: (arg adaptTypeA: self) op: arg adaptToTypeA. This gives the arg of typeB an opportunity to resolve the incompatibility, knowing exactly what two types are involved. If self is more general, then arg will be converted, and viceVersa. This mechanism is extensible to any new number classes that one might wish to add to Squeak. The only requirement is that every subclass of Number must support a pair of conversion methods specific to each of the other subclasses of Number.! !Number methodsFor: 'mathematical functions' stamp: 'jsp 2/24/1999 15:20'! arcTan: denominator "The receiver is the tangent of an angle. Answer the angle measured in radians." ^(self asFloat) arcTan: denominator.! ! !Number methodsFor: 'mathematical functions' stamp: 'di 9/8/1998 17:10'! log "Answer the base-10 log of the receiver." ^self asFloat log! ! !Number methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:35'! raisedTo: aNumber "Answer the receiver raised to aNumber." aNumber isInteger ifTrue: ["Do the special case of integer power" ^ self raisedToInteger: aNumber]. self < 0 ifTrue: [ self error: self printString, ' raised to a non-integer power' ]. aNumber = 0 ifTrue: [^ 1]. "Special case of exponent=0" (self = 0) | (aNumber = 1) ifTrue: [^ self]. "Special case of exponent=1" ^ (aNumber * self ln) exp "Otherwise use logarithms"! ! !Number methodsFor: 'mathematical functions' stamp: 'RJ 3/15/1999 19:32'! raisedToInteger: anInteger "Answer the receiver raised to the power anInteger where the argument must be a kind of Integer. This is a special case of raisedTo:." anInteger isInteger ifFalse: [^self error: 'raisedToInteger: only works for integral arguments']. anInteger = 0 ifTrue: [^ 1]. (self = 0) | (anInteger = 1) ifTrue: [^ self]. anInteger > 1 ifTrue: [^ (self * self raisedToInteger: anInteger // 2) * (self raisedToInteger: anInteger \\ 2)]. ^ (self raisedToInteger: anInteger negated) reciprocal! ! !Number methodsFor: 'truncation and round off' stamp: 'di 10/4/1999 08:08'! roundTo: quantum "Answer the nearest number that is a multiple of quantum." ^(self / quantum) rounded * quantum! ! !Number methodsFor: 'testing' stamp: 'sw 12/30/1998 13:21'! isDivisibleBy: aNumber aNumber = 0 ifTrue: [^ false]. aNumber isInteger ifFalse: [^ false]. ^ (self \\ aNumber) = 0! ! !Number methodsFor: 'testing'! isZero ^self = 0! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:21'! adaptToFloat: rcvr andSend: selector "If I am involved in arithmetic with a Float, convert me to a Float." ^ rcvr perform: selector with: self asFloat! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert us and evaluate exprBlock." ^ self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToInteger: rcvr andSend: selector "If I am involved in arithmetic with a Integer, convert us and evaluate exprBlock." ^ self subclassResponsibility! ! !Number methodsFor: 'converting' stamp: 'di 11/6/1998 13:44'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a Point, convert me to a Point." ^ rcvr perform: selector with: self@self! ! !Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'! asNumber ^ self! ! !Number methodsFor: 'converting' stamp: 'sw 10/7/1999 12:24'! asSmallPositiveDegrees "Return the receiver normalized to lie within the range (0, 360)" | result | result _ self. [result < 0] whileTrue: [result _ result + 360]. ^ result \\ 360 "#(-500 -300 -150 -5 0 5 150 300 500 1200) collect: [:n | n asSmallPositiveDegrees]"! ! !Number methodsFor: 'intervals' stamp: 'tao 1/30/1999 08:58'! to: stop by: step do: aBlock "Normally compiled in-line, and therefore not overridable. Evaluate aBlock for each element of the interval (self to: stop by: step)." | nextValue | nextValue _ self. step = 0 ifTrue: [self error: 'step must be non-zero']. step < 0 ifTrue: [[stop <= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]] ifFalse: [[stop >= nextValue] whileTrue: [aBlock value: nextValue. nextValue _ nextValue + step]]! ! !Number methodsFor: 'printing' stamp: 'sw 6/29/1999 21:10'! isOrAreStringWith: aNoun | result | result _ self = 1 ifTrue: [' is one '] ifFalse: [self = 0 ifTrue: [' are no '] ifFalse: [' are ', self printString, ' ']]. result _ result, aNoun. self = 1 ifFalse: [result _ result, 's']. ^ result "#(0 1 2 98.6) do: [:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! ! !Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'! stringForReadout ^ self rounded printString! ! !Number class methodsFor: 'instance creation' stamp: 'bf 12/9/1998 19:21'! readFrom: stringOrStream "Answer a number as described on aStream. The number may include a leading radix specification, as in 16rFADE" | value base aStream sign | aStream _ (stringOrStream isMemberOf: String) ifTrue: [ReadStream on: stringOrStream] ifFalse: [stringOrStream]. (aStream nextMatchAll: 'NaN') ifTrue: [^ Float nan]. sign _ (aStream peekFor: $-) ifTrue: [-1] ifFalse: [1]. (aStream nextMatchAll: 'Infinity') ifTrue: [^ Float infinity * sign]. base _ 10. value _ Integer readFrom: aStream base: base. (aStream peekFor: $r) ifTrue: ["<base>r<integer>" (base _ value) < 2 ifTrue: [^self error: 'Invalid radix']. (aStream peekFor: $-) ifTrue: [sign _ sign negated]. value _ Integer readFrom: aStream base: base]. ^ self readRemainderOf: value from: aStream base: base withSign: sign.! ! A simple, 32-bit, direct-pointer, garbage-collected object memory. An "oop" (object-oriented pointer) is an object reference. There are three kinds of oop: 1. The oop 0 represent nil. 2. An oop whose least significant bit is zero points to an object in memory. (Objects always begin at an even memory address.) 3. An oop whose least significant bit is one represents a signed integer (a SmallInteger) whose value is it's top 31-bits. ! !ObjMem methodsFor: 'initialization' stamp: 'jm 10/19/2006 10:17'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." "This version tranlates to C code that calls malloc()." | roundedByteCount | roundedByteCount _ (byteCount + 7) bitAnd: AllButHeaderTypeBits. memStart _ self cCode: '(int) malloc(roundedByteCount)'. memStart = 0 ifTrue: [^ self error: 'could not allocate memory']. memEnd _ memStart + roundedByteCount. freeBlock _ memStart. self longAt: freeBlock put: (roundedByteCount bitOr: HeaderTypeFree). ! ! !ObjMem methodsFor: 'small integers' stamp: 'jm 10/2/2006 22:44'! isIntegerOop: oop ^ (oop bitAnd: 1) ~= 0 ! ! !ObjMem methodsFor: 'small integers' stamp: 'jm 9/20/2006 08:39'! isObjectOop: oop ^ (oop bitAnd: 1) = 0 ! ! !ObjMem methodsFor: 'object access' stamp: 'jm 9/24/2006 20:14'! classIndex: oop "Answer the class index for the given object. The class index is an index into a one-based array of class objects." oop = NilOop ifTrue: [^ NilClassIndex]. (self isIntegerOop: oop) ifTrue: [^ SmallIntegerClassIndex]. ^ ((self longAt: oop) bitAnd: ClassIndexMask) >> ClassIndexShift ! ! !ObjMem methodsFor: 'object access' stamp: 'jm 10/2/2006 20:40'! objectSize: objectOop "Answer the size (in bytes) of the given object, including its object header word(s). Assume that the oop points to a real object, not nil or a small integer." | header | header _ self longAt: objectOop. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [^ self longAt: objectOop + 4] ifFalse: [^ (header bitAnd: ObjSizeMask) >> ObjSizeShift] ! ! !ObjMem methodsFor: 'object access' stamp: 'jm 10/14/2006 21:36'! oopAt: index in: oop "Return the oop at the given index of the given object. The object must be pointers." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self error: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 4] ifFalse: [offset _ 0]. ^ self longAt: oop + offset + (4 * index) ! ! !ObjMem methodsFor: 'object access' stamp: 'jm 10/14/2006 21:36'! oopAt: index put: oopToStore in: oop "Store the given oop at the given index of the given object. The object must be pointers." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self error: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 4] ifFalse: [offset _ 0]. ^ self longAt: oop + offset + (4 * index) put: oopToStore ! ! !ObjMem methodsFor: 'allocation' stamp: 'jm 10/2/2006 20:38'! allocate: byteCount format: format classIndex: classIndex "Allocate an object of the given size and class." | baseHeader newOop | baseHeader _ (((byteCount << ObjSizeShift) bitAnd: ObjSizeMask) bitOr: ((format << FormatShift) bitAnd: FormatMask)) bitOr: ((classIndex << ClassIndexShift) bitAnd: ClassIndexMask). byteCount > 4095 ifTrue: [ "large object: two-word header" newOop _ self allocateChunk: byteCount + 8. "+8 for two header words" baseHeader _ baseHeader bitAnd: AllButObjSizeBits. "zero out size field" self longAt: newOop put: (baseHeader bitOr: HeaderTypeTwoWord). self longAt: newOop + 4 put: byteCount] "second header word holds object size" ifFalse: [ "normal object: one-word header" newOop _ self allocateChunk: byteCount + 4. "+4 for one header word" self longAt: newOop put: (baseHeader bitOr: HeaderTypeOneWord)]. ^ newOop ! ! !ObjMem methodsFor: 'allocation' stamp: 'jm 10/2/2006 20:33'! allocateChunk: byteCount "Allocate and zero a chunk of memory of the given size The given byte count should include the header word(s) for the new object being created." "Note: The size stored in the header word of a free chunk or object does not include the header words(s)." | roundedByteCount freeBytes newChunk | roundedByteCount _ (byteCount + 3) bitAnd: AllButHeaderTypeBits. "round up to word boundary" freeBytes _ (self longAt: freeBlock) bitAnd: AllButHeaderTypeBits. roundedByteCount >= freeBytes ifTrue: [self error: 'out of memory']. newChunk _ freeBlock. freeBlock _ freeBlock + roundedByteCount. newChunk + 4 to: freeBlock - 4 by: 4 do: [:i | self longAt: i put: 0]. self longAt: newChunk put: ((roundedByteCount - 4) bitOr: HeaderTypeFree). self longAt: freeBlock put: ((freeBytes - roundedByteCount) bitOr: HeaderTypeFree). ^ newChunk ! ! !ObjMem methodsFor: 'enumeration' stamp: 'jm 10/3/2006 20:23'! chunkSize: ptr "Return the number of bytes for this object or free chunk. Used when scanning the object memory. Assume the given ptr is not nil or a SmallInteger." ^ self chunkSize: ptr header: (self longAt: ptr) ! ! !ObjMem methodsFor: 'enumeration' stamp: 'jm 10/3/2006 20:17'! chunkSize: ptr header: header "Return the number of bytes for this object or free chunk. Used when scanning the object memory. Assume the given ptr is not nil or a SmallInteger." "Details: The most common cases are tested first." | type realHeader | type _ header bitAnd: HeaderTypeMask. HeaderTypeOneWord = type ifTrue: [ "+4 for object header word and +3 to round up to word boundary" ^ (((header bitAnd: ObjSizeMask) >> ObjSizeShift) + 7) bitAnd: AllButHeaderTypeBits]. HeaderTypeFree = type ifTrue: [ "+4 for free chunk header" ^ (header bitAnd: AllButHeaderTypeBits) + 4]. HeaderTypeTwoWord = type ifTrue: [ "+8 for object header words and +3 to round up to word boundary" ^ ((self longAt: ptr + 4) + 11) bitAnd: AllButHeaderTypeBits]. HeaderTypeForward = type ifTrue: [ "forwarded object: get the real header from the forwarding table entry" realHeader _ self longAt: ((header bitAnd: AllButHeaderTypeBits) + 4). type _ realHeader bitAnd: HeaderTypeMask. type = HeaderTypeOneWord ifTrue: [^ (((realHeader bitAnd: ObjSizeMask) >> ObjSizeShift) + 7) bitAnd: AllButHeaderTypeBits] ifFalse: [^ ((self longAt: ptr + 4) + 11) bitAnd: AllButHeaderTypeBits]]. ! ! !ObjMem methodsFor: 'enumeration' stamp: 'jm 10/3/2006 20:23'! objectAfter: anOop "If anOop is nil, return the first object in memory (of any class). Otherwise, return the next object after the given oop, or NilOop if there is none." | ptr header | (anOop bitAnd: 1) ~= 0 ifTrue: [^ NilOop]. "anOop is a SmallInteger" anOop = NilOop ifTrue: [ptr _ memStart] ifFalse: [ptr _ anOop + (self chunkSize: anOop)]. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. (header bitAnd: HeaderTypeIsObjectBit) ~= 0 ifTrue: [^ ptr]. ptr _ ptr + (self chunkSize: anOop header: header)]. ^ NilOop ! ! !ObjMem methodsFor: 'enumeration' stamp: 'jm 10/2/2006 20:40'! objectAfter: anOop withClassIndex: cIndex "If anOop is nil, return the first object in memory of the given class. Otherwise, return the next object of the given class after the given oop, or NilOop if there is none. " | oop | oop _ self objectAfter: anOop. [true] whileTrue: [ oop = NilOop ifTrue: [^ NilOop]. cIndex = (((self longAt: oop) bitAnd: ClassIndexMask) >> ClassIndexShift) ifTrue: [^ oop]. oop _ self objectAfter: oop]. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/14/2006 21:14'! compact "Compact memory by sliding surviving objects down so that all the free space is consolidated into one large chunk. Assume that marking has been done and that unmarked objects should be reclaimed." "Details: If there are enough forwarding table entries for all surviving objects, this process can be done in three passes over memory: a. sweep memory, making forwarding table entries for surviving objects b. apply the forwarding table to update pointers in all objects to point to the new object locations c. slide the surviving objects down to their new locations However, if there are not enough forwarding table entries we must repeat this process, moving as many objects as possible each time. A growing chunk of newly freed memory bubbles up through the objects until finally it is at the end of all the objects. At that point memory is compact." | sweepStart sweepEnd | sweepStart _ memStart. [sweepStart < freeBlock] whileTrue: [ sweepEnd _ self sweepAndMakeForwardingEntriesFrom: sweepStart. self applyForwardingTable. sweepStart _ self moveObjectsFrom: sweepStart to: sweepEnd]. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/15/2006 20:04'! garbageCollectRoot: rootOop "Do a full garbage collection. Objects not reachable from the given root are reclaimed and memory is compacted." "Details: In the extremely unlikely event of overflowing the mark stack during marking, we recover by scanning memory for partially marked objects and treating those objects as the roots of another mark pass. This process eventually find all the live objects." | ptr header | "mark phase" self initMarkingStack. self markRoot: rootOop. self markLoop. [markStackOverflowed] whileTrue: [ "extremely rare case: mark stack overflowed" self initMarkingStack. ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. (((header bitAnd: HeaderTypeIsObjectBit) ~= 0) and: [(header bitAnd: MarkBitsMask) = MarkBit]) ifTrue: [ self mark: ptr. self markLoop]. ptr _ ptr + (self chunkSize: ptr header: header)]]. "sweep/compact phase" self compact. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 9/26/2006 23:31'! initMarkingStack "Initialize the marking stack immediately after the last object." markStackBase _ markStackPtr _ freeBlock + 4. markStackOverflowed _ false. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/2/2006 21:43'! mark: memoryOop "Mark the given object. Assume that memoryOop refers to a real object (not nil or a SmallInteger)." "Note: The 'mark' bit means an object is accessible and that it has been added to the mark stack for further processing. The 'marking done' bit means that all pointer-containing fields of the object have been traced." | header first last thisOop thisHdr | header _ self longAt: memoryOop. (header bitAnd: HasPointersBit) = 0 ifTrue: [ self longAt: memoryOop put: (header bitOr: MarkBitsMask). "no pointers to process" ^ 0]. (header bitAnd: HeaderTypeMask) = HeaderTypeOneWord ifTrue: [ "one word header" first _ memoryOop + 4. last _ memoryOop + ((header bitAnd: ObjSizeMask) >> ObjSizeShift)] ifFalse: [ "two word header" first _ memoryOop + 8. last _ memoryOop + (self longAt: memoryOop + 4) + 4]. first to: last by: 4 do: [:ptr | thisOop _ self longAt: ptr. ((thisOop ~= NilOop) and: [self isObjectOop: thisOop]) ifTrue: [ thisHdr _ self longAt: thisOop. (thisHdr bitAnd: MarkBit) = 0 ifTrue: [ (thisHdr bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process; mark it and be done" self longAt: thisOop put: (thisHdr bitOr: MarkBitsMask)] ifFalse: [ "oop contains pointers, put it on the stack to be scanned" self longAt: thisOop put: (thisHdr bitOr: MarkBit). markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: thisOop. markStackPtr _ markStackPtr + 4]]]]]. "record that this object has been fully traced" self longAt: memoryOop put: (header bitOr: MarkBitsMask). ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 9/27/2006 22:58'! markLoop "Mark all accessible objects starting with the root objects on the mark stack." | thisOop | [markStackPtr > markStackBase] whileTrue: [ markStackPtr _ markStackPtr - 4. thisOop _ self longAt: markStackPtr. self mark: thisOop]. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/1/2006 19:10'! markRoot: memoryOop "Mark the given root object. If it contains pointers, add it to the mark stack to be processed later. Assume that the oop is a real memory object (not nil or a SmallInteger)." | header | header _ self longAt: memoryOop. (header bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process" self longAt: memoryOop put: (header bitOr: MarkBitsMask). ^ 0]. self longAt: memoryOop put: (header bitOr: MarkBit). markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: memoryOop. markStackPtr _ markStackPtr + 4]. ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/3/2006 21:47'! moveObjectsFrom: startPtr to: endPtr "Slide down objects to compact memory starting and ending at the given chunk addresses. Return the start of the chunk immediately following the last object moved." | ptr dstPtr byteCount header | ptr _ dstPtr _ startPtr. [ptr < endPtr] whileTrue: [ header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ header _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4. self longAt: ptr put: header]. byteCount _ self chunkSize: ptr header: header. (header bitAnd: HeaderTypeIsObjectBit) ~= 0 ifTrue: [ "copy object" dstPtr = ptr ifTrue: [dstPtr _ dstPtr + byteCount] "object doesn't need to move" ifFalse: [ ptr to: ptr + byteCount - 4 by: 4 do: [:srcPtr | self longAt: dstPtr put: (self longAt: srcPtr). dstPtr _ dstPtr + 4]]]. ptr _ ptr + byteCount]. dstPtr < endPtr ifTrue: [ byteCount _ (endPtr - dstPtr) bitAnd: AllButHeaderTypeBits. endPtr = freeBlock ifTrue: [ byteCount _ byteCount + (self chunkSize: freeBlock)]. self longAt: dstPtr put: ((byteCount - 4) bitOr: HeaderTypeFree). endPtr = freeBlock ifTrue: [freeBlock _ dstPtr]. ^ dstPtr]. ^ endPtr! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/3/2006 20:29'! survivorAfter: chunkPtr "Return the first surviving object after the given chunk or freeBlock." "Assume: No objects are forwarded." | ptr header | ptr _ chunkPtr + (self chunkSize: chunkPtr). [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. ((header bitAnd: HeaderTypeIsObjectBit) ~= 0 and: [(header bitAnd: MarkBit) ~= 0]) ifTrue: [^ ptr]. ptr _ ptr + (self chunkSize: ptr header: header)]. ^ freeBlock ! ! !ObjMem methodsFor: 'garbage collection' stamp: 'jm 10/15/2006 10:12'! sweepAndMakeForwardingEntriesFrom: sweepStart "Sweep memory and create forwarding table entries for all surviving objects. Clear the mark bits. Consolidate contiguous free blocks to speed up later memory scans." "Details: shiftBytes is the number of bytes by which surviving objects will be shifted down in memory. Thus, newOop = (old oop - shifteBytes)." | shiftBytes ptr header type nextPtr | self initForwardingTable. shiftBytes _ 0. ptr _ sweepStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. ((HeaderTypeFree = type) or: [(header bitAnd: MarkBit) = 0]) ifTrue: [ "garbage" nextPtr _ self survivorAfter: ptr. shiftBytes _ shiftBytes + (nextPtr - ptr). self longAt: ptr put: (((nextPtr - ptr) - 4) bitOr: HeaderTypeFree)] ifFalse: [ "survivor: clear mark bits and set up forward table entry" nextFwdEntry >= (memEnd - 8) ifTrue: [^ ptr]. "out of entries; start next pass here" self longAt: ptr put: (header bitAnd: AllButMarkBits). "clear mark bits" type = HeaderTypeOneWord ifTrue: [nextPtr _ ptr + ((header bitAnd: ObjSizeMask) >> ObjSizeShift) + 4] ifFalse: [nextPtr _ ptr + (((self longAt: ptr + 4) + 3) bitAnd: AllButHeaderTypeBits) + 8]. shiftBytes > 0 ifTrue: [ self forwardOop: ptr to: ptr - shiftBytes]]. ptr _ nextPtr]. ^ ptr ! ! !ObjMem methodsFor: 'forwarding' stamp: 'jm 10/15/2006 11:42'! applyForwardingTable "Update all object references using the forwarding table. Every pointer-containing object is scanned and every forwarded oop in it is replaced with that oop's new location." | ptr header type first last thisOop thisHdr | ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. type = HeaderTypeFree ifTrue: [ptr _ ptr + (header bitAnd: AllButHeaderTypeBits) + 4] ifFalse: [ type = HeaderTypeForward ifTrue: [ "this object is forwarded; get it's actual header" header _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4. type _ header bitAnd: HeaderTypeMask]. (header bitAnd: HeaderTypeMask) = HeaderTypeOneWord ifTrue: [ "one word header" first _ ptr + 4. last _ ptr + ((header bitAnd: ObjSizeMask) >> ObjSizeShift)] ifFalse: [ "two word header" first _ ptr + 8. last _ ptr + (self longAt: ptr + 4) + 4]. (header bitAnd: HasPointersBit) ~= 0 ifTrue: [ first to: last by: 4 do: [:i | thisOop _ self longAt: i. ((thisOop ~= NilOop) and: [self isObjectOop: thisOop]) ifTrue: [ thisHdr _ self longAt: thisOop. (thisHdr bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ self longAt: i put: (self longAt: (thisHdr bitAnd: AllButHeaderTypeBits))]]]]. ptr _ last + 4]]. ! ! !ObjMem methodsFor: 'forwarding' stamp: 'jm 10/14/2006 21:11'! forwardOop: oop to: newOop "Create a forwarding table entry for the given oop." "Details: Allocate a new forwarding table entry. The first word of this entry holds the new oop. The second word holds the original base header word for the given oop. The base header word of the oop is replaced with the address of the forwarding table entry with its low two bits set to HeaderTypeForward." | newEntry | newEntry _ nextFwdEntry. nextFwdEntry _ nextFwdEntry + 8. self longAt: newEntry put: newOop. self longAt: (newEntry + 4) put: (self longAt: oop). "save old header word" self longAt: oop put: (newEntry bitOr: HeaderTypeForward). ! ! !ObjMem methodsFor: 'forwarding' stamp: 'jm 10/14/2006 21:11'! initForwardingTable "Initialize the forwarding table immediately after freeChunk. Return the number of forwarding entries." nextFwdEntry _ freeBlock + 4. ^ (memEnd - nextFwdEntry) // 8 ! ! !ObjMem methodsFor: 'forwarding' stamp: 'jm 10/3/2006 20:24'! restoreHeadersFrom: startPtr to: endPtr "Scan the given range of memory and restore the original header words of forwarded objects." | ptr header | ptr _ startPtr. [ptr < endPtr] whileTrue: [ header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ header _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4. self longAt: ptr put: header]. ptr _ ptr + (self chunkSize: ptr header: header)]. ! ! !ObjMem methodsFor: 'tests' stamp: 'jm 10/15/2006 20:14'! gcTest1 "Allocate an array of N objects mixed with garbage, then do two collections. Shows the difference between a GC that moves N objects versus one that scans all N objects but doesn't move them." | count rootOop savedOop classID | count _ 10000. self initMemByteCount: 500000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. self startTimer. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. self reportTime: 'Test 1, object creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem methodsFor: 'tests' stamp: 'jm 10/15/2006 20:14'! gcTest2 "Create a long linked list of objects mixed with garbage." | count rootOop lastOop thisOop | count _ 10000. self initMemByteCount: 500000. rootOop _ self allocate: 4 format: 3 classIndex: 99. self startTimer. lastOop _ NilOop. 1 to: count do: [:i | thisOop _ self allocate: 4 format: 3 classIndex: 9. self oopAt: 1 put: lastOop in: thisOop. lastOop _ thisOop. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4]. self oopAt: 1 put: lastOop in: rootOop. self reportTime: 'Test 2, Link list creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem methodsFor: 'tests' stamp: 'jm 10/15/2006 20:14'! gcTest3 "Create a binary tree of objects mixed with garbage." | depth rootOop bytesNeeded | depth _ 13. bytesNeeded _ "2 raisedTo: 13" 8192 * (36 + 8). self initMemByteCount: bytesNeeded. self startTimer. rootOop _ self treeDepth: depth. self reportTime: 'Test 3, Tree creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem methodsFor: 'tests' stamp: 'jm 10/15/2006 10:06'! treeDepth: n "Create a binary tree of depth N with garbage. Return the oop of the root." | treeOop | n = 0 ifTrue: [^ NilOop]. treeOop _ self allocate: 8 format: 3 classIndex: 9. self allocate: 4 format: 2 classIndex: 2. "garbage" self oopAt: 1 put: (self treeDepth: n - 1) in: treeOop. self allocate: 4 format: 2 classIndex: 2. "garbage" self oopAt: 2 put: (self treeDepth: n - 1) in: treeOop. self allocate: 4 format: 2 classIndex: 2. "garbage" ^ treeOop ! ! !ObjMem class methodsFor: 'class initialization' stamp: 'jm 10/2/2006 20:37'! initialize "self initialize" "Object pointers point to a base header word with the following format: 2 bits used for gc (mark, markingDone) 12 bits object size in bytes (0-4095; if larger, byte count is stored in extended header) 2 bits object format (0: byte array; 1: word array, 2: pointers, non-indexable; 3 pointers, indexable) 14 bits class table index 2 bits header type (0: normal; 1: two-word; 2: marking; 3: free chunk)" MarkBitsMask _ 16rC0000000. MarkBit _ 16r80000000. MarkingDoneBit _ 16r40000000. ObjSizeMask _ 16r3FFC0000. ObjSizeShift _ 18. FormatMask _ 16r30000. FormatShift _ 16. HasPointersBit _ 16r20000. WordIndexableBit _ 16r10000. ClassIndexMask _ 16rFFFC. ClassIndexShift _ 2. HeaderTypeMask _ 3. HeaderTypeFree _ 0. HeaderTypeForward _ 1. HeaderTypeOneWord _ 2. HeaderTypeTwoWord _ 3. HeaderTypeIsObjectBit _ 2. AllButMarkBits _ MarkBitsMask bitInvert32. AllButObjSizeBits _ ObjSizeMask bitInvert32. AllButHeaderTypeBits _ HeaderTypeMask bitInvert32. NilOop _ 0. NilClassIndex _ 1. SmallIntegerClassIndex _ 2. ! ! !ObjMem class methodsFor: 'translation' stamp: 'jm 10/15/2006 12:10'! translate: fileName doInlining: inlineFlag "ObjMem translate: 'objMem.c' doInlining: false" | cg | ObjMem initialize. cg _ CCodeGenerator new initialize. cg addClass: ObjMem. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! This version of the object memory reserves a forwarding word in each object header that is used to update pointers during compaction and object mutation. While this apparently wastes one word per object we would otherwise need to reserve two words per object to be used for forwarding table entries during compaction or we would need to make multiple passes during compaction. By building the forwarding link into the object header we do not need to reserve extra space for the forwarding table, compaction can always be done in a single pass, and pointer updating can be done with only one memory reference instead of two. ! !ObjMem2 methodsFor: 'initialization' stamp: 'jm 10/19/2006 10:17'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." "This version tranlates to C code that calls malloc()." | roundedByteCount | roundedByteCount _ (byteCount + 7) bitAnd: WordAlignMask. memStart _ self cCode: '(int) malloc(roundedByteCount)'. memStart = 0 ifTrue: [^ self error: 'could not allocate memory']. memEnd _ memStart + roundedByteCount. freeBlock _ memStart. self longAt: freeBlock put: (roundedByteCount bitOr: HeaderTypeFree). ! ! !ObjMem2 methodsFor: 'small integers' stamp: 'jm 10/18/2006 21:30'! isIntegerOop: oop ^ (oop bitAnd: 1) ~= 0 ! ! !ObjMem2 methodsFor: 'small integers' stamp: 'jm 10/18/2006 21:30'! isObjectOop: oop ^ (oop bitAnd: 1) = 0 ! ! !ObjMem2 methodsFor: 'object access' stamp: 'jm 10/18/2006 21:30'! classIndex: oop "Answer the class index for the given object. The class index is an index into a one-based array of class objects." oop = NilOop ifTrue: [^ NilClassIndex]. (self isIntegerOop: oop) ifTrue: [^ SmallIntegerClassIndex]. ^ ((self longAt: oop) bitAnd: ClassIndexMask) >> ClassIndexShift ! ! !ObjMem2 methodsFor: 'object access' stamp: 'jm 10/18/2006 21:45'! objectSize: objectOop "Answer the size (in bytes) of the given object, including its object header word(s). Assume that the oop points to a real object, not nil or a small integer." | header | header _ self longAt: objectOop. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [^ self longAt: objectOop + 8] ifFalse: [^ (header bitAnd: ObjSizeMask) >> ObjSizeShift] ! ! !ObjMem2 methodsFor: 'object access' stamp: 'jm 11/23/2006 22:42'! oopAt: index in: oop "Return the oop at the given index of the given object. The object must be pointers." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self error: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 8] ifFalse: [offset _ 4]. ^ self longAt: oop + offset + (4 * index) ! ! !ObjMem2 methodsFor: 'object access' stamp: 'jm 11/23/2006 22:42'! oopAt: index put: oopToStore in: oop "Store the given oop at the given index of the given object. The object must be pointers." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self error: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 8] ifFalse: [offset _ 4]. ^ self longAt: oop + offset + (4 * index) put: oopToStore ! ! !ObjMem2 methodsFor: 'allocation' stamp: 'jm 10/19/2006 10:21'! allocate: byteCount format: format classIndex: classIndex "Allocate an object of the given size and class." | baseHeader newOop | baseHeader _ (((byteCount << ObjSizeShift) bitAnd: ObjSizeMask) bitOr: ((format << FormatShift) bitAnd: FormatMask)) bitOr: ((classIndex << ClassIndexShift) bitAnd: ClassIndexMask). byteCount > MaxSizeForOneWordHeader ifTrue: [ "large object: two-word header" newOop _ self allocateChunk: byteCount + 12. "+12 for two header words and forward word" baseHeader _ baseHeader bitAnd: AllButObjSizeBits. "zero out size field" self longAt: newOop put: (baseHeader bitOr: HeaderTypeTwoWord). self longAt: newOop + 8 put: byteCount] "extended header word holds object size" ifFalse: [ "normal object: one-word header" newOop _ self allocateChunk: byteCount + 8. "+8 for one header word and forward word" self longAt: newOop put: (baseHeader bitOr: HeaderTypeOneWord)]. ^ newOop ! ! !ObjMem2 methodsFor: 'allocation' stamp: 'jm 10/19/2006 10:11'! allocateChunk: byteCount "Allocate and zero a chunk of memory of the given size The given byte count should include the header word(s) for the new object being created." "Note: The size stored in the header word of a free chunk or object does not include the header words(s)." | roundedByteCount freeBytes newChunk | roundedByteCount _ (byteCount + 3) bitAnd: WordAlignMask. "round up to word boundary" freeBytes _ (self longAt: freeBlock) bitAnd: WordAlignMask. roundedByteCount >= freeBytes ifTrue: [self error: 'out of memory']. newChunk _ freeBlock. freeBlock _ freeBlock + roundedByteCount. newChunk + 4 to: freeBlock - 4 by: 4 do: [:i | self longAt: i put: 0]. self longAt: newChunk put: ((roundedByteCount - 4) bitOr: HeaderTypeFree). self longAt: freeBlock put: ((freeBytes - roundedByteCount) bitOr: HeaderTypeFree). ^ newChunk ! ! !ObjMem2 methodsFor: 'enumeration' stamp: 'jm 11/23/2006 11:35'! chunkSize: ptr header: header "Return the number of bytes for this object or free chunk. Used when scanning the object memory. Assume the given ptr is not nil or a SmallInteger." "Details: The most common cases are tested first." | type | type _ header bitAnd: HeaderTypeMask. HeaderTypeOneWord = type ifTrue: [ "+8 for object header word and forward word and +3 to round up to word boundary" ^ (((header bitAnd: ObjSizeMask) >> ObjSizeShift) + 11) bitAnd: WordAlignMask]. HeaderTypeFree = type ifTrue: [ "+4 for free chunk header" ^ (header bitAnd: WordAlignMask) + 4]. HeaderTypeTwoWord = type ifTrue: [ "+12 for two object header words and forward word and +3 to round up to word boundary" ^ ((self longAt: ptr + 8) + 15) bitAnd: WordAlignMask]. self error: 'unknown header type'. ! ! !ObjMem2 methodsFor: 'enumeration' stamp: 'jm 11/23/2006 10:48'! objectAfter: anOop "If anOop is nil, return the first object in memory (of any class). Otherwise, return the next object after the given oop, or NilOop if there is none." | ptr header | (anOop bitAnd: 1) ~= 0 ifTrue: [^ NilOop]. "anOop is a SmallInteger" anOop = NilOop ifTrue: [ptr _ memStart] ifFalse: [ptr _ anOop + (self chunkSize: anOop header: (self longAt: anOop))]. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) ~= HeaderTypeFree ifTrue: [^ ptr]. ptr _ ptr + (self chunkSize: anOop header: header)]. ^ NilOop ! ! !ObjMem2 methodsFor: 'enumeration' stamp: 'jm 10/18/2006 21:30'! objectAfter: anOop withClassIndex: cIndex "If anOop is nil, return the first object in memory of the given class. Otherwise, return the next object of the given class after the given oop, or NilOop if there is none. " | oop | oop _ self objectAfter: anOop. [true] whileTrue: [ oop = NilOop ifTrue: [^ NilOop]. cIndex = (((self longAt: oop) bitAnd: ClassIndexMask) >> ClassIndexShift) ifTrue: [^ oop]. oop _ self objectAfter: oop]. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/18/2006 22:26'! compact "Compact memory by sliding surviving objects down so that all the free space is consolidated into one large chunk. Assume that marking has been done." "Details: This process is done in three passes: a. sweep memory setting up the forwarding fields of surviving objects b. update oops in all objects to point to the new locations of their target objects c. slide the surviving objects down to their new locations and clear their forwarding fields" self sweepAndSetForwardFields. self updatedForwardedPointers. self moveSurvivors. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/19/2006 10:33'! garbageCollectRoot: rootOop "Do a full garbage collection. Objects not reachable from the given root are reclaimed and memory is compacted." "Details: In the extremely unlikely event of overflowing the mark stack during marking, we recover by scanning memory for partially marked objects and treating those objects as the roots of another mark pass. This process eventually finds all the live objects." | ptr header | "mark phase" self initMarkingStack. self markRoot: rootOop. self markLoop. [markStackOverflowed] whileTrue: [ "extremely rare case: mark stack overflowed" self initMarkingStack. ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. (((header bitAnd: HeaderTypeMask) ~= HeaderTypeFree) and: [((self longAt: ptr + 4) bitAnd: MarkBitsMask) = MarkBit]) ifTrue: [ self mark: ptr. self markLoop]. ptr _ ptr + (self chunkSize: ptr header: header)]]. self compact. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/18/2006 21:30'! initMarkingStack "Initialize the marking stack immediately after the last object." markStackBase _ markStackPtr _ freeBlock + 4. markStackOverflowed _ false. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 11/23/2006 22:12'! mark: memoryOop "Mark the given object. Assume that memoryOop refers to a real object (not nil or a SmallInteger)." "Note: The 'mark' bit means an object is accessible and that it has been added to the mark stack for further processing. The 'marking done' bit means that all pointers in the object have been traced." | header first last thisOop | header _ self longAt: memoryOop. (header bitAnd: HasPointersBit) = 0 ifTrue: [ self longAt: memoryOop + 4 put: MarkBitsMask. "no pointers to process" ^ 0]. (header bitAnd: HeaderTypeMask) = HeaderTypeOneWord ifTrue: [ "one word header" first _ memoryOop + 8. last _ first - 4 + ((header bitAnd: ObjSizeMask) >> ObjSizeShift)] ifFalse: [ "two word header" first _ memoryOop + 12. last _ first - 4 + (self longAt: memoryOop + 8)]. first to: last by: 4 do: [:ptr | thisOop _ self longAt: ptr. ((thisOop ~= NilOop) and: [self isObjectOop: thisOop]) ifTrue: [ ((self longAt: thisOop + 4) bitAnd: MarkBit) = 0 ifTrue: [ ((self longAt: thisOop) bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process; mark it and be done" self longAt: thisOop + 4 put: MarkBitsMask] ifFalse: [ "oop contains pointers, put it on the stack to be scanned" self longAt: thisOop + 4 put: MarkBit. markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: thisOop. markStackPtr _ markStackPtr + 4]]]]]. "record that this object has been fully traced" self longAt: memoryOop + 4 put: MarkBitsMask. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/18/2006 21:30'! markLoop "Mark all accessible objects starting with the root objects on the mark stack." | thisOop | [markStackPtr > markStackBase] whileTrue: [ markStackPtr _ markStackPtr - 4. thisOop _ self longAt: markStackPtr. self mark: thisOop]. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/19/2006 10:49'! markRoot: memoryOop "Mark the given root object. If it contains pointers, add it to the mark stack to be processed later. Assume that the oop is a real memory object (not nil or a SmallInteger)." ((self longAt: memoryOop) bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process" self longAt: memoryOop + 4 put: MarkBitsMask. ^ 0]. self longAt: memoryOop + 4 put: MarkBit. markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: memoryOop. markStackPtr _ markStackPtr + 4]. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 11/23/2006 10:49'! moveSurvivors "Slide down objects to compact memory starting and ending at the given chunk addresses. Return the start of the chunk immediately following the last object moved." | ptr dstPtr byteCount header | ptr _ dstPtr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. byteCount _ self chunkSize: ptr header: header. (header bitAnd: HeaderTypeMask) ~= HeaderTypeFree ifTrue: [ "copy object" self longAt: ptr + 4 put: 0. "clear forwarding link and mark bits" dstPtr = ptr ifTrue: [dstPtr _ dstPtr + byteCount] "object doesn't need to move" ifFalse: [ ptr to: ptr + byteCount - 4 by: 4 do: [:srcPtr | self longAt: dstPtr put: (self longAt: srcPtr). dstPtr _ dstPtr + 4]]]. ptr _ ptr + byteCount]. byteCount _ (freeBlock - dstPtr) + (self chunkSize: freeBlock header: (self longAt: freeBlock)). self longAt: dstPtr put: ((byteCount - 4) bitOr: HeaderTypeFree). freeBlock _ dstPtr. ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/19/2006 11:02'! survivorAfter: chunkPtr "Return the first surviving (i.e. marked) object at or after the given chunk." | ptr header | ptr _ chunkPtr. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. (((header bitAnd: HeaderTypeMask) ~= HeaderTypeFree) and: [((self longAt: ptr + 4) bitAnd: MarkBit) ~= 0]) ifTrue: [^ ptr]. ptr _ ptr + (self chunkSize: ptr header: header)]. ^ freeBlock ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 10/19/2006 11:10'! sweepAndSetForwardFields "Sweep memory and set the forwarding fields for all surviving objects. Consolidate contiguous free blocks to speed up later memory scans." "Details: shiftBytes is the number of bytes by which surviving objects will be shifted down in memory. Thus, newOop = oldOop - shiftBytes." | shiftBytes ptr header type nextPtr | shiftBytes _ 0. ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. ((HeaderTypeFree = type) or: [((self longAt: ptr + 4) bitAnd: MarkBit) = 0]) ifTrue: [ "garbage" nextPtr _ self survivorAfter: ptr + (self chunkSize: ptr header: header). shiftBytes _ shiftBytes + (nextPtr - ptr). self longAt: ptr put: (((nextPtr - ptr) - 4) bitOr: HeaderTypeFree)] ifFalse: [ "survivor: set up forward field" shiftBytes = 0 ifTrue: [self longAt: ptr + 4 put: 0] "don't forward; this object is not moving" ifFalse: [self longAt: ptr + 4 put: ptr - shiftBytes]. "forward to new oop" type = HeaderTypeOneWord ifTrue: [nextPtr _ ptr + ((((header bitAnd: ObjSizeMask) >> ObjSizeShift) + 11) bitAnd: WordAlignMask)] ifFalse: [nextPtr _ ptr + (((self longAt: ptr + 8) + 15) bitAnd: WordAlignMask)]]. ptr _ nextPtr]. ^ ptr ! ! !ObjMem2 methodsFor: 'garbage collection' stamp: 'jm 11/23/2006 23:01'! updatedForwardedPointers "Update all object references using the forwarding fields. Every pointer-containing object is scanned and every forwarded oop in it is replaced with that oop's new location." | ptr header chunkSize type first oldOop newOop | ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. chunkSize _ self chunkSize: ptr header: header. type _ header bitAnd: HeaderTypeMask. ((type ~= HeaderTypeFree) and: [(header bitAnd: HasPointersBit) ~= 0]) ifTrue: [ type = HeaderTypeOneWord ifTrue: [first _ ptr + 8] "one word header" ifFalse: [first _ ptr + 12]. "two word header" first to: ptr + chunkSize - 4 by: 4 do: [:i | oldOop _ self longAt: i. ((oldOop ~= NilOop) and: [self isObjectOop: oldOop]) ifTrue: [ newOop _ self longAt: oldOop + 4. newOop ~= 0 ifTrue: [self longAt: i put: newOop]]]]. ptr _ ptr + chunkSize]. ! ! !ObjMem2 methodsFor: 'tests' stamp: 'jm 11/23/2006 23:02'! gcTest1 "Allocate an array of N objects mixed with garbage, then do two collections. Shows the difference between a GC that moves N objects versus one that scans all N objects but doesn't move them." | count rootOop savedOop classID | count _ 10000. self initMemByteCount: 600000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. self startTimer. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. self reportTime: 'Test 1, object creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem2 methodsFor: 'tests' stamp: 'jm 10/18/2006 21:30'! gcTest2 "Create a long linked list of objects mixed with garbage." | count rootOop lastOop thisOop | count _ 10000. self initMemByteCount: 500000. rootOop _ self allocate: 4 format: 3 classIndex: 99. self startTimer. lastOop _ NilOop. 1 to: count do: [:i | thisOop _ self allocate: 4 format: 3 classIndex: 9. self oopAt: 1 put: lastOop in: thisOop. lastOop _ thisOop. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4]. self oopAt: 1 put: lastOop in: rootOop. self reportTime: 'Test 2, Link list creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem2 methodsFor: 'tests' stamp: 'jm 11/23/2006 23:06'! gcTest3 "Create a binary tree of objects mixed with garbage." | depth rootOop bytesNeeded | depth _ 13. bytesNeeded _ "2 raisedTo: 13" 8192 * (36 + 8 + 24). self initMemByteCount: bytesNeeded. self startTimer. rootOop _ self treeDepth: depth. self reportTime: 'Test 3, Tree creation: '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'first GC (moves all objects): '. self startTimer. self garbageCollectRoot: rootOop. self reportTime: 'second GC (no compaction needed): '. ! ! !ObjMem2 methodsFor: 'tests' stamp: 'jm 10/18/2006 21:30'! treeDepth: n "Create a binary tree of depth N with garbage. Return the oop of the root." | treeOop | n = 0 ifTrue: [^ NilOop]. treeOop _ self allocate: 8 format: 3 classIndex: 9. self allocate: 4 format: 2 classIndex: 2. "garbage" self oopAt: 1 put: (self treeDepth: n - 1) in: treeOop. self allocate: 4 format: 2 classIndex: 2. "garbage" self oopAt: 2 put: (self treeDepth: n - 1) in: treeOop. self allocate: 4 format: 2 classIndex: 2. "garbage" ^ treeOop ! ! !ObjMem2 class methodsFor: 'class initialization' stamp: 'jm 10/19/2006 10:15'! initialize "self initialize" "Object pointers point to a base header word with the following format: 14 bits class table index 14 bits object size in bytes (0-16383; if larger, byte count is stored in extended header) 2 bits object format (0: byte array; 1: word array, 2: pointers, non-indexable; 3 pointers, indexable) 2 bits header type (0: free chunk; 1: normal object; 2: large object (extra header word for size)) The second word of the object header is used for garbage collection and forwarding. Format is either: a. the new address of the object after compaction or become or b. <30 bits unused><mark bit><marking done bit> The mark bits are meaningful only during GC. The optional third object header word is the size in bytes of objects larger than 16383 bytes." ClassIndexMask _ 16rFFFC0000. ClassIndexShift _ 18. ObjSizeMask _ 16r3FFF0. ObjSizeShift _ 4. FormatMask _ 16rC. FormatShift _ 2. HasPointersBit _ 8. WordIndexableBit _ 4. HeaderTypeMask _ 3. HeaderTypeFree _ 0. HeaderTypeOneWord _ 1. HeaderTypeTwoWord _ 2. MarkBitsMask _ 3. MarkBit _ 2. MarkingDoneBit _ 1. AllButObjSizeBits _ ObjSizeMask bitInvert32. AllButHeaderTypeBits _ HeaderTypeMask bitInvert32. MaxSizeForOneWordHeader _ (2 raisedTo: 14) - 1. WordAlignMask _ 16rFFFFFFFC. "AND-ing with this rounds down to a multiple of four" NilOop _ 0. NilClassIndex _ 1. SmallIntegerClassIndex _ 2. ! ! !ObjMem2 class methodsFor: 'translation' stamp: 'jm 10/18/2006 21:44'! translate: fileName doInlining: inlineFlag "self translate: 'objMem2.c' doInlining: false" | cg | self initialize. cg _ CCodeGenerator new initialize. cg addClass: self. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! !ObjMemSimulator methodsFor: 'initialization' stamp: 'jm 10/2/2006 22:18'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." | roundedByteCount | roundedByteCount _ (byteCount + 7) bitAnd: AllButHeaderTypeBits. memory _ Bitmap new: (roundedByteCount // 4) + 1 withAll: 111. "+1 because we have to start at 4" memStart _ freeBlock _ 4. "zero is reserved for nil; start at 4 instead" memEnd _ memStart + roundedByteCount. self longAt: freeBlock put: (roundedByteCount bitOr: HeaderTypeFree). ! ! !ObjMemSimulator methodsFor: 'small integers' stamp: 'jm 10/14/2006 21:18'! intToOop: anInteger "Convert the given SmallInteger value into an oop." anInteger < 0 ifTrue: [^ ((16r80000000 + anInteger) << 1) + 1] ifFalse: [^ (anInteger << 1) + 1] ! ! !ObjMemSimulator methodsFor: 'small integers' stamp: 'jm 10/14/2006 21:18'! isIntegerObject: oop ^ (oop bitAnd: 1) ~= 0 ! ! !ObjMemSimulator methodsFor: 'small integers' stamp: 'jm 10/14/2006 21:22'! isIntegerValue: anInteger "Return true if the given integer can be represented as a 31-bit SmallInteger (i.e. it can be encoded directly in the oop)." "Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits." ^ (anInteger bitXor: (anInteger << 1)) >= 0 ! ! !ObjMemSimulator methodsFor: 'small integers' stamp: 'jm 10/14/2006 21:18'! oopToInt: oop "Convert the given oop encoding of a SmallInteger to its integer value." "Translator produces 'oop >> 1'" (oop bitAnd: 16r80000000) ~= 0 ifTrue: ["negative" ^ ((oop bitAnd: 16r7FFFFFFF) >> 1) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"] ifFalse: [^ oop >> 1] "positive" ! ! !ObjMemSimulator methodsFor: 'indexed access' stamp: 'jm 10/14/2006 21:39'! byteAt: index in: oop "Return the byte at the given index of the given object. The object must be byte-indexable." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self error: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 7] ifFalse: [offset _ 3]. ^ self byteAt: oop + offset + index ! ! !ObjMemSimulator methodsFor: 'indexed access' stamp: 'jm 10/14/2006 21:40'! byteAt: index put: uint8 in: oop "Store the given 8-bit positive integer at the given byte index of the given object. The object must be byte-indexable." | header offset | (uint8 < 0) | (uint8 > 255) ifTrue: [^ self error: 'value not in range 0..255']. (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self error: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 7] ifFalse: [offset _ 3]. ^ self byteAt: oop + offset + index put: uint8 ! ! !ObjMemSimulator methodsFor: 'indexed access' stamp: 'jm 10/14/2006 21:40'! wordAt: index in: oop "Return the 32-bit word at the given index of the given object. The object must be word-indexable (not pointers)." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self error: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 4] ifFalse: [offset _ 0]. ^ self longAt: oop + offset + (4 * index) ! ! !ObjMemSimulator methodsFor: 'indexed access' stamp: 'jm 10/14/2006 21:40'! wordAt: index put: anInteger in: oop "Store the given 32-bit positive integer at the given index of the given object. The object must be word-indexable (not pointers)." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self error: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 4] ifFalse: [offset _ 0]. ^ self longAt: oop + offset + (4 * index) put: anInteger ! ! !ObjMemSimulator methodsFor: 'memory access' stamp: 'jm 9/24/2006 14:29'! byteAt: byteAddress "Return the unsigned byte at the given (byte) address. This becomes a direct memory reference in C." | word shift | word _ memory at: (byteAddress // 4) + 1. shift _ -8 * (3 - (byteAddress \\ 4)). ^ (word bitShift: shift) bitAnd: 16rFF ! ! !ObjMemSimulator methodsFor: 'memory access' stamp: 'jm 9/24/2006 14:42'! byteAt: byteAddress put: uint8 "Store the given unsigned byte at the given (byte) address. This becomes a direct memory reference in C." | word shift | word _ memory at: (byteAddress // 4) + 1. shift _ 8 * (3 - (byteAddress \\ 4)). word _ (word bitAnd: (16rFF bitShift: shift) bitInvert32) bitOr: ((uint8 bitAnd: 16rFF) bitShift: shift). memory at: (byteAddress // 4) + 1 put: word. ! ! !ObjMemSimulator methodsFor: 'memory access' stamp: 'jm 9/24/2006 14:29'! longAt: byteAddress "Return the unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." ^ memory at: (byteAddress // 4) + 1 ! ! !ObjMemSimulator methodsFor: 'memory access' stamp: 'jm 9/24/2006 14:29'! longAt: byteAddress put: uint32 "Store the given unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." memory at: (byteAddress // 4) + 1 put: uint32. ! ! !ObjMemSimulator methodsFor: 'tests' stamp: 'jm 10/3/2006 23:01'! markTest | count rootOop savedOop classID | count _ 100. self initMemByteCount: 500000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. ^ rootOop ! ! !ObjMemSimulator methodsFor: 'tests' stamp: 'jm 10/3/2006 23:01'! markTest2 | root lastOop oop | self initMemByteCount: 820. root _ self allocate: 4 format: 3 classIndex: 11. "build a linked list:" lastOop _ NilOop. 1 to: 100 do: [:i | oop _ self allocate: 4 format: 3 classIndex: 11. self oopAt: 1 put: lastOop in: oop. lastOop _ oop]. self oopAt: 1 put: lastOop in: root. ^ root ! ! !ObjMemSimulator methodsFor: 'old code' stamp: 'jm 10/3/2006 23:02'! OLDrestoreHeadersFrom: startPtr to: endPtr "Scan the given range of memory and restore the original header words of forwarded objects." | ptr header | ptr _ startPtr. [ptr < endPtr] whileTrue: [ header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ header _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4. self longAt: ptr put: header]. ptr _ ptr + (self chunkSize: ptr header: header)]. ! ! !ObjMemSimulator methodsFor: 'old code' stamp: 'jm 10/14/2006 21:13'! OLDsweepAndCount "Sweep memory clearing mark bits and counting the number of surviving objects and the amount of free space. Also consolidate adjacent free chuks to speed up future memory scans." | freeBytes ptr header type nextPtr | freeBytes _ 0. ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. ((type = HeaderTypeFree) or: [(header bitAnd: MarkBit) = 0]) ifTrue: [ nextPtr _ self survivorAfter: ptr. freeBytes _ freeBytes + (nextPtr - ptr). self longAt: ptr put: (((nextPtr - ptr) - 4) bitOr: HeaderTypeFree)] ifFalse: [ self longAt: ptr put: (header bitAnd: AllButMarkBits). "clear mark bits" type = HeaderTypeOneWord ifTrue: [nextPtr _ ptr + ((header bitAnd: ObjSizeMask) >> ObjSizeShift) + 4] ifFalse: [nextPtr _ ptr + (((self longAt: ptr + 4) + 3) bitAnd: AllButHeaderTypeBits) + 8]]. ptr _ nextPtr]. ^ freeBytes ! ! !ObjMemSimulator methodsFor: 'old code' stamp: 'jm 10/14/2006 21:11'! OLDsweepAndMakeForwardingEntriesFrom: sweepStart "Sweep memory and create forwarding table entries for all surviving objects." "Details: shiftBytes is the number of bytes by which surviving objects will be shifted down in memory. Thus, newOop = (old oop - shifteBytes)." | shiftBytes ptr header byteCount | self initForwardingTable. shiftBytes _ 0. ptr _ sweepStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. byteCount _ self chunkSize: ptr header: header. HeaderTypeFree = (header bitAnd: HeaderTypeMask) ifTrue: [shiftBytes _ shiftBytes + byteCount] ifFalse: [ nextFwdEntry >= memEnd ifTrue: [^ ptr]. "out of entries; start next pass here" self forwardOop: ptr to: ptr - shiftBytes]. ptr _ ptr + byteCount]. ^ ptr ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 9/25/2006 21:46'! allObjects | result oop | result _ OrderedCollection new: 1000. oop _ self objectAfter: NilOop. [oop ~= NilOop] whileTrue: [ result addLast: oop. oop _ self objectAfter: oop]. ^ result asArray ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 9/24/2006 21:40'! allObjectsWithClassIndex: classIndex | result oop | result _ OrderedCollection new: 1000. oop _ self objectAfter: NilOop withClassIndex: classIndex. [oop ~= NilOop] whileTrue: [ result addLast: oop. oop _ self objectAfter: oop withClassIndex: classIndex]. ^ result asArray ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/3/2006 20:33'! chunksDo: aBlock "Evaluate the given block for each object or free chunk." | ptr | ptr _ memStart. [ptr <= freeBlock] whileTrue: [ aBlock value: ptr. ptr _ ptr + (self chunkSize: ptr header: (self longAt: ptr))]. ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/3/2006 22:59'! countChunks "Test code to count the number of chunks." | count ptr | count _ 0. ptr _ memStart. [ptr <= freeBlock] whileTrue: [ count _ count + 1. ptr _ ptr + (self chunkSize: ptr header: (self longAt: ptr))]. ^ count ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/3/2006 22:59'! countObjects "Test code to count the number of objects.." | count oop | count _ 0. oop _ self objectAfter: NilOop. [oop ~= NilOop] whileTrue: [ count _ count + 1. oop _ self objectAfter: oop]. ^ count ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/2/2006 21:08'! dumpString | s | s _ WriteStream on: (String new: 10000). s cr. self chunksDo: [:ptr | s nextPutAll: (self headerStringAt: ptr); cr]. ^ s contents ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/2/2006 22:25'! headerStringAt: ptr "Answer a string describing the object or free chunk at the given address." | s header headerType byteCount fwdEntry | s _ WriteStream on: String new. header _ self longAt: ptr. s nextPutAll: ptr printString, ': '. headerType _ header bitAnd: HeaderTypeMask. headerType = HeaderTypeFree ifTrue: [ s nextPutAll: '[FREE] ', (header bitAnd: AllButHeaderTypeBits) printString, ' bytes'. ^ s contents]. headerType = HeaderTypeForward ifTrue: [ fwdEntry _ header bitAnd: AllButHeaderTypeBits. s nextPutAll: '[FWD (', fwdEntry printString, ')->', (self longAt: fwdEntry) printString, ']'. header _ self longAt: (fwdEntry + 4). "actual header from forwarding table" (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [byteCount _ self longAt: ptr + 4] ifFalse: [byteCount _ (header bitAnd: ObjSizeMask) >> ObjSizeShift]]. headerType = HeaderTypeOneWord ifTrue: [ s nextPutAll: '[obj]'. byteCount _ (header bitAnd: ObjSizeMask) >> ObjSizeShift]. headerType = HeaderTypeTwoWord ifTrue: [ s nextPutAll: '[big]'. byteCount _ self longAt: ptr + 4]. s nextPutAll: ' gc=', ((header >> 30) bitAnd: 3) printString. s nextPutAll: ' objSize=', byteCount printString. s nextPutAll: ' format=', ((header bitAnd: FormatMask) >> FormatShift) printString. s nextPutAll: ' class=', ((header bitAnd: ClassIndexMask) >> ClassIndexShift) printString. ^ s contents ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 9/24/2006 14:32'! memory ^ memory ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/1/2006 19:05'! reportTime: aString | deltaMSecs | deltaMSecs _ Time millisecondClockValue - startMSecs. Transcript show: aString, deltaMSecs printString; cr. ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/1/2006 19:04'! startTimer startMSecs _ Time millisecondClockValue. ! ! !ObjMemSimulator methodsFor: 'debug' stamp: 'jm 10/14/2006 21:53'! timeGCRoot: rootOop | sweepStart sweepEnd | self startTimer. self initMarkingStack. self markRoot: rootOop. self markLoop. self reportTime: 'Marking: '. sweepStart _ memStart. [sweepStart < freeBlock] whileTrue: [ self startTimer. sweepEnd _ self sweepAndMakeForwardingEntriesFrom: sweepStart. self reportTime: 'Make forwarding entries: '. self startTimer. self applyForwardingTable. self reportTime: 'Apply forwarding table: '. self startTimer. sweepStart _ self moveObjectsFrom: sweepStart to: sweepEnd. self reportTime: 'Move objects: ']. ! ! !ObjMemSimulator2 methodsFor: 'initialization' stamp: 'jm 11/23/2006 09:14'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." | roundedByteCount | roundedByteCount _ (byteCount + 7) bitAnd: AllButHeaderTypeBits. memory _ Bitmap new: (roundedByteCount // 4) + 1 withAll: 111. "+1 because we have to start at 4" memStart _ freeBlock _ 4. "zero is reserved for nil; start at 4 instead" memEnd _ memStart + roundedByteCount. self longAt: freeBlock put: (roundedByteCount bitOr: HeaderTypeFree). ! ! !ObjMemSimulator2 methodsFor: 'small integers' stamp: 'jm 11/23/2006 09:14'! intToOop: anInteger "Convert the given SmallInteger value into an oop." anInteger < 0 ifTrue: [^ ((16r80000000 + anInteger) << 1) + 1] ifFalse: [^ (anInteger << 1) + 1] ! ! !ObjMemSimulator2 methodsFor: 'small integers' stamp: 'jm 11/23/2006 09:14'! isIntegerObject: oop ^ (oop bitAnd: 1) ~= 0 ! ! !ObjMemSimulator2 methodsFor: 'small integers' stamp: 'jm 11/23/2006 09:14'! isIntegerValue: anInteger "Return true if the given integer can be represented as a 31-bit SmallInteger (i.e. it can be encoded directly in the oop)." "Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits." ^ (anInteger bitXor: (anInteger << 1)) >= 0 ! ! !ObjMemSimulator2 methodsFor: 'small integers' stamp: 'jm 11/23/2006 09:14'! oopToInt: oop "Convert the given oop encoding of a SmallInteger to its integer value." "Translator produces 'oop >> 1'" (oop bitAnd: 16r80000000) ~= 0 ifTrue: ["negative" ^ ((oop bitAnd: 16r7FFFFFFF) >> 1) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"] ifFalse: [^ oop >> 1] "positive" ! ! !ObjMemSimulator2 methodsFor: 'indexed access' stamp: 'jm 11/23/2006 23:18'! byteAt: index in: oop "Return the byte at the given index of the given object. The object must be byte-indexable." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self error: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 11] ifFalse: [offset _ 7]. ^ self byteAt: oop + offset + index ! ! !ObjMemSimulator2 methodsFor: 'indexed access' stamp: 'jm 11/23/2006 23:18'! byteAt: index put: uint8 in: oop "Store the given 8-bit positive integer at the given byte index of the given object. The object must be byte-indexable." | header offset | (uint8 < 0) | (uint8 > 255) ifTrue: [^ self error: 'value not in range 0..255']. (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self error: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 11] ifFalse: [offset _ 7]. ^ self byteAt: oop + offset + index put: uint8 ! ! !ObjMemSimulator2 methodsFor: 'indexed access' stamp: 'jm 11/23/2006 23:17'! wordAt: index in: oop "Return the 32-bit word at the given index of the given object. The object must be word-indexable (not pointers)." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self error: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 8] ifFalse: [offset _ 4]. ^ self longAt: oop + offset + (4 * index) ! ! !ObjMemSimulator2 methodsFor: 'indexed access' stamp: 'jm 11/23/2006 23:18'! wordAt: index put: anInteger in: oop "Store the given 32-bit positive integer at the given index of the given object. The object must be word-indexable (not pointers)." | header offset | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self error: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self error: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self error: 'index out of range']. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [offset _ 8] ifFalse: [offset _ 4]. ^ self longAt: oop + offset + (4 * index) put: anInteger ! ! !ObjMemSimulator2 methodsFor: 'memory access' stamp: 'jm 11/23/2006 09:14'! byteAt: byteAddress "Return the unsigned byte at the given (byte) address. This becomes a direct memory reference in C." | word shift | word _ memory at: (byteAddress // 4) + 1. shift _ -8 * (3 - (byteAddress \\ 4)). ^ (word bitShift: shift) bitAnd: 16rFF ! ! !ObjMemSimulator2 methodsFor: 'memory access' stamp: 'jm 11/23/2006 09:14'! byteAt: byteAddress put: uint8 "Store the given unsigned byte at the given (byte) address. This becomes a direct memory reference in C." | word shift | word _ memory at: (byteAddress // 4) + 1. shift _ 8 * (3 - (byteAddress \\ 4)). word _ (word bitAnd: (16rFF bitShift: shift) bitInvert32) bitOr: ((uint8 bitAnd: 16rFF) bitShift: shift). memory at: (byteAddress // 4) + 1 put: word. ! ! !ObjMemSimulator2 methodsFor: 'memory access' stamp: 'jm 11/23/2006 09:14'! longAt: byteAddress "Return the unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." ^ memory at: (byteAddress // 4) + 1 ! ! !ObjMemSimulator2 methodsFor: 'memory access' stamp: 'jm 11/23/2006 09:14'! longAt: byteAddress put: uint32 "Store the given unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." memory at: (byteAddress // 4) + 1 put: uint32. ! ! !ObjMemSimulator2 methodsFor: 'tests' stamp: 'jm 11/23/2006 09:14'! markTest | count rootOop savedOop classID | count _ 100. self initMemByteCount: 500000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. ^ rootOop ! ! !ObjMemSimulator2 methodsFor: 'tests' stamp: 'jm 11/23/2006 09:14'! markTest2 | root lastOop oop | self initMemByteCount: 820. root _ self allocate: 4 format: 3 classIndex: 11. "build a linked list:" lastOop _ NilOop. 1 to: 100 do: [:i | oop _ self allocate: 4 format: 3 classIndex: 11. self oopAt: 1 put: lastOop in: oop. lastOop _ oop]. self oopAt: 1 put: lastOop in: root. ^ root ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! allObjects | result oop | result _ OrderedCollection new: 1000. oop _ self objectAfter: NilOop. [oop ~= NilOop] whileTrue: [ result addLast: oop. oop _ self objectAfter: oop]. ^ result asArray ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! allObjectsWithClassIndex: classIndex | result oop | result _ OrderedCollection new: 1000. oop _ self objectAfter: NilOop withClassIndex: classIndex. [oop ~= NilOop] whileTrue: [ result addLast: oop. oop _ self objectAfter: oop withClassIndex: classIndex]. ^ result asArray ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! chunksDo: aBlock "Evaluate the given block for each object or free chunk." | ptr | ptr _ memStart. [ptr <= freeBlock] whileTrue: [ aBlock value: ptr. ptr _ ptr + (self chunkSize: ptr header: (self longAt: ptr))]. ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! countChunks "Test code to count the number of chunks." | count ptr | count _ 0. ptr _ memStart. [ptr <= freeBlock] whileTrue: [ count _ count + 1. ptr _ ptr + (self chunkSize: ptr header: (self longAt: ptr))]. ^ count ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! countObjects "Test code to count the number of objects.." | count oop | count _ 0. oop _ self objectAfter: NilOop. [oop ~= NilOop] whileTrue: [ count _ count + 1. oop _ self objectAfter: oop]. ^ count ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! dumpString | s | s _ WriteStream on: (String new: 10000). s cr. self chunksDo: [:ptr | s nextPutAll: (self headerStringAt: ptr); cr]. ^ s contents ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 11:55'! headerStringAt: ptr "Answer a string describing the object or free chunk at the given address." | s header headerType byteCount | s _ WriteStream on: String new. header _ self longAt: ptr. s nextPutAll: ptr printString, ': '. headerType _ header bitAnd: HeaderTypeMask. headerType = HeaderTypeFree ifTrue: [ s nextPutAll: '[FREE] ', (header bitAnd: AllButHeaderTypeBits) printString, ' bytes'. ^ s contents]. headerType = HeaderTypeOneWord ifTrue: [ s nextPutAll: '[obj]'. byteCount _ (header bitAnd: ObjSizeMask) >> ObjSizeShift]. headerType = HeaderTypeTwoWord ifTrue: [ s nextPutAll: '[big]'. byteCount _ self longAt: ptr + 4]. s nextPutAll: ' gc=', (self longAt: ptr + 4) printString. s nextPutAll: ' objSize=', byteCount printString. s nextPutAll: ' format=', ((header bitAnd: FormatMask) >> FormatShift) printString. s nextPutAll: ' class=', ((header bitAnd: ClassIndexMask) >> ClassIndexShift) printString. ^ s contents ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! memory ^ memory ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! reportTime: aString | deltaMSecs | deltaMSecs _ Time millisecondClockValue - startMSecs. Transcript show: aString, deltaMSecs printString; cr. ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! startTimer startMSecs _ Time millisecondClockValue. ! ! !ObjMemSimulator2 methodsFor: 'debug' stamp: 'jm 11/23/2006 09:14'! timeGCRoot: rootOop | sweepStart sweepEnd | self startTimer. self initMarkingStack. self markRoot: rootOop. self markLoop. self reportTime: 'Marking: '. sweepStart _ memStart. [sweepStart < freeBlock] whileTrue: [ self startTimer. sweepEnd _ self sweepAndMakeForwardingEntriesFrom: sweepStart. self reportTime: 'Make forwarding entries: '. self startTimer. self applyForwardingTable. self reportTime: 'Apply forwarding table: '. self startTimer. sweepStart _ self moveObjectsFrom: sweepStart to: sweepEnd. self reportTime: 'Move objects: ']. ! ! This class allows you to test ObjMem in Squeak: ObjMemTest new gcTest1 ObjMemTest new gcTest2 ObjMemTest new gcTest3 Times print in the Transcript. ! !ObjMemTest methodsFor: 'initialization' stamp: 'jm 10/15/2006 20:16'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." | roundedByteCount | roundedByteCount _ (byteCount + 7) bitAnd: AllButHeaderTypeBits. memory _ Bitmap new: (roundedByteCount // 4) + 1 withAll: 111. "+1 because we have to start at 4" memStart _ freeBlock _ 4. "zero is reserved for nil; start at 4 instead" memEnd _ memStart + roundedByteCount. self longAt: freeBlock put: (roundedByteCount bitOr: HeaderTypeFree). ! ! !ObjMemTest methodsFor: 'testing support' stamp: 'jm 10/15/2006 20:17'! reportTime: aString | deltaMSecs | deltaMSecs _ Time millisecondClockValue - startMSecs. Transcript show: aString, deltaMSecs printString; cr. ! ! !ObjMemTest methodsFor: 'testing support' stamp: 'jm 10/15/2006 20:17'! startTimer startMSecs _ Time millisecondClockValue. ! ! !ObjMemTest methodsFor: 'memory access' stamp: 'jm 10/15/2006 20:17'! longAt: byteAddress "Return the unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." ^ memory at: (byteAddress // 4) + 1 ! ! !ObjMemTest methodsFor: 'memory access' stamp: 'jm 10/15/2006 20:17'! longAt: byteAddress put: uint32 "Store the given unsigned 32-bit word at the given (byte) address. This becomes a direct memory reference in C." memory at: (byteAddress // 4) + 1 put: uint32. ! ! !ObjMemV1 methodsFor: 'initialization' stamp: 'jm 10/19/2006 10:17'! initMemByteCount: byteCount "Initialize this object memory to the given size in bytes (rounded up to a multiple of 4 bytes)." "This version tranlates to C code that calls malloc()." | wordCount | wordCount _ ((byteCount + 3) // 4) + 1. memStart _ self cCode: '(int) malloc(4 * wordCount)'. memStart = 0 ifTrue: [^ self error: 'could not allocate memory']. memEnd _ memStart + (4 * wordCount). freeBlock _ memStart. self longAt: freeBlock put: ((wordCount << 2) bitOr: HeaderTypeFree). ! ! !ObjMemV1 methodsFor: 'small integers' stamp: 'jm 10/2/2006 20:17'! intToOop: anInteger "Convert the given SmallInteger value into an oop." anInteger < 0 ifTrue: [^ ((16r80000000 + anInteger) << 1) + 1] ifFalse: [^ (anInteger << 1) + 1] ! ! !ObjMemV1 methodsFor: 'small integers' stamp: 'jm 10/2/2006 20:17'! isIntegerOop: oop ^ (oop bitAnd: 1) > 0 ! ! !ObjMemV1 methodsFor: 'small integers' stamp: 'jm 10/2/2006 20:17'! isIntegerValue: anInteger "Return true if the given integer can be represented as a 31-bit SmallInteger (i.e. it can be encoded directly in the oop)." "Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits." ^ (anInteger bitXor: (anInteger << 1)) >= 0 ! ! !ObjMemV1 methodsFor: 'small integers' stamp: 'jm 10/2/2006 20:17'! isObjectOop: oop ^ (oop bitAnd: 1) = 0 ! ! !ObjMemV1 methodsFor: 'small integers' stamp: 'jm 10/2/2006 20:17'! oopToInt: oop "Convert the given oop encoding of a SmallInteger to its integer value." "Translator produces 'oop >> 1'" (oop bitAnd: 16r80000000) ~= 0 ifTrue: ["negative" ^ ((oop bitAnd: 16r7FFFFFFF) >> 1) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"] ifFalse: [^ oop >> 1] "positive" ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! byteAt: index in: oop "Return the byte at the given index of the given object. The object must be byte-indexable." | header | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self fail: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self fail: 'index out of range']. ^ self byteAt: (oop + 3 + index) ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! byteAt: index put: uint8 in: oop "Store the given 8-bit positive integer at the given byte index of the given object. The object must be byte-indexable." | header | (uint8 < 0) | (uint8 > 255) ifTrue: [^ self fail: 'value not in range 0..255']. (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= 0 ifTrue: [^ self fail: 'not byte indexable']. (index < 1) | (index > (self objectSize: oop)) ifTrue: [^ self fail: 'index out of range']. ^ self byteAt: (oop + 3 + index) put: uint8 ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! oopAt: index in: oop "Return the oop at the given index of the given object. The object must be pointers." | header | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self fail: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self fail: 'index out of range']. ^ self longAt: oop + (4 * index) ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! oopAt: index put: oopToStore in: oop "Store the given oop at the given index of the given object. The object must be pointers." | header | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: HasPointersBit) = 0 ifTrue: [^ self fail: 'not pointers']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self fail: 'index out of range']. ^ self longAt: oop + (4 * index) put: oopToStore ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! wordAt: index in: oop "Return the 32-bit word at the given index of the given object. The object must be word-indexable (not pointers)." | header | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self fail: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self fail: 'index out of range']. ^ self longAt: oop + (4 * index) ! ! !ObjMemV1 methodsFor: 'array/field access' stamp: 'jm 10/2/2006 20:17'! wordAt: index put: anInteger in: oop "Store the given 32-bit positive integer at the given index of the given object. The object must be word-indexable (not pointers)." | header | (oop = NilOop) | (self isIntegerOop: oop) ifTrue: [^ self fail: 'not indexable']. header _ self longAt: oop. (header bitAnd: FormatMask) ~= WordIndexableBit ifTrue: [^ self fail: 'not word indexable']. (index < 1) | (index > ((self objectSize: oop) // 4)) ifTrue: [^ self fail: 'index out of range']. ^ self longAt: oop + (4 * index) put: anInteger ! ! !ObjMemV1 methodsFor: 'allocation' stamp: 'jm 10/2/2006 20:17'! allocate: byteCount format: format classIndex: classIndex "Allocate an object of the given size and class." | baseHeader wordCount newOop | baseHeader _ (((byteCount << ObjSizeShift) bitAnd: ObjSizeMask) bitOr: ((format << FormatShift) bitAnd: FormatMask)) bitOr: ((classIndex << ClassIndexShift) bitAnd: ClassIndexMask). wordCount _ (byteCount + 3) // 4. byteCount > 4095 ifTrue: [ "large object: two-word header" newOop _ self allocateChunk: wordCount + 2. self longAt: newOop put: ((byteCount << 2) bitOr: HeaderTypeTwoWord). "extra header word holds object size" baseHeader _ baseHeader bitAnd: ObjSizeMask bitInvert32. "zero out size field" newOop _ newOop + 4. self longAt: newOop put: (baseHeader bitOr: HeaderTypeTwoWord)] ifFalse: [ "normal object: one-word header" newOop _ self allocateChunk: wordCount + 1. self longAt: newOop put: (baseHeader bitOr: HeaderTypeOneWord)]. ^ newOop ! ! !ObjMemV1 methodsFor: 'allocation' stamp: 'jm 10/2/2006 20:17'! allocateChunk: wordCount "Allocate and zero a chunk of memory of the given size The given word count should include the header word(s) for the new object being created." "Note: The size stored in the header word of a chunk or object does not include the header words(s)." | freeWords newChunk | freeWords _ (self longAt: freeBlock) >> 2. freeWords > wordCount ifFalse: [self error: 'out of memory']. newChunk _ freeBlock. freeBlock _ freeBlock + (4 * wordCount). newChunk + 4 to: freeBlock - 4 by: 4 do: [:i | self longAt: i put: 0]. self longAt: newChunk put: (((wordCount - 1) << 2) bitOr: HeaderTypeFree). self longAt: freeBlock put: (((freeWords - wordCount) << 2) bitOr: HeaderTypeFree). ^ newChunk ! ! !ObjMemV1 methodsFor: 'object header' stamp: 'jm 10/2/2006 20:17'! classIndex: oop "Answer the class index for the given object. The class index is an index into a one-based array of class objects." oop = NilOop ifTrue: [^ NilClassIndex]. (self isIntegerOop: oop) ifTrue: [^ SmallIntegerClassIndex]. ^ ((self longAt: oop) bitAnd: ClassIndexMask) >> ClassIndexShift ! ! !ObjMemV1 methodsFor: 'object header' stamp: 'jm 10/2/2006 20:17'! objectSize: objectOop "Answer the size (in bytes) of the given object, including its object header word(s). Assume that the oop points to a real object, not nil or a small integer." | header | header _ self longAt: objectOop. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [^ (self longAt: objectOop - 4) >> 2] ifFalse: [^ (header bitAnd: ObjSizeMask) >> ObjSizeShift] ! ! !ObjMemV1 methodsFor: 'enumeration' stamp: 'jm 10/2/2006 20:17'! objectAfter: anOop "If anOop is nil, return the first object in memory (of any class). Otherwise, return the next object after the given oop, or NilOop if there is none." | ptr type wordCount | (self isIntegerOop: anOop) ifTrue: [^ NilOop]. anOop = NilOop ifTrue: [ptr _ memStart] ifFalse: [ptr _ anOop + (4 * (self wordsForChunk: anOop))]. [ptr < freeBlock] whileTrue: [ type _ (self longAt: ptr) bitAnd: HeaderTypeMask. (type bitAnd: HeaderTypeIsObjectBit) ~= 0 ifTrue: [ type = HeaderTypeTwoWord ifTrue: [^ ptr + 4] ifFalse: [^ ptr]]. wordCount _ self wordsForChunk: ptr. ptr _ ptr + (4 * wordCount)]. ^ NilOop ! ! !ObjMemV1 methodsFor: 'enumeration' stamp: 'jm 10/2/2006 20:17'! objectAfter: anOop withClassIndex: cIndex "If anOop is nil, return the first object in memory of the given class. Otherwise, return the next object of the given class after the given oop, or NilOop if there is none. " | oop | oop _ self objectAfter: anOop. [true] whileTrue: [ oop = NilOop ifTrue: [^ NilOop]. (self classIndex: oop) = cIndex ifTrue: [^ oop]. oop _ self objectAfter: oop]. ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! applyForwardingTable "Update all object references using the forwarding table. Evert pointer-containing object is scanned and every forwarded oop in it is replaced with that oop's new location." | ptr nextPtr header thisOop thisHdr | ptr _ memStart. [ptr < freeBlock] whileTrue: [ nextPtr _ ptr + (4 * (self wordsForChunk: ptr)). header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [ ptr _ ptr + 4. header _ self longAt: ptr]. (header bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ header _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4]. "this object is forwarded; get it's actual header" (header bitAnd: HasPointersBit) ~= 0 ifTrue: [ ptr + 4 to: nextPtr - 4 by: 4 do: [:i | thisOop _ self longAt: i. ((thisOop ~= NilOop) and: [self isObjectOop: thisOop]) ifTrue: [ thisHdr _ self longAt: thisOop. (thisHdr bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ self longAt: i put: (self longAt: (thisHdr bitAnd: AllButHeaderTypeBits))]]]]. ptr _ nextPtr]. ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! compact "Compact memory by sliding surviving objects down so that all the free space is consolidated into one large chunk." "Details: If there are enough forwarding table entries for all surviving objects, this process can be done in three passes over memory: a. sweep memory, making forwarding table entries for surviving objects b. apply the forwarding table to update pointers in all objects to point to the new object locations c. slide the surviving objects down to their new locations However, if there are not enough forwarding table entries we must repeat this process, moving as many objects as possible each time. A growing chunk of newly freed memory bubbles up through the objects until finally it is at the end of all the objects. At that point memory is compact." | forwardingEntryCount sweepStart sweepEnd | forwardingEntryCount _ self initForwardingTable. self sweepAndCount. survivorCount > forwardingEntryCount ifTrue: [ "could try to make more forwaring entries by doing a compaction of the last forwardingEntryCount objects"]. sweepStart _ memStart. [sweepStart < freeBlock] whileTrue: [ sweepEnd _ self sweepAndMakeForwardingEntriesFrom: sweepStart. self applyForwardingTable. self restoreHeadersFrom: sweepStart to: sweepEnd. sweepStart _ self moveObjectsFrom: sweepStart to: sweepEnd]. ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! forwardOop: oop to: newOop "Create a forwarding table entry for the given oop." "Details: Allocate a new forwarding table entry. The first word of this entry holds the new oop. The second word holds the original base header word for the given oop. The base header word of the oop is replaced with the address of the forwarding table entry with its low two bits set to HeaderTypeForward." | newEntry | newEntry _ fwdTableEnd. fwdTableEnd _ fwdTableEnd + 8. self longAt: newEntry put: newOop. self longAt: (newEntry + 4) put: (self longAt: oop). "save old header word" self longAt: oop put: (newEntry bitOr: HeaderTypeForward). ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! gc: rootOop "Do a full garbage collection and compaction. Trace pointers starting with the given root object." self initMarkingStack. self mark: rootOop. self markLoop. self compact. ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! initForwardingTable "Initialize the forwarding table immediately after freeChunk. Return the number of forwarding entries." fwdTable _ freeBlock. fwdTableEnd _ fwdTable. "initially empty" ^ (memEnd - fwdTable) // 8 ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! moveObjectsFrom: startPtr to: endPtr "Slide down objects to compact memory starting and ending at the given chunk addresses. Return the start of the chunk immediately following the last object moved." | ptr dstPtr wordCount header | ptr _ dstPtr _ startPtr. [ptr < endPtr] whileTrue: [ wordCount _ self wordsForChunk: ptr. header _ self longAt: ptr. (header bitAnd: HeaderTypeIsObjectBit) ~= 0 ifTrue: [ "copy object" ptr to: ptr + (4 * (wordCount - 1)) by: 4 do: [:srcPtr | self longAt: dstPtr put: (self longAt: srcPtr). dstPtr _ dstPtr + 4]]. ptr _ ptr + (4 * wordCount)]. dstPtr < endPtr ifTrue: [ wordCount _ (endPtr - dstPtr) // 4. endPtr = freeBlock ifTrue: [ wordCount _ wordCount + (self wordsForChunk: freeBlock)]. self longAt: dstPtr put: ((4 * (wordCount - 1)) bitOr: HeaderTypeFree). endPtr = freeBlock ifTrue: [freeBlock _ dstPtr]. ^ dstPtr]. ^ endPtr! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! restoreHeadersFrom: startPtr to: endPtr "Scan the given range of memory and restore the original header words of forwarded objects." | ptr nextPtr header oldHeader | ptr _ startPtr. [ptr < endPtr] whileTrue: [ nextPtr _ ptr + (4 * (self wordsForChunk: ptr)). header _ self longAt: ptr. (header bitAnd: HeaderTypeMask) = HeaderTypeTwoWord ifTrue: [ ptr _ ptr + 4. header _ self longAt: ptr]. (header bitAnd: HeaderTypeMask) = HeaderTypeForward ifTrue: [ oldHeader _ self longAt: (header bitAnd: AllButHeaderTypeBits) + 4. self longAt: ptr put: oldHeader]. ptr _ nextPtr]. ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! survivorAfter: chunkPtr "Return the first surviving object after the given chunk or freeBlock." | ptr header type | ptr _ chunkPtr + (4 * (self wordsForChunk: chunkPtr)). [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. (type bitAnd: HeaderTypeIsObjectBit) ~= 0 ifTrue: [ type = HeaderTypeTwoWord ifTrue: [header _ self longAt: ptr + 4]. (header bitAnd: MarkBit) ~= 0 ifTrue: [^ ptr]]. ptr _ ptr + (4 * (self wordsForChunk: ptr))]. ^ freeBlock ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! sweepAndCount "Sweep memory clearing mark bits and counting the number of surviving objects and the amount of free space. Also consolidate adjacent free chuks to speed up future memory scans." | freeBytes ptr header type oop nextPtr | survivorCount _ freeBytes _ 0. ptr _ memStart. [ptr < freeBlock] whileTrue: [ header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. oop _ ptr. type = HeaderTypeTwoWord ifTrue: [oop _ ptr + 4. header _ self longAt: oop]. ((type = HeaderTypeFree) or: [(header bitAnd: MarkBit) = 0]) ifTrue: [ nextPtr _ self survivorAfter: ptr. freeBytes _ freeBytes + (nextPtr - ptr). self longAt: ptr put: (((nextPtr - ptr) - 4) bitOr: HeaderTypeFree)] ifFalse: [ survivorCount _ survivorCount + 1. self longAt: oop put: (header bitAnd: AllButMarkBits). "clear mark bits" nextPtr _ ptr + (4 * (self wordsForChunk: ptr))]. ptr _ nextPtr]. ^ freeBytes ! ! !ObjMemV1 methodsFor: 'forwarding' stamp: 'jm 10/2/2006 20:17'! sweepAndMakeForwardingEntriesFrom: sweepStart "Sweep memory and create forwarding table entries for all surviving objects." "Details: shiftBytes is the number of bytes by which surviving objects will be shifted down in memory. Thus, newOop = (old oop - shifteBytes)." | shiftBytes ptr wordCount header type oop | self initForwardingTable. shiftBytes _ 0. ptr _ sweepStart. [ptr < freeBlock] whileTrue: [ wordCount _ self wordsForChunk: ptr. header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. type = HeaderTypeFree ifTrue: [ shiftBytes _ shiftBytes + (4 * wordCount)] ifFalse: [ type = HeaderTypeOneWord ifTrue: [oop _ ptr] ifFalse: [oop _ ptr + 4]. fwdTableEnd >= memEnd ifTrue: [^ ptr]. "out of forwarding table entries; start the next pass here" self forwardOop: oop to: oop - shiftBytes]. ptr _ ptr + (4 * wordCount)]. ^ ptr ! ! !ObjMemV1 methodsFor: 'marking' stamp: 'jm 10/2/2006 20:17'! initMarkingStack "Initialize the marking stack immediately after the last object." markStackBase _ markStackPtr _ freeBlock + 4. markStackOverflowed _ false. ! ! !ObjMemV1 methodsFor: 'marking' stamp: 'jm 10/2/2006 20:17'! mark: memoryOop "Mark the given object. Assume that memoryOop refers to a real object (not nil or a SmallInteger)." "Note: The 'mark' bit means an object is accessible and that it has been added to the mark stack for further processing. The 'marking done' bit means that all pointer-containing fields of the object have been traced." | header byteCount thisOop thisHdr | header _ self longAt: memoryOop. (header bitAnd: HasPointersBit) = 0 ifTrue: [ self longAt: memoryOop put: (header bitOr: MarkBitsMask). "no pointers to process" ^ 0]. byteCount _ self objectSize: memoryOop. memoryOop + 4 to: memoryOop + byteCount by: 4 do: [:ptr | thisOop _ self longAt: ptr. ((thisOop ~= NilOop) and: [self isObjectOop: thisOop]) ifTrue: [ thisHdr _ self longAt: thisOop. (thisHdr bitAnd: MarkBit) = 0 ifTrue: [ (thisHdr bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process; mark it and be done" self longAt: thisOop put: (thisHdr bitOr: MarkBitsMask)] ifFalse: [ "oop contains pointers, put it on the stack to be scanned" self longAt: thisOop put: (thisHdr bitOr: MarkBit). markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: thisOop. markStackPtr _ markStackPtr + 4]]]]]. "record that this object has been fully traced" self longAt: memoryOop put: (header bitOr: MarkBitsMask). ! ! !ObjMemV1 methodsFor: 'marking' stamp: 'jm 10/2/2006 20:17'! markLoop "Mark all accessible objects starting with the root objects on the mark stack." | thisOop | [markStackPtr > markStackBase] whileTrue: [ markStackPtr _ markStackPtr - 4. thisOop _ self longAt: markStackPtr. self mark: thisOop]. ! ! !ObjMemV1 methodsFor: 'marking' stamp: 'jm 10/2/2006 20:17'! markRoot: memoryOop "Mark the given root object. If it contains pointers, add it to the mark stack to be processed later. Assume that the oop is a real memory object (not nil or a SmallInteger)." | header | header _ self longAt: memoryOop. (header bitAnd: HasPointersBit) = 0 ifTrue: [ "no pointers to process" self longAt: memoryOop put: (header bitOr: MarkBitsMask). ^ 0]. self longAt: memoryOop put: (header bitOr: MarkBit). markStackPtr >= memEnd ifTrue: [markStackOverflowed _ true] ifFalse: [ self longAt: markStackPtr put: memoryOop. markStackPtr _ markStackPtr + 4]. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! countChunks "Test code to count the number of chunks." | count ptr | count _ 0. ptr _ memStart. [ptr <= freeBlock] whileTrue: [ count _ count + 1. ptr _ ptr + (4 * (self wordsForChunk: ptr))]. ^ count ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! countObjects "Test code to count the number of objects.." | count oop | count _ 0. oop _ self objectAfter: NilOop. [oop ~= NilOop] whileTrue: [ count _ count + 1. oop _ self objectAfter: oop]. ^ count ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! fail: errorString self var: #errorString declareC: 'char *errorString'. self error: errorString. ^ NilOop ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! gcTimingTest | count rootOop savedOop classID | count _ 2000. self initMemByteCount: 250000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. self startTimer. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. self reportTime: 'Object creation: '. self timeGCRoot: rootOop. self reportTime: ''. self timeGCRoot: rootOop. self reportTime: ''. self timeGCRoot: rootOop. self reportTime: ''. self timeGCRoot: rootOop. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! markTest | count rootOop savedOop classID | count _ 4000. self initMemByteCount: 500000. rootOop _ self allocate: (4 * count) format: 2 classIndex: 99. classID _ 0. 1 to: count do: [:i | savedOop _ self allocate: 4 format: 3 classIndex: (classID _ (classID + 1) \\ 10) + 10. self allocate: 4 format: 2 classIndex: 2. self allocate: 4 format: 1 classIndex: 3. self allocate: 4 format: 0 classIndex: 4. self oopAt: i put: savedOop in: rootOop]. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! markTest2 | lastOop oop | self initMemByteCount: 820. "build a linked list:" lastOop _ NilOop. 1 to: 100 do: [:i | oop _ self allocate: 4 format: 3 classIndex: 11. self oopAt: 1 put: lastOop in: oop. lastOop _ oop]. self initMarkingStack. self mark: lastOop. self markLoop. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! setup self initMemByteCount: 1500000. 1 to: 100000 do: [:i | self allocate: 8 format: 1 classIndex: 7]. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! timeGCRoot: rootOop | sweepStart sweepEnd | self startTimer. self initMarkingStack. self mark: rootOop. self markLoop. self reportTime: 'Marking: '. self startTimer. self initForwardingTable. self sweepAndCount. self reportTime: 'Sweep and count: '. sweepStart _ memStart. [sweepStart < freeBlock] whileTrue: [ self startTimer. sweepEnd _ self sweepAndMakeForwardingEntriesFrom: sweepStart. self reportTime: 'Make forwarding entries: '. self startTimer. self applyForwardingTable. self reportTime: 'Apply forwarding table: '. self startTimer. self restoreHeadersFrom: sweepStart to: sweepEnd. self reportTime: 'Restore headers: '. self startTimer. sweepStart _ self moveObjectsFrom: sweepStart to: sweepEnd. self reportTime: 'Move objects: ']. ! ! !ObjMemV1 methodsFor: 'debug' stamp: 'jm 10/2/2006 20:17'! wordsForChunk: ptr "Return the number of words for this object or free chunk. Used when scanning the object memory. Assume the given ptr is not nil or a SmallInteger and that it points to the *first* header word of the free chunk or object (even for objects with two header words; a normal oop points to the second header word of such objects)." | header type byteCount | header _ self longAt: ptr. type _ header bitAnd: HeaderTypeMask. type = HeaderTypeOneWord ifTrue: [byteCount _ (header bitAnd: ObjSizeMask) >> ObjSizeShift] ifFalse: [ type = HeaderTypeFree ifTrue: [^ (header >> 2) + 1]. "+1 word for chunk header" type = HeaderTypeTwoWord ifTrue: [byteCount _ (header >> 2) + 4] "+4 bytes for extra header word" ifFalse: [ "forwarded: get byteCount from header word in forwarding table entry" header _ self longAt: ((header bitAnd: AllButHeaderTypeBits) + 4). byteCount _ (header bitAnd: ObjSizeMask) >> ObjSizeShift]]. ^ ((byteCount + 3) // 4) + 1 "+1 word for base object header" ! ! !ObjMemV1 class methodsFor: 'class initialization' stamp: 'jm 10/2/2006 20:17'! initialize "self initialize" "Object pointers point to a base header word with the following format: 2 bits used for gc (mark, markingDone) 12 bits object size in bytes (0-4095; if larger, byte count is stored in extended header) 2 bits object format (0: byte array; 1: word array, 2: pointers, non-indexable; 3 pointers, indexable) 14 bits class table index 2 bits header type (0: normal; 1: two-word; 2: marking; 3: free chunk)" MarkBitsMask _ 16rC0000000. MarkBit _ 16r80000000. MarkingDoneBit _ 16r40000000. ObjSizeMask _ 16r3FFC0000. ObjSizeShift _ 18. FormatMask _ 16r30000. FormatShift _ 16. HasPointersBit _ 16r20000. WordIndexableBit _ 16r10000. ClassIndexMask _ 16rFFFC. ClassIndexShift _ 2. HeaderTypeMask _ 3. HeaderTypeFree _ 0. HeaderTypeForward _ 1. HeaderTypeOneWord _ 2. HeaderTypeTwoWord _ 3. HeaderTypeIsObjectBit _ 2. AllButMarkBits _ MarkBitsMask bitInvert32. AllButHeaderTypeBits _ HeaderTypeMask bitInvert32. NilOop _ 0. NilClassIndex _ 1. SmallIntegerClassIndex _ 2. ! ! !ObjMemV1 class methodsFor: 'translation' stamp: 'jm 10/2/2006 20:17'! declareCVarsIn: aCCodeGenerator "No declarations yet." ! ! !ObjMemV1 class methodsFor: 'translation' stamp: 'jm 10/2/2006 20:17'! translate: fileName doInlining: inlineFlag "Time millisecondsToRun: [ ObjMem translate: 'objMem.c' doInlining: true. Smalltalk beep]" | cg | ObjMem initialize. cg _ CCodeGenerator new initialize. self declareCVarsIn: cg. cg addClass: ObjMem. cg storeCodeOnFile: fileName doInlining: inlineFlag. ! ! Object is the root class for almost all of the other classes in the class hierarchy. The exceptions are ProtoObject (the superclass of Object) and its subclasses. Class Object provides default behavior common to all normal objects, such as access, copying, comparison, error handling, message sending, and reflection. Also utility messages that all objects should respond to are defined here. Object has no instance variables, nor should any be added. This is due to several classes of objects that inherit from Object that have special implementations (SmallInteger and UndefinedObject for example) or the VM knows about and depends on the structure and layout of certain standard classes. Class Variables: DependentsFields an IdentityDictionary Provides a virtual 'dependents' field so that any object may have one or more dependent views, synchronized by the changed:/update: protocol. Note that class Model has a real slot for its dependents, and overrides the associated protocol with more efficient implementations. Because Object is the root of the inheritance tree, methods are often defined in Object to give all objects special behaviors needed by certain subsystems or applications, or to respond to certain general test messages such as isMorph.! !Object methodsFor: 'accessing' stamp: 'di 3/29/1999 11:39'! at: index "Primitive. Assumes receiver is indexable. Answer the value of an indexable element in the receiver. Fail if the argument index is not an Integer or is out of bounds. Essential. See Object documentation whatIsAPrimitive." <primitive: 60> index isInteger ifTrue: [self class isVariable ifTrue: [self errorSubscriptBounds: index] ifFalse: [self error: (self class name) , 's are not indexable']]. index isNumber ifTrue: [^self at: index asInteger] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'accessing' stamp: 'di 3/29/1999 11:41'! at: index put: value "Primitive. Assumes receiver is indexable. Store the argument value in the indexable element of the receiver indicated by index. Fail if the index is not an Integer or is out of bounds. Or fail if the value is not of the right type for this kind of collection. Answer the value that was stored. Essential. See Object documentation whatIsAPrimitive." <primitive: 61> index isInteger ifTrue: [self class isVariable ifTrue: [(index >= 1 and: [index <= self size]) ifTrue: [self errorImproperStore] ifFalse: [self errorSubscriptBounds: index]] ifFalse: [self error: (self class name) , 's are not indexable']]. index isNumber ifTrue: [^self at: index asInteger put: value] ifFalse: [self errorNonIntegerIndex]! ! !Object methodsFor: 'accessing' stamp: 'jm 10/27/2003 09:20'! headerWords "Answer the number of header words for this object." | cl contentsBytes | cl _ self class. contentsBytes _ cl instSize * 4. cl isVariable ifTrue: [ contentsBytes _ contentsBytes + (cl isBytes ifTrue: [self basicSize roundUpTo: 4] ifFalse: [self basicSize * 4])]. contentsBytes > 255 ifTrue: [^ 3]. ^ (cl indexIfCompact > 0) ifTrue: [1] ifFalse: [2] ! ! !Object methodsFor: 'accessing' stamp: 'di 3/29/1999 13:10'! size "Primitive. Answer the number of indexable variables in the receiver. This value is the same as the largest legal subscript. Essential. See Object documentation whatIsAPrimitive." <primitive: 62> self class isVariable ifFalse: [self errorNotIndexable]. ^ 0! ! !Object methodsFor: 'accessing' stamp: 'jm 10/27/2003 09:11'! totalBytes "Answer the number of bytes consumed by this object, including its object header." | cl contentsBytes isCompact headerBytes | cl _ self class. contentsBytes _ cl instSize * 4. cl isVariable ifTrue: [ contentsBytes _ contentsBytes + (cl isBytes ifTrue: [self basicSize roundUpTo: 4] ifFalse: [self basicSize * 4])]. isCompact _ cl indexIfCompact > 0. headerBytes _ contentsBytes > 255 ifTrue: [12] ifFalse: [isCompact ifTrue: [4] ifFalse: [8]]. ^ headerBytes + contentsBytes ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:54'! ifNil: nilBlock "Just return self, since I am not nil." ^ self ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:48'! ifNil: nilBlock ifNotNil: notNilBlock "Evaluate notNilBlock, since I am not nil." ^ notNilBlock value ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:55'! ifNotNil: notNilBlock "Evaluate notNilBlock, since I am not nil." ^ notNilBlock value ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:55'! ifNotNil: notNilBlock ifNil: nilBlock "Evaluate notNilBlock, since I am not nil." ^ notNilBlock value ! ! !Object methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! isBehavior "Return true if the receiver is a behavior. Note: Do not override in any class except behavior." ^false! ! !Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'! isFloat "Overridden to return true in Float, natch" ^ false! ! !Object methodsFor: 'testing' stamp: 'len 1/13/98 21:18'! isFraction "Answer true if the receiver is a Fraction." ^ false! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:33'! isNil "Coerces nil to true and everything else to false." ^false! ! !Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'! isPoint "Overridden to return true in Point." ^ false! ! !Object methodsFor: 'testing' stamp: 'jm 10/27/2003 07:36'! isSmallInteger ^ false ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:56'! notNil "Answer true, since I am not nil." ^ true ! ! !Object methodsFor: 'testing' stamp: 'jm 5/15/2003 22:33'! pointsTo: anObject "This method returns true if self contains a pointer to anObject, and returns false otherwise" <primitive: 132> 1 to: self class instSize do: [:i | (self instVarAt: i) == anObject ifTrue: [^ true]]. 1 to: self basicSize do: [:i | (self basicAt: i) == anObject ifTrue: [^ true]]. ^ false! ! !Object methodsFor: 'testing' stamp: 'sw 10/20/1999 14:52'! stepAt: millisecondClockValue in: aWindow ^ self stepIn: aWindow! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:16'! stepIn: aWindow ^ self step! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:21'! stepTime ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:22'! stepTimeIn: aSystemWindow ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !Object methodsFor: 'testing' stamp: 'di 1/8/1999 15:04'! wantsSteps "Overridden by morphic classes whose instances want to be stepped, or by model classes who want their morphic views to be stepped." ^ false! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:26'! wantsStepsIn: aSystemWindow ^ self wantsSteps! ! !Object methodsFor: 'comparing' stamp: 'jm 5/15/2003 22:58'! == anObject "Primitive. Answer true if the receiver and the argument are the same object (have the same object pointer). Do not redefine the message == in any other class!! Essential. No Lookup. Do not override in any subclass." <primitive: 110> self primitiveFailed ! ! !Object methodsFor: 'comparing' stamp: 'jm 5/15/2003 22:34'! identityHash "Answer a SmallInteger whose value is related to the receiver's identity. This method must not be overridden, except by SmallInteger. Primitive. Fails if the receiver is a SmallInteger. Essential. See Object documentation whatIsAPrimitive. Do not override." <primitive: 75> self primitiveFailed! ! !Object methodsFor: 'comparing' stamp: 'jm 5/15/2003 22:57'! ~~ anObject "Answer true if the argument are not the same object (do not have the same object pointer)." self == anObject ifTrue: [^ false] ifFalse: [^ true] ! ! !Object methodsFor: 'copying' stamp: 'tk 11/27/1998 09:00'! copyFrom: anotherObject "Copy to myself all instance variables I have in common with anotherObject. This is dangerous because it ignores an object's control over its own inst vars. " | mine his | mine _ self class allInstVarNames. his _ anotherObject class allInstVarNames. 1 to: (mine size min: his size) do: [:ind | (mine at: ind) = (his at: ind) ifTrue: [ self instVarAt: ind put: (anotherObject instVarAt: ind)]]. self class isVariable & anotherObject class isVariable ifTrue: [ 1 to: (self basicSize min: anotherObject basicSize) do: [:ind | self basicAt: ind put: (anotherObject basicAt: ind)]].! ! !Object methodsFor: 'copying' stamp: 'di 6/9/1999 14:44'! copySameFrom: otherObject "Copy to myself all instance variables named the same in otherObject. This ignores otherObject's control over its own inst vars." | myInstVars otherInstVars match | myInstVars _ self class allInstVarNames. otherInstVars _ otherObject class allInstVarNames. myInstVars doWithIndex: [:each :index | (match _ otherInstVars indexOf: each) > 0 ifTrue: [self instVarAt: index put: (otherObject instVarAt: match)]] ! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:24'! addDependent: anObject "Make the given object one of the receiver's dependents." | dependents | dependents _ self dependents. (dependents includes: anObject) ifFalse: [self myDependents: (dependents copyWith: anObject)]. ^ anObject! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:53'! breakDependents "Remove all of the receiver's dependents." self myDependents: nil! ! !Object methodsFor: 'dependents access' stamp: 'jm 5/23/2003 20:38'! canDiscardEdits "Answer true if none of the views on this model has unaccepted edits that matter." self dependents do: [:each | each = self ifFalse: [each canDiscardEdits ifFalse: [^ false]]]. ^ true ! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:58'! dependents "Answer a collection of objects that are 'dependent' on the receiver; that is, all objects that should be notified if the receiver changes." ^ self myDependents ifNil: [#()]! ! !Object methodsFor: 'dependents access' stamp: 'jm 5/23/2003 20:40'! hasUnacceptedEdits "Answer true if any of the views on this object has unaccepted edits." self dependents do: [:each | each = self ifFalse: [each hasUnacceptedEdits ifTrue: [^ true]]]. ^ false ! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:55'! myDependents "Private. Answer a list of all the receiver's dependents." ^ DependentsFields at: self ifAbsent: []! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 19:52'! myDependents: aCollectionOrNil "Private. Set (or remove) the receiver's dependents list." aCollectionOrNil ifNil: [DependentsFields removeKey: self ifAbsent: []] ifNotNil: [DependentsFields at: self put: aCollectionOrNil]! ! !Object methodsFor: 'dependents access' stamp: 'jm 10/4/2002 17:27'! release "Remove references to objects that may refer to the receiver. This message should be overridden by subclasses with any cycles, in which case the subclass should also include the expression super release." self breakDependents. ! ! !Object methodsFor: 'dependents access' stamp: 'sma 2/29/2000 20:23'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." | dependents | dependents _ self dependents reject: [:each | each == anObject]. self myDependents: (dependents isEmpty ifFalse: [dependents]). ^ anObject! ! !Object methodsFor: 'updating' stamp: 'sw 10/31/1999 00:15'! noteSelectionIndex: anInteger for: aSymbol "backstop"! ! !Object methodsFor: 'updating' stamp: 'sma 2/29/2000 20:05'! update: aParameter "Receive a change notice from an object of whom the receiver is a dependent. The default behavior is to do nothing; a subclass might want to change itself in some way." ^ self! ! !Object methodsFor: 'updating' stamp: 'sw 10/19/1999 14:39'! updateListsAndCodeIn: aWindow self canDiscardEdits ifFalse: [^ self]. aWindow updatablePanes do: [:aPane | aPane verifyContents]! ! !Object methodsFor: 'updating' stamp: 'jm 8/20/1998 18:26'! windowIsClosing "This message is used to inform a models that its window is closing. Most models do nothing, but some, such as the Debugger, must do some cleanup. Note that this mechanism must be used with care by models that support multiple views, since one view may be closed while others left open." ! ! !Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:28'! longPrintOn: aStream "Append to the argument, aStream, the names and values of all of the receiver's instance variables." self class allInstVarNames doWithIndex: [:title :index | aStream nextPutAll: title; nextPut: $:; space; tab; print: (self instVarAt: index); cr]! ! !Object methodsFor: 'printing' stamp: 'sw 9/2/1999 15:18'! longPrintString "Answer a String whose characters are a description of the receiver." ^ String streamContents: [:aStream | self longPrintOn: aStream]! ! !Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:31'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." | title | title _ self class name. aStream nextPutAll: (title first isVowel ifTrue: ['an '] ifFalse: ['a ']); nextPutAll: title! ! !Object methodsFor: 'printing' stamp: 'sma 6/1/2000 09:22'! printString "Answer a String whose characters are a description of the receiver. If you want to print without a character limit, use fullPrintString." ^ self printStringLimitedTo: 50000! ! !Object methodsFor: 'printing' stamp: 'tk 5/7/1999 16:20'! printStringLimitedTo: limit "Answer a String whose characters are a description of the receiver. If you want to print without a character limit, use fullPrintString." | limitedString | limitedString _ String streamContents: [:s | self printOn: s] limitedTo: limit. limitedString size < limit ifTrue: [^ limitedString]. ^ limitedString , '...etc...'! ! !Object methodsFor: 'printing' stamp: 'jm 12/29/2003 11:23'! putString: aString "For MicroSqueak. Write the given string to the Transcript." Transcript nextPutAll: aString; endEntry. ! ! !Object methodsFor: 'printing' stamp: 'jm 12/29/2003 11:24'! putcr "For MicroSqueak. Write a carriage return to the Transcript." Transcript cr. ! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! perform: aSymbol "Send the unary selector, aSymbol, to the receiver. Fail if the number of arguments expected by the selector is not zero. Primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (Array new: 0)! ! !Object methodsFor: 'message handling' stamp: 'sw 10/30/1998 18:27'! perform: selector orSendTo: otherTarget "If I wish to intercept and handle selector myself, do it; else send it to otherTarget" ^ otherTarget perform: selector! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! perform: aSymbol with: anObject "Send the selector, aSymbol, to the receiver with anObject as its argument. Fail if the number of arguments expected by the selector is not one. Primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (Array with: anObject)! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! perform: aSymbol with: firstObject with: secondObject "Send the selector, aSymbol, to the receiver with the given arguments. Fail if the number of arguments expected by the selector is not two. Primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject)! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:51'! perform: aSymbol with: firstObject with: secondObject with: thirdObject "Send the selector, aSymbol, to the receiver with the given arguments. Fail if the number of arguments expected by the selector is not three. Primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 83> ^ self perform: aSymbol withArguments: (Array with: firstObject with: secondObject with: thirdObject)! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:55'! perform: selector withArguments: argArray "Send the selector, aSymbol, to the receiver with arguments in argArray. Fail if the number of arguments expected by the selector does not match the size of argArray. Primitive. Optional. See Object documentation whatIsAPrimitive." <primitive: 84> ^ self perform: selector withArguments: argArray inSuperclass: self class! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 08:00'! perform: selector withArguments: argArray inSuperclass: lookupClass "NOTE: This is just like perform:withArguments:, except that the message lookup process begins, not with the receivers's class, but with the supplied superclass instead. It will fail if lookupClass cannot be found among the receiver's superclasses. Primitive. Essential. See Object documentation whatIsAPrimitive." <primitive: 100> (selector isMemberOf: Symbol) ifFalse: [^ self error: 'selector argument must be a Symbol']. (selector numArgs = argArray size) ifFalse: [^ self error: 'incorrect number of arguments']. (self class == lookupClass or: [self class inheritsFrom: lookupClass]) ifFalse: [^ self error: 'lookupClass is not in my inheritance chain']. self primitiveFailed! ! !Object methodsFor: 'error handling' stamp: 'jm 5/22/2003 19:32'! assert: aBlock "Raise an error if aBlock does not evaluates to true." aBlock value ifFalse: [self error: 'Assertion failed.']. ! ! !Object methodsFor: 'error handling' stamp: 'di 3/19/1999 10:31'! cannotInterpret: aMessage "Handle the fact that there was an attempt to send the given message to the receiver but a null methodDictionary was encountered while looking up the message selector. Hopefully this is the result of encountering a stub for a swapped out class which induces this exception on purpose." "If this is the result of encountering a swap-out stub, then simulating the lookup in Smalltalk should suffice to install the class properly, and the message may be resent." | handler errorString | (self class lookupSelector: aMessage selector) == nil ifFalse: ["Simulated lookup succeeded -- resend the message." ^ aMessage sentTo: self]. "Could not recover by simulated lookup -- it's an error" errorString _ 'MethodDictionary fault'. (handler _ Processor activeProcess errorHandler) notNil ifTrue: [handler value: errorString value: self] ifFalse: [Debugger openContext: thisContext label: errorString contents: thisContext shortStack]. ^ aMessage sentTo: self! ! !Object methodsFor: 'error handling' stamp: 'sma 5/28/2000 15:48'! confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." "nil confirm: 'Are you hungry?'" ^ PopUpMenu confirm: queryString! ! !Object methodsFor: 'error handling' stamp: 'sma 5/28/2000 15:55'! confirm: aString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." ^ PopUpMenu confirm: aString orCancel: cancelBlock! ! !Object methodsFor: 'error handling' stamp: 'jm 5/23/2003 12:43'! doesNotUnderstand: aMessage "Error: an attempt was made to send the given message but the receiver does not understand this message. This message is sent by the virtual machine when a message is sent to an object that does not define a method for the message selector." "Example: 3 width" self error: 'Message not understood: ', aMessage selector. ^ aMessage sentTo: self ! ! !Object methodsFor: 'error handling' stamp: 'jm 5/15/2003 20:49'! error: aString "The default behavior for error: is the same as halt:. The code is replicated in order to avoid showing an extra level of message sending in the Debugger. This additional message is the one a subclass should override in order to change the error handling behavior." | handler | (handler _ Processor activeProcess errorHandler) notNil ifTrue: [handler value: aString value: self] ifFalse: [Debugger openContext: thisContext label: aString contents: thisContext shortStack] "nil error: 'error message'."! ! !Object methodsFor: 'error handling' stamp: 'jm 5/22/2003 19:26'! halt "This message is used to insert breakpoints during debugging." "Example: nil halt" self halt: 'Halt encountered.' ! ! !Object methodsFor: 'error handling' stamp: 'jm 5/23/2003 12:41'! halt: aString "This is the typical message to use for inserting breakpoints during debugging. It creates and schedules a Debugger with the given string as the label." "Example: (self halt: 'Hello!!')" Debugger openContext: thisContext label: aString contents: thisContext shortStack. ! ! !Object methodsFor: 'user interface' stamp: 'sw 10/4/1999 08:13'! addModelItemsToWindowMenu: aMenu "aMenu is being constructed to be presented to the user in response to the user's pressing on the menu widget in the title bar of a morphic window. Here, the model is given the opportunity to add any model-specific items to the menu, whose default target is the SystemWindow itself."! ! !Object methodsFor: 'user interface' stamp: 'RAA 6/21/1999 11:35'! asExplorerString ^self asString! ! !Object methodsFor: 'user interface' stamp: 'jm 11/22/2002 19:03'! beep "Emit a short alert sound. Do nothing if the primitive fails." <primitive: 140> ! ! !Object methodsFor: 'user interface' stamp: 'sw 5/8/2000 01:59'! browseHierarchy ^ HierarchyBrowser newFor: self class "(2@7) browseHierarchy"! ! !Object methodsFor: 'user interface' stamp: 'jm 5/31/2003 16:45'! defaultBackgroundColor "Answer the color to be used as the base window color for a window whose model is an object of the receiver's class" ^ Preferences windowColorFor: self class name ! ! !Object methodsFor: 'user interface' stamp: 'RAA 6/21/1999 11:27'! hasContentsInExplorer ^self basicSize > 0 or: [self class allInstVarNames isEmpty not] ! ! !Object methodsFor: 'user interface' stamp: 'sma 5/28/2000 15:59'! inform: aString "Display a message for the user to read and then dismiss. 6/9/96 sw" aString isEmptyOrNil ifFalse: [PopUpMenu inform: aString]! ! !Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:26'! modelSleep "A window with me as model is being exited or collapsed or closed. Default response is no-op" ! ! !Object methodsFor: 'user interface' stamp: 'di 5/11/1999 22:01'! modelWakeUp "A window with me as model is being entered or expanded. Default response is no-op" ! ! !Object methodsFor: 'user interface' stamp: 'sw 10/16/1999 22:45'! modelWakeUpIn: aWindow "A window with me as model is being entered or expanded. Default response is no-op" self modelWakeUp! ! !Object methodsFor: 'user interface' stamp: 'sw 3/8/1999 15:27'! mouseUpBalk: evt "A button I own got a mouseDown, but the user moved out before letting up. Certain kinds of objects (so-called 'radio buttons', for example, and other structures that must always have some selection, e.g. PaintBoxMorph) wish to take special action in this case; this default does nothing." ! ! !Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'! windowActiveOnFirstClick "Return true if my window should be active on first click." ^ false! ! !Object methodsFor: 'user interface' stamp: 'di 6/10/1998 15:06'! windowReqNewLabel: labelString "My window's title has been edited. Return true if this is OK, and override for further behavior." ^ true! ! !Object methodsFor: 'system primitives' stamp: 'jm 5/15/2003 22:35'! become: otherObject "Primitive. Swap the object pointers of the receiver and the argument. All variables in the entire system that used to point to the receiver now point to the argument, and vice-versa. Fails if either object is a SmallInteger" (Array with: self) elementsExchangeIdentityWith: (Array with: otherObject)! ! !Object methodsFor: 'system primitives' stamp: 'di 1/9/1999 15:19'! becomeForward: otherObject "Primitive. All variables in the entire system that used to point to the receiver now point to the argument. Fails if either argument is a SmallInteger." (Array with: self) elementsForwardIdentityTo: (Array with: otherObject)! ! !Object methodsFor: 'system primitives' stamp: 'jm 5/15/2003 22:36'! nextInstance "Primitive. Answer the next instance after the receiver in the enumeration of all instances of this class. Fails if all instances have been enumerated. Essential. See Object documentation whatIsAPrimitive." <primitive: 78> ^nil! ! !Object methodsFor: 'system primitives' stamp: 'jm 5/15/2003 22:36'! nextObject "Primitive. Answer the next object after the receiver in the enumeration of all objects. Return 0 when all objects have been enumerated." <primitive: 139> self primitiveFailed.! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'ar 5/25/2000 20:27'! tryNamedPrimitive: arg1 with: arg2 with: arg3 with: arg4 with: arg5 with: arg6 with: arg7 with: arg8 "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive:'' module:''> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'system primitives' stamp: 'di 2/10/1999 22:16'! tryPrimitive: primIndex withArgs: argumentArray "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." <primitive: 118> ^ ContextPart primitiveFailToken! ! !Object methodsFor: 'private' stamp: 'di 3/29/1999 12:39'! errorNotIndexable "Create an error notification that the receiver is not indexable." self error: (self class name) , 's are not indexable'! ! !Object methodsFor: 'private' stamp: 'sma 5/27/2000 17:49'! primitiveError: aString "This method is called when the error handling results in a recursion in calling on error: or halt or halt:." | context | (String streamContents: [:s | s nextPutAll: '**System error handling failed**'. s cr; nextPutAll: aString. context _ thisContext sender sender. 20 timesRepeat: [context == nil ifFalse: [s cr; print: (context _ context sender)]]. s cr; nextPutAll: '**Type CR to enter an emergency evaluator.**'. s cr; nextPutAll: '**Type any other character to restart.**']) displayAt: 0 @ 0. [Sensor keyboardPressed] whileFalse. Sensor keyboard == Character cr ifTrue: [Transcripter emergencyEvaluator]. Smalltalk isMorphic ifTrue: [^ World install "To init hand events and redisplay world"]. ScheduledControllers searchForActiveController! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! adaptToFloat: rcvr andSend: selector "If no method has been provided for adapting an object to a Float, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:14'! adaptToFraction: rcvr andSend: selector "If no method has been provided for adapting an object to a Fraction, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: 'converting' stamp: 'di 11/9/1998 12:15'! adaptToInteger: rcvr andSend: selector "If no method has been provided for adapting an object to a Integer, then it may be adequate to simply adapt it to a number." ^ self adaptToNumber: rcvr andSend: selector! ! !Object methodsFor: 'converting' stamp: 'sma 5/12/2000 17:39'! asOrderedCollection "Answer an OrderedCollection with the receiver as its only element." ^ OrderedCollection with: self! ! !Object methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^self! ! !Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 17:31'! contentsChanged self changed: #contents! ! !Object methodsFor: 'macpal' stamp: 'sw 1/28/1999 12:02'! currentEvent "Answer the current Morphic event. This method never returns nil." ^ self currentHand lastEvent! ! !Object methodsFor: 'macpal' stamp: 'di 6/7/1999 15:42'! currentHand "Return a usable HandMorph -- the one associated with the object's current environment. This method will always return a hand, even if it has to conjure one up as a last resort. If a particular hand is actually handling events at the moment (such as a remote hand or a ghost hand), it will be returned." ^ self currentWorld primaryHand! ! !Object methodsFor: 'macpal' stamp: 'di 11/27/1999 07:34'! currentWorld "Answer a morphic world that is the current UI focus. If in a morphic project, it's that project's world. If in an mvc project, it is the topmost morphic-mvc-window's worldMorph. If in an mvc project that has no morphic-mvc-windows, then it's just some existing worldmorph instance. If in an mvc project in a Squeak that has NO WorldMorph instances, one is created. This method will never return nil, it will always return its best effort at returning a relevant world morph, but if need be -- if there are no worlds anywhere, it will create a new one." | aView aSubview | World ifNotNil: [^ World]. aView _ ScheduledControllers controllerSatisfying: [:ctrl | (aSubview _ ctrl view firstSubView) notNil and: [aSubview model isMorph and: [aSubview model isWorldMorph]]]. ^ aView ifNotNil: [aSubview model] ifNil: [MVCWiWPasteUpMorph newWorldForProject: nil]! ! !Object methodsFor: 'translation support' stamp: 'jm 12/29/2003 22:02'! cCoerce: oop to: type "For translation only; noop when running in Smalltalk." ^ oop ! ! !Object methodsFor: 'translation support' stamp: 'jm 12/29/2003 22:02'! export: ignored "For translation only; noop when running in Smalltalk." ! ! !Object methodsFor: 'translation support' stamp: 'jm 12/29/2003 22:02'! inline: inlineFlag "For translation only; noop when running in Smalltalk." ! ! !Object methodsFor: 'translation support' stamp: 'jm 12/29/2003 22:02'! sharedCodeNamed: caseName inCase: caseNum "For translation only; noop when running in Smalltalk." ! ! !Object methodsFor: 'translation support' stamp: 'jm 12/29/2003 22:02'! var: varSymbol declareC: declString "For translation only; noop when running in Smalltalk." ! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:26'! actAsExecutor "Prepare the receiver to act as executor for any resources associated with it" self breakDependents! ! !Object methodsFor: 'finalization' stamp: 'ar 3/20/98 22:19'! executor "Return an object which can act as executor for finalization of the receiver" ^self shallowCopy actAsExecutor! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:27'! finalize "Finalize the resource associated with the receiver. This message should only be sent during the finalization process. There is NO garantuee that the resource associated with the receiver hasn't been free'd before so take care that you don't run into trouble - this all may happen with interrupt priority."! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 18:38'! retryWithGC: execBlock until: testBlock "Retry execBlock as long as testBlock returns false. Do an incremental GC after the first try, a full GC after the second try." | blockValue | blockValue := execBlock value. (testBlock value: blockValue) ifTrue:[^blockValue]. Smalltalk garbageCollectMost. blockValue := execBlock value. (testBlock value: blockValue) ifTrue:[^blockValue]. Smalltalk garbageCollect. ^execBlock value.! ! !Object methodsFor: 'initialization' stamp: 'jm 5/29/2003 21:43'! initialize "Initialize this object. Usually called by new when a new object is created. This default implementation does nothing."! ! !Object class methodsFor: 'instance creation' stamp: 'jm 5/29/2003 21:45'! new ^ self basicNew initialize ! ! !Object class methodsFor: 'instance creation' stamp: 'di 6/9/1999 14:27'! newFrom: aSimilarObject "Create an object that has similar contents to aSimilarObject. If the classes have any instance varaibles with the same names, copy them across. If this is bad for a class, override this method." ^ self basicNew copySameFrom: aSimilarObject! ! !Object class methodsFor: 'instance creation' stamp: 'tk 4/18/1999 07:05'! readFrom: aStream "Create an object based on the contents of aStream." | object ok | ok _ (aStream isKindOf: Stream) or: [aStream isKindOf: String]. (ok or: [aStream isKindOf: Text]) ifFalse: [^ self error: 'expected String or Text']. object _ Compiler evaluate: aStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: 'private' stamp: 'sma 2/29/2000 20:12'! initializeDependentsFields DependentsFields _ IdentityDictionary new "Object initializeDependentsFields"! ! ObjectMemory comment: 'This class describes a 32-bit direct-pointer object memory for Smalltalk. The model is very simple in principle: a pointer is either a SmallInteger or a 32-bit direct object pointer. SmallIntegers are tagged with a low-order bit equal to 1, and an immediate 31-bit 2s-complement signed value in the rest of the word. All object pointers point to a header, which may be followed by a number of data fields. This object memory achieves considerable compactness by using a variable header size (the one complexity of the design). The format of the 0th header word is as follows: 3 bits reserved for gc (mark, old, dirty) 12 bits object hash (for HashSets) 5 bits compact class index 4 bits object format 6 bits object size in 32-bit words 2 bits header type (0: 3-word, 1: 2-word, 2: forbidden, 3: 1-word) If a class is in the compact class table, then this is the only header information needed. If it is not, then it will have another header word at offset -4 bytes with its class in the high 30 bits, and the header type repeated in its low 2 bits. It the objects size is greater than 255 bytes, then it will have yet another header word at offset -8 bytes with its full word size in the high 30 bits and its header type repeated in the low two bits. The object format field provides the remaining information as given in the formatOf: method (including isPointers, isVariable, isBytes, and the low 2 size bits of byte-sized objects). This implementation includes incremental (2-generation) and full garbage collection, each with compaction and rectification of direct pointers. It also supports a bulk-become (exchange object identity) feature that allows many objects to be becomed at once, as when all instances of a class must be grown or shrunk.'! !ObjectMemory methodsFor: 'initialization' stamp: 'di 12/18/1998 13:25'! adjustAllOopsBy: bytesToShift "Adjust all oop references by the given number of bytes. This is done just after reading in an image when the new base address of the object heap is different from the base address in the image." "ar 10/7/1998 - Clear the RootBit of all objects" | oop header | "Note: Don't bypass this method even if bytesToShift is zero until the RootBit problem has been fixed in the appropriate places." "bytesToShift = 0 ifTrue: [ ^ nil ]." oop _ self firstObject. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifFalse: [ header _ self longAt: oop. self longAt: oop put: (header bitAnd: AllButRootBit). self adjustFieldsAndClassOf: oop by: bytesToShift. ]. oop _ self objectAfter: oop. ]. ! ! !ObjectMemory methodsFor: 'initialization'! adjustFieldsAndClassOf: oop by: offsetBytes "Adjust all pointers in this object by the given offset." | fieldAddr fieldOop classHeader newClassOop | fieldAddr _ oop + (self lastPointerOf: oop). [fieldAddr > oop] whileTrue: [ fieldOop _ self longAt: fieldAddr. (self isIntegerObject: fieldOop) ifFalse: [ self longAt: fieldAddr put: (fieldOop + offsetBytes). ]. fieldAddr _ fieldAddr - 4. ]. (self headerType: oop) ~= HeaderTypeShort ifTrue: [ "adjust class header if not a compact class" classHeader _ self longAt: (oop - 4). newClassOop _ (classHeader bitAnd: AllButTypeMask) + offsetBytes. self longAt: (oop - 4) put: (newClassOop bitOr: (classHeader bitAnd: TypeMask)). ]. ! ! !ObjectMemory methodsFor: 'initialization' stamp: 'jm 11/25/1998 16:35'! initializeMemoryFirstFree: firstFree "Initialize endOfMemory to the top of oop storage space, reserving some space for forwarding blocks, and create the freeBlock from which space is allocated. Also create a fake free chunk at endOfMemory to act as a sentinal for memory scans." "Note: The amount of space reserved for forwarding blocks should be chosen to ensure that incremental compactions can usually be done in a single pass. However, there should be enough forwarding blocks so a full compaction can be done in a reasonable number of passes, say ten. (A full compaction requires N object-moving passes, where N = number of non-garbage objects / number of forwarding blocks)." | fwdBlockBytes | "reserve space for forwarding blocks" fwdBlockBytes _ MinimumForwardTableBytes. (memoryLimit - fwdBlockBytes) >= (firstFree + BaseHeaderSize) ifFalse: [ "reserve enough space for a minimal free block of BaseHeaderSize bytes" fwdBlockBytes _ memoryLimit - (firstFree + BaseHeaderSize). ]. "set endOfMemory and initialize freeBlock" endOfMemory _ memoryLimit - fwdBlockBytes. freeBlock _ firstFree. self setSizeOfFree: freeBlock to: (endOfMemory - firstFree). "bytes available for oops" "make a fake free chunk at endOfMemory for use as a sentinal in memory scans" self setSizeOfFree: endOfMemory to: BaseHeaderSize. DoAssertionChecks ifTrue: [ ((freeBlock < endOfMemory) and: [endOfMemory < memoryLimit]) ifFalse: [ self error: 'error in free space computation' ]. (self oopFromChunk: endOfMemory) = endOfMemory ifFalse: [ self error: 'header format must have changed' ]. (self objectAfter: freeBlock) = endOfMemory ifFalse: [ self error: 'free block not properly initialized' ]. ].! ! !ObjectMemory methodsFor: 'initialization' stamp: 'jm 12/6/1998 17:26'! initializeObjectMemory: bytesToShift "Initialize object memory variables at startup time. Assume endOfMemory is initially set (by the image-reading code) to the end of the last object in the image. Initialization redefines endOfMemory to be the end of the object allocation area based on the total available memory, but reserving some space for forwarding blocks." "Assume: image reader initializes the following variables: memory endOfMemory memoryLimit specialObjectsOop lastHash " self inline: false. "set the start of the young object space" youngStart _ endOfMemory. self initializeMemoryFirstFree: endOfMemory. "initializes endOfMemory, freeBlock" "image may be at a different address; adjust oops for new location" self adjustAllOopsBy: bytesToShift. specialObjectsOop _ specialObjectsOop + bytesToShift. "heavily used special objects" nilObj _ self splObj: NilObject. falseObj _ self splObj: FalseObject. trueObj _ self splObj: TrueObject. rootTableCount _ 0. child _ 0. field _ 0. parentField _ 0. freeContexts _ NilContext. allocationCount _ 0. lowSpaceThreshold _ 0. signalLowSpace _ false. compStart _ 0. compEnd _ 0. fwdTableNext _ 0. fwdTableLast _ 0. remapBufferCount _ 0. allocationsBetweenGCs _ 4000. "do incremental GC after this many allocations" tenuringThreshold _ 2000. "tenure all suriving objects if count is over this threshold" "garbage collection statistics" statFullGCs _ 0. statFullGCMSecs _ 0. statIncrGCs _ 0. statIncrGCMSecs _ 0. statTenures _ 0. statRootTableOverflows _ 0. displayBits _ 0. "support for the Acorn VM; ignored if zero" ! ! !ObjectMemory methodsFor: 'interpreter access'! fetchByte: byteIndex ofObject: oop ^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'di 11/27/1998 11:19'! fetchClassOf: oop | ccIndex | self inline: true. (self isIntegerObject: oop) ifTrue: [ ^ self splObj: ClassInteger ]. ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F. ccIndex = 0 ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop) ]. ! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'di 11/27/1998 11:18'! fetchClassOfNonInt: oop | ccIndex | self inline: true. ccIndex _ ((self baseHeader: oop) >> 12) bitAnd: 16r1F. ccIndex = 0 ifTrue: [^ (self classHeader: oop) bitAnd: AllButTypeMask ] ifFalse: ["look up compact class" ^ self fetchPointer: ccIndex - 1 ofObject: (self fetchPointer: CompactClasses ofObject: specialObjectsOop)] ! ! !ObjectMemory methodsFor: 'interpreter access'! fetchPointer: fieldIndex ofObject: oop ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! ! !ObjectMemory methodsFor: 'interpreter access'! fetchWord: fieldIndex ofObject: oop ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2)! ! !ObjectMemory methodsFor: 'interpreter access'! fetchWordLengthOf: objectPointer | sz | sz _ self sizeBitsOf: objectPointer. ^ (sz - BaseHeaderSize) >> 2! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'jm 12/6/1998 17:12'! instantiateClass: classPointer indexableSize: size | hash header1 header2 cClass byteSize format inc binc header3 hdrSize fillWord newObj sizeHiBits | " NOTE: This method supports the backward-compatible split instSize field of the class format word. The sizeHiBits will go away and other shifts change by 2 when the split fields get merged in an (incompatible) image change. " self inline: false. DoAssertionChecks ifTrue: [ size < 0 ifTrue: [ self error: 'cannot have a negative indexable field count' ]]. hash _ self newObjectHash. header1 _ self formatOfClass: classPointer. "Low 2 bits are 0" sizeHiBits _ (header1 bitAnd: 16r60000) >> 9. header1 _ (header1 bitAnd: 16r1FFFF) bitOr: ((hash << HashBitsOffset) bitAnd: HashBits). header2 _ classPointer. header3 _ 0. cClass _ header1 bitAnd: CompactClassMask. "compact class field from format word" byteSize _ (header1 bitAnd: SizeMask) + sizeHiBits. "size in bytes -- low 2 bits are 0" format _ (header1 >> 8) bitAnd: 16rF. format < 8 ifTrue: [ "Bitmaps and Arrays" inc _ size * 4. ] ifFalse: [ "Strings and Methods" inc _ (size + 3) bitAnd: AllButTypeMask. "round up" binc _ 3 - ((size + 3) bitAnd: 3). "odd bytes" "low bits of byte size go in format field" header1 _ header1 bitOr: (binc << 8). ]. (byteSize + inc) > 255 ifTrue: [ "requires size header word" header3 _ byteSize + inc. header1 _ header1 - (byteSize bitAnd: 16rFF). "Clear qsize field" ] ifFalse: [ header1 _ header1 + inc. ]. byteSize _ byteSize + inc. header3 > 0 ifTrue: [ "requires full header" hdrSize _ 3. ] ifFalse: [ cClass = 0 ifTrue: [ hdrSize _ 2 ] ifFalse: [ hdrSize _ 1 ]. ]. format <= 4 "if pointers, fill with nil oop" ifTrue: [ fillWord _ nilObj ] ifFalse: [ fillWord _ 0 ]. newObj _ self allocate: byteSize headerSize: hdrSize h1: header1 h2: header2 h3: header3 doFill: true with: fillWord. ^ newObj! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'di 12/4/1998 02:36'! instantiateContext: classPointer sizeInBytes: sizeInBytes "This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word." | hash header1 header2 hdrSize | hash _ self newObjectHash. header1 _ ((hash << HashBitsOffset) bitAnd: HashBits) bitOr: (self formatOfClass: classPointer). header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask)). header2 _ classPointer. (header1 bitAnd: CompactClassMask) = 0 "is compact class field from format word zero?" ifTrue: [ hdrSize _ 2 ] ifFalse: [ hdrSize _ 1 ]. ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: false with: 0! ! !ObjectMemory methodsFor: 'interpreter access' stamp: 'di 12/4/1998 01:33'! instantiateSmallClass: classPointer sizeInBytes: sizeInBytes fill: fillValue "This version of instantiateClass assumes that the total object size is under 256 bytes, the limit for objects with only one or two header words. Note that the size is specified in bytes and should include four bytes for the base header word." | hash header1 header2 hdrSize | hash _ self newObjectHash. header1 _ ((hash << HashBitsOffset) bitAnd: HashBits) bitOr: (self formatOfClass: classPointer). header1 _ header1 + (sizeInBytes - (header1 bitAnd: SizeMask)). header2 _ classPointer. (header1 bitAnd: CompactClassMask) = 0 "is compact class field from format word zero?" ifTrue: [ hdrSize _ 2 ] ifFalse: [ hdrSize _ 1 ]. ^ self allocate: sizeInBytes headerSize: hdrSize h1: header1 h2: header2 h3: 0 doFill: true with: fillValue! ! !ObjectMemory methodsFor: 'interpreter access'! integerObjectOf: value value < 0 ifTrue: [^ ((16r80000000 + value) << 1) + 1] ifFalse: [^ (value << 1) + 1]! ! !ObjectMemory methodsFor: 'interpreter access'! integerValueOf: objectPointer "Translator produces 'objectPointer >> 1'" ((objectPointer bitAnd: 16r80000000) ~= 0) ifTrue: ["negative" ^ ((objectPointer bitAnd: 16r7FFFFFFF) >> 1) - 16r3FFFFFFF - 1 "Faster than -16r40000000 (a LgInt)"] ifFalse: ["positive" ^ objectPointer >> 1]! ! !ObjectMemory methodsFor: 'interpreter access'! isIntegerObject: objectPointer ^ (objectPointer bitAnd: 1) > 0! ! !ObjectMemory methodsFor: 'interpreter access'! isIntegerValue: intValue "Return true if the given value can be represented as a Smalltalk integer value." "Details: This trick is from Tim Rowledge. Use a shift and XOR to set the sign bit if and only if the top two bits of the given value are the same, then test the sign bit. Note that the top two bits are equal for exactly those integers in the range that can be represented in 31-bits." ^ (intValue bitXor: (intValue << 1)) >= 0! ! !ObjectMemory methodsFor: 'interpreter access'! nilObject "For access from BitBlt module" ^ nilObj! ! !ObjectMemory methodsFor: 'interpreter access'! popRemappableOop "Pop and return the possibly remapped object from the remap buffer." | oop | oop _ remapBuffer at: remapBufferCount. remapBufferCount _ remapBufferCount - 1. ^ oop! ! !ObjectMemory methodsFor: 'interpreter access'! pushRemappableOop: oop "Record the given object in a the remap buffer. Objects in this buffer are remapped when a compaction occurs. This facility is used by the interpreter to ensure that objects in temporary variables are properly remapped." remapBuffer at: (remapBufferCount _ remapBufferCount + 1) put: oop.! ! !ObjectMemory methodsFor: 'interpreter access'! splObj: index "Return one of the objects in the SpecialObjectsArray" ^ self fetchPointer: index ofObject: specialObjectsOop! ! !ObjectMemory methodsFor: 'interpreter access'! storeByte: byteIndex ofObject: oop withValue: valueByte ^ self byteAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + byteIndex put: valueByte! ! !ObjectMemory methodsFor: 'interpreter access'! storePointer: fieldIndex ofObject: oop withValue: valuePointer "Note must check here for stores of young objects into old ones." (oop < youngStart) ifTrue: [ self possibleRootStoreInto: oop value: valuePointer. ]. ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2) put: valuePointer! ! !ObjectMemory methodsFor: 'interpreter access'! storePointerUnchecked: fieldIndex ofObject: oop withValue: valuePointer "Like storePointer:ofObject:withValue:, but the caller guarantees that the object being stored into is a young object or is already marked as a root." ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2) put: valuePointer ! ! !ObjectMemory methodsFor: 'interpreter access'! storeWord: fieldIndex ofObject: oop withValue: valueWord ^ self longAt: (self cCoerce: oop to: 'char *') + BaseHeaderSize + (fieldIndex << 2) put: valueWord! ! !ObjectMemory methodsFor: 'memory access'! checkAddress: byteAddress "Keep this method around for debugging the C code." byteAddress < (self startOfMemory) ifTrue: [ self error: 'bad address: negative'. ]. byteAddress >= memoryLimit ifTrue: [ self error: 'bad address: past end of heap'. ].! ! !ObjectMemory methodsFor: 'memory access'! checkedByteAt: byteAddress "Assumes zero-based array indexing." self checkAddress: byteAddress. ^ self byteAt: byteAddress! ! !ObjectMemory methodsFor: 'memory access'! checkedByteAt: byteAddress put: byte "Assumes zero-based array indexing." self checkAddress: byteAddress. self byteAt: byteAddress put: byte.! ! !ObjectMemory methodsFor: 'memory access'! checkedLongAt: byteAddress "Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass." self checkAddress: byteAddress. self checkAddress: byteAddress + 3. ^ self longAt: byteAddress! ! !ObjectMemory methodsFor: 'memory access'! checkedLongAt: byteAddress put: a32BitInteger "Assumes zero-based array indexing. For testing in Smalltalk, this method should be overridden in a subclass." self checkAddress: byteAddress. self checkAddress: byteAddress + 3. self longAt: byteAddress put: a32BitInteger.! ! !ObjectMemory methodsFor: 'header access'! baseHeader: oop ^ self longAt: oop! ! !ObjectMemory methodsFor: 'header access'! classHeader: oop ^ self longAt: oop - 4! ! !ObjectMemory methodsFor: 'header access' stamp: 'ar 3/21/98 00:30'! formatOf: oop " 0 no fields 1 fixed fields only (possibly containing pointers) 2 indexable fields only (possibly containing pointers) 3 both fixed and indexable fields (possibly containing pointers) 4 both fixed and indexable weak fields (possibly containing pointers). 5 unused 6 indexable word fields only (no pointers) 7 unused 8-11 indexable byte fields only (no pointers) (low 2 bits are low 2 bits of size) 12-15 compiled methods: # of literal oops specified in method header, followed by indexable bytes (same interpretation of low 2 bits as above) " ^ ((self baseHeader: oop) >> 8) bitAnd: 16rF! ! !ObjectMemory methodsFor: 'header access'! hashBitsOf: oop ^ ((self baseHeader: oop) >> 17) bitAnd: 16rFFF! ! !ObjectMemory methodsFor: 'header access'! headerType: oop ^ (self longAt: oop) bitAnd: TypeMask! ! !ObjectMemory methodsFor: 'header access'! isBytes: oop "Answer true if the argument contains indexable bytes. See comment in formatOf:" "Note: Includes CompiledMethods." ^ (self formatOf: oop) >= 8! ! !ObjectMemory methodsFor: 'header access'! isFreeObject: oop ^ (self headerType: oop) = HeaderTypeFree! ! !ObjectMemory methodsFor: 'header access'! isPointers: oop "Answer true if the argument has only fields that can hold oops. See comment in formatOf:" ^ (self formatOf: oop) <= 4! ! !ObjectMemory methodsFor: 'header access' stamp: 'ar 3/21/98 02:38'! isWeak: oop "Answer true if the argument has only weak fields that can hold oops. See comment in formatOf:" ^ (self formatOf: oop) = 4! ! !ObjectMemory methodsFor: 'header access'! isWords: oop "Answer true if the argument contains only indexable words (no oops). See comment in formatOf:" ^ (self formatOf: oop) = 6! ! !ObjectMemory methodsFor: 'header access'! isWordsOrBytes: oop "Answer true if the contains only indexable words or bytes (no oops). See comment in formatOf:" "Note: Excludes CompiledMethods." | fmt | fmt _ self formatOf: oop. ^ fmt = 6 or: [(fmt >= 8) and: [fmt <= 11]]! ! !ObjectMemory methodsFor: 'header access'! newObjectHash "Answer a new 16-bit pseudo-random number for use as an identity hash." lastHash _ 13849 + (27181 * lastHash) bitAnd: 65535. ^ lastHash ! ! !ObjectMemory methodsFor: 'header access' stamp: 'go 11/18/1998 11:04'! rightType: headerWord "Computer the correct header type for an object based on the size and compact class fields of the given base header word, rather than its type bits. This is used during marking, when the header type bits are used to record the state of tracing." (headerWord bitAnd: SizeMask) = 0 "zero size field in header word" ifTrue: [ ^ HeaderTypeSizeAndClass ] ifFalse: [ (headerWord bitAnd: CompactClassMask) = 0 ifTrue: [ ^ HeaderTypeClass ] ifFalse: [ ^ HeaderTypeShort ]].! ! !ObjectMemory methodsFor: 'header access' stamp: 'go 11/13/1998 17:04'! setSizeOfFree: chunk to: byteSize "Set the header of the given chunk to make it be a free chunk of the given size." self longAt: chunk put: ((byteSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree).! ! !ObjectMemory methodsFor: 'header access' stamp: 'go 11/17/1998 15:57'! sizeBitsOf: oop "Answer the number of bytes in the given object, including its base header, rounded up to an integral number of words." "Note: byte indexable objects need to have low bits subtracted from this size." | header | header _ self baseHeader: oop. (header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ ^ header bitAnd: SizeMask ].! ! !ObjectMemory methodsFor: 'header access' stamp: 'go 11/17/1998 15:57'! sizeBitsOfSafe: oop "Compute the size of the given object from the cc and size fields in its header. This works even if its type bits are not correct." | header type | header _ self baseHeader: oop. type _ self rightType: header. type = HeaderTypeSizeAndClass ifTrue: [ ^ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ ^ header bitAnd: SizeMask ].! ! !ObjectMemory methodsFor: 'header access'! sizeHeader: oop ^ self longAt: oop - 8! ! !ObjectMemory methodsFor: 'header access' stamp: 'go 11/13/1998 17:04'! sizeOfFree: oop "Return the size of the given chunk in bytes. Argument MUST be a free chunk." ^ (self longAt: oop) bitAnd: AllButTypeMask! ! !ObjectMemory methodsFor: 'object enumeration'! accessibleObjectAfter: oop "Return the accessible object following the given object or free chunk in the heap. Return nil when heap is exhausted." | obj | self inline: false. obj _ self objectAfter: oop. [obj < endOfMemory] whileTrue: [ (self isFreeObject: obj) ifFalse: [ ^obj ]. obj _ self objectAfter: obj. ]. ^ nil! ! !ObjectMemory methodsFor: 'object enumeration'! firstAccessibleObject "Return the first accessible object in the heap." | obj | obj _ self firstObject. [obj < endOfMemory] whileTrue: [ (self isFreeObject: obj) ifFalse: [ ^obj ]. obj _ self objectAfter: obj. ]. self error: 'heap is empty'! ! !ObjectMemory methodsFor: 'object enumeration'! firstObject "Return the first object or free chunk in the heap." ^ self oopFromChunk: self startOfMemory! ! !ObjectMemory methodsFor: 'object enumeration'! initialInstanceOf: classPointer "Support for instance enumeration. Return the first instance of the given class, or nilObj if it has no instances." | thisObj thisClass | thisObj _ self firstAccessibleObject. [thisObj = nil] whileFalse: [ thisClass _ self fetchClassOf: thisObj. thisClass = classPointer ifTrue: [ ^thisObj ]. thisObj _ self accessibleObjectAfter: thisObj. ]. ^nilObj! ! !ObjectMemory methodsFor: 'object enumeration'! instanceAfter: objectPointer "Support for instance enumeration. Return the next instance of the class of the given object, or nilObj if the enumeration is complete." | classPointer thisObj thisClass | classPointer _ (self fetchClassOf: objectPointer). thisObj _ self accessibleObjectAfter: objectPointer. [thisObj = nil] whileFalse: [ thisClass _ self fetchClassOf: thisObj. thisClass = classPointer ifTrue: [ ^thisObj ]. thisObj _ self accessibleObjectAfter: thisObj. ]. ^nilObj! ! !ObjectMemory methodsFor: 'object enumeration' stamp: 'di 12/27/1998 23:17'! lastPointerOf: oop "Return the byte offset of the last pointer field of the given object. Works with CompiledMethods, as well as ordinary objects. Can be used even when the type bits are not correct." | fmt sz methodHeader header | self inline: true. header _ self baseHeader: oop. fmt _ (header >> 8) bitAnd: 16rF. fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header]) ifTrue: ["contexts end at the stack pointer" ^ (CtxtTempFrameStart + (self fetchStackPointerOf: oop)) * 4]. sz _ self sizeBitsOfSafe: oop. ^ sz - BaseHeaderSize "all pointers"]. fmt < 12 ifTrue: [ ^0 ]. "no pointers" "CompiledMethod: contains both pointers and bytes:" methodHeader _ self longAt: oop + BaseHeaderSize. ^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! ! !ObjectMemory methodsFor: 'object enumeration' stamp: 'jm 11/25/1998 16:34'! objectAfter: oop "Return the object or free chunk immediately following the given object or free chunk in memory. Return endOfMemory when enumeration is complete." | sz | self inline: true. DoAssertionChecks ifTrue: [ oop >= endOfMemory ifTrue: [ self error: 'no objects after the end of memory' ]. ]. (self isFreeObject: oop) ifTrue: [ sz _ self sizeOfFree: oop ] ifFalse: [ sz _ self sizeBitsOf: oop ]. ^ self oopFromChunk: (oop + sz)! ! !ObjectMemory methodsFor: 'object enumeration'! startOfMemory "Return the start of object memory." ^ self cCode: '(int) memory'! ! !ObjectMemory methodsFor: 'oop/chunk conversion'! chunkFromOop: oop "Compute the chunk of this oop by subtracting its extra header bytes." | extra | extra _ self extraHeaderBytes: oop. ^ oop - extra! ! !ObjectMemory methodsFor: 'oop/chunk conversion'! extraHeaderBytes: oopOrChunk "Return the number of extra bytes used by the given object's header." "Warning: This method should not be used during marking, when the header type bits of an object may be incorrect." | type extra | self inline: true. type _ self headerType: oopOrChunk. type > 1 ifTrue: [ extra _ 0. "free chunk (type 2) or 1-word header (type 3); most common" ] ifFalse: [ type = 1 ifTrue: [ extra _ 4. "2-word header (type 1)" ] ifFalse: [ extra _ 8. "3-word header (type 0)" ]. ]. ^ extra! ! !ObjectMemory methodsFor: 'oop/chunk conversion'! oopFromChunk: chunk "Compute the oop of this chunk by adding its extra header bytes." | extra | extra _ self extraHeaderBytes: chunk. ^ chunk + extra! ! !ObjectMemory methodsFor: 'allocation' stamp: 'jm 12/6/1998 17:12'! allocate: byteSize headerSize: hdrSize h1: baseHeader h2: classOop h3: extendedSize doFill: doFill with: fillWord "Allocate a new object of the given size and number of header words. (Note: byteSize already includes space for the base header word.) Initialize the header fields of the new object and fill the remainder of the object with the given value." | newObj remappedClassOop end i | self inline: true. "remap classOop in case GC happens during allocation" hdrSize > 1 ifTrue: [ self pushRemappableOop: classOop ]. newObj _ self allocateChunk: byteSize + ((hdrSize - 1) * 4). hdrSize > 1 ifTrue: [ remappedClassOop _ self popRemappableOop ]. hdrSize = 3 ifTrue: [ self longAt: newObj put: (extendedSize bitOr: HeaderTypeSizeAndClass). self longAt: newObj + 4 put: (remappedClassOop bitOr: HeaderTypeSizeAndClass). self longAt: newObj + 8 put: (baseHeader bitOr: HeaderTypeSizeAndClass). newObj _ newObj + 8. ]. hdrSize = 2 ifTrue: [ self longAt: newObj put: (remappedClassOop bitOr: HeaderTypeClass). self longAt: newObj + 4 put: (baseHeader bitOr: HeaderTypeClass). newObj _ newObj + 4. ]. hdrSize = 1 ifTrue: [ self longAt: newObj put: (baseHeader bitOr: HeaderTypeShort). ]. "clear new object" doFill ifTrue: [end _ newObj + byteSize. i _ newObj + 4. [i < end] whileTrue: [self longAt: i put: fillWord. i _ i + 4]]. DoAssertionChecks ifTrue: [ self okayOop: newObj. self oopHasOkayClass: newObj. (self objectAfter: newObj) = freeBlock ifFalse: [ self error: 'allocate bug: did not set header of new oop correctly' ]. (self objectAfter: freeBlock) = endOfMemory ifFalse: [ self error: 'allocate bug: did not set header of freeBlock correctly' ]. ]. ^ newObj! ! !ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 19:36'! allocateChunk: byteSize "Allocate a chunk of the given size. Sender must be sure that the requested size includes enough space for the header word(s)." "Details: To limit the time per incremental GC, do one every so many allocations." | enoughSpace newFreeSize newChunk | self inline: true. allocationCount >= allocationsBetweenGCs ifTrue: [ "do an incremental GC every so many allocations to keep pauses short" self incrementalGC. ]. enoughSpace _ self sufficientSpaceToAllocate: byteSize. enoughSpace ifFalse: [ "signal that space is running low, put proceed with allocation if possible" signalLowSpace _ true. lowSpaceThreshold _ 0. "disable additional interrupts until lowSpaceThreshold is reset by image" interruptCheckCounter _ 0. ]. (self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ') < (self cCoerce: (byteSize + BaseHeaderSize) to: 'unsigned ') ifTrue: [ self error: 'out of memory'. ]. "if we get here, there is enough space for allocation to succeed" newFreeSize _ (self sizeOfFree: freeBlock) - byteSize. newChunk _ freeBlock. freeBlock _ freeBlock + byteSize. "Assume: client will initialize object header of free chunk, so following is not needed:" "self setSizeOfFree: newChunk to: byteSize." self setSizeOfFree: freeBlock to: newFreeSize. allocationCount _ allocationCount + 1. ^ newChunk! ! !ObjectMemory methodsFor: 'allocation' stamp: 'di 12/18/1998 08:45'! allocateOrRecycleContext "Return a recycled context or a newly allocated one if none is available for recycling." | cntxt | freeContexts ~= NilContext ifTrue: [cntxt _ freeContexts. freeContexts _ self fetchPointer: 0 ofObject: cntxt. ^ cntxt]. cntxt _ self instantiateContext: (self splObj: ClassMethodContext) sizeInBytes: LargeContextSize. "Required init -- above does not fill w/nil. All others get written." self storePointerUnchecked: 4 "InitialIPIndex" ofObject: cntxt withValue: nilObj. ^ cntxt ! ! !ObjectMemory methodsFor: 'allocation'! clone: oop "Return a shallow copy of the given object." "Assume: Oop is a real object, not a small integer." | extraHdrBytes bytes newChunk remappedOop fromIndex toIndex lastFrom newOop header hash | self inline: false. extraHdrBytes _ self extraHeaderBytes: oop. bytes _ self sizeBitsOf: oop. bytes _ bytes + extraHdrBytes. "allocate space for the copy, remapping oop in case of a GC" self pushRemappableOop: oop. newChunk _ self allocateChunk: bytes. remappedOop _ self popRemappableOop. "copy old to new including all header words" toIndex _ newChunk - 4. "loop below uses pre-increment" fromIndex _ (remappedOop - extraHdrBytes) - 4. lastFrom _ fromIndex + bytes. [fromIndex < lastFrom] whileTrue: [ self longAt: (toIndex _ toIndex + 4) put: (self longAt: (fromIndex _ fromIndex + 4)). ]. newOop _ newChunk + extraHdrBytes. "convert from chunk to oop" "fix base header: compute new hash and clear Mark and Root bits" hash _ self newObjectHash. header _ (self longAt: newOop) bitAnd: 16r1FFFF. "use old ccIndex, format, size, and header-type fields" header _ header bitOr: ((hash << 17) bitAnd: 16r1FFE0000). self longAt: newOop put: header. ^ newOop ! ! !ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 23:34'! recycleContextIfPossible: cntxOop "If possible, save the given context on a list of free contexts to be recycled." "Note: The context is not marked free, so it can be reused with minimal fuss. The recycled context lists are cleared at every garbage collect." self inline: true. "only recycle young contexts (which should be most of them)" (cntxOop >= youngStart and: [self isMethodContextHeader: (self baseHeader: cntxOop)]) ifTrue: [self storePointerUnchecked: 0 ofObject: cntxOop withValue: freeContexts. freeContexts _ cntxOop]. ! ! !ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 16:35'! sufficientSpaceAfterGC: minFree "Return true if there is enough free space after doing a garbage collection. If not, signal that space is low." self inline: false. self incrementalGC. "try to recover some space" (self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ') < (self cCoerce: minFree to: 'unsigned ') ifTrue: [signalLowSpace ifTrue: [ ^ false ]. "give up; problem is already noted" self fullGC. "try harder" "for stability, require more free space after doing an expensive full GC" (self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ') < ((self cCoerce: minFree to: 'unsigned ') + 15000) ifTrue: [ ^ false ]. "still not enough" ]. ^ true! ! !ObjectMemory methodsFor: 'allocation' stamp: 'di 12/27/1998 19:30'! sufficientSpaceToAllocate: bytes "Return true if there is enough space to allocate the given number of bytes, perhaps after doing a garbage collection." | minFree | self inline: true. minFree _ lowSpaceThreshold + bytes + BaseHeaderSize. "check for low-space" (self cCoerce: (self sizeOfFree: freeBlock) to: 'unsigned ') >= (self cCoerce: minFree to: 'unsigned ') ifTrue: [^ true] ifFalse: [^ self sufficientSpaceAfterGC: minFree].! ! !ObjectMemory methodsFor: 'garbage collection'! beRootIfOld: oop "Record that the given oop in the old object area may point to an object in the young area." | header | self inline: false. ((oop < youngStart) and: [(self isIntegerObject: oop) not]) ifTrue: [ "oop is in the old object area" header _ self longAt: oop. (header bitAnd: RootBit) = 0 ifTrue: [ "record oop as root only if not already recorded" rootTableCount < RootTableSize ifTrue: [ "record root only if there is room in the roots table" rootTableCount _ rootTableCount + 1. rootTable at: rootTableCount put: oop. self longAt: oop put: (header bitOr: RootBit). ]. ]. ].! ! !ObjectMemory methodsFor: 'garbage collection'! clearRootsTable "Clear the root bits of the current roots, then empty the roots table." "Caution: This should only be done when the young object space is empty." | oop | "reset the roots table (after this, all objects are old so there are no roots)" 1 to: rootTableCount do: [ :i | "clear root bits of current root table entries" oop _ rootTable at: i. self longAt: oop put: ((self longAt: oop) bitAnd: AllButRootBit). rootTable at: i put: 0. ]. rootTableCount _ 0.! ! !ObjectMemory methodsFor: 'garbage collection'! fullCompaction "Move all accessible objects down to leave one big free chunk at the end of memory." "Assume: Incremental GC has just been done to maximimize forwarding table space." "need not move objects below the first free chunk" compStart _ self lowestFreeAfter: (self startOfMemory). compStart = freeBlock ifTrue: [ "memory is already compact; only free chunk is at the end" ^ self initializeMemoryFirstFree: freeBlock ]. "work up through memory until all free space is at the end" [compStart < freeBlock] whileTrue: [ "free chunk returned by incCompBody becomes start of next compaction" compStart _ self incCompBody. "bubble of free space moves up each time" ].! ! !ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 12/30/2003 20:14'! fullGC "Do a mark/sweep garbage collection of the entire object memory. Free inaccessible objects but do not move them." | startTime | self inline: false. self preGCAction. startTime _ self ioMicroMSecs. self clearRootsTable. youngStart _ self startOfMemory. "process all of memory" self markPhase. self sweepPhase. self fullCompaction. allocationCount _ 0. statFullGCs _ statFullGCs + 1. statFullGCMSecs _ statFullGCMSecs + (self ioMicroMSecs - startTime). youngStart _ freeBlock. "reset the young object boundary" self postGCAction.! ! !ObjectMemory methodsFor: 'garbage collection'! incrementalCompaction "Move objects down to make one big free chunk. Compact the last N objects (where N = number of forwarding table entries) of the young object area." "Assume: compStart was set during the sweep phase" compStart = freeBlock ifTrue: [ "Note: If compStart = freeBlock then either the young space is already compact or there are enough forwarding table entries to do a one-pass incr. compaction." self initializeMemoryFirstFree: freeBlock. ] ifFalse: [ self incCompBody. ]. ! ! !ObjectMemory methodsFor: 'garbage collection' stamp: 'jm 12/30/2003 20:14'! incrementalGC "Do a mark/sweep garbage collection of just the young object area of object memory (i.e., objects above youngStart), using the root table to identify objects containing pointers to young objects from the old object area." | survivorCount startTime | self inline: false. rootTableCount >= RootTableSize ifTrue: [ "root table overflow; cannot do an incremental GC (this should be very rare)" statRootTableOverflows _ statRootTableOverflows + 1. ^ self fullGC ]. self preGCAction. "incremental GC and compaction" startTime _ self ioMicroMSecs. self markPhase. survivorCount _ self sweepPhase. self incrementalCompaction. allocationCount _ 0. statIncrGCs _ statIncrGCs + 1. statIncrGCMSecs _ statIncrGCMSecs + (self ioMicroMSecs - startTime). survivorCount > tenuringThreshold ifTrue: [ "move up the young space boundary if there are too many survivors; this limits the number of objects that must be processed on future incremental GC's" statTenures _ statTenures + 1. self clearRootsTable. youngStart _ freeBlock. "reset the young object boundary" ]. self postGCAction. ! ! !ObjectMemory methodsFor: 'garbage collection' stamp: 'go 11/17/1998 15:56'! lowestFreeAfter: chunk "Return the first free block after the given chunk in memory." | oop oopHeader oopHeaderType oopSize | self inline: false. oop _ self oopFromChunk: chunk. [oop < endOfMemory] whileTrue: [ oopHeader _ self baseHeader: oop. oopHeaderType _ oopHeader bitAnd: TypeMask. (oopHeaderType = HeaderTypeFree) ifTrue: [ ^ oop ] ifFalse: [ oopHeaderType = HeaderTypeSizeAndClass ifTrue: [ oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ oopSize _ oopHeader bitAnd: SizeMask ]. ]. oop _ self oopFromChunk: (oop + oopSize). ]. self error: 'expected to find at least one free object'. ! ! !ObjectMemory methodsFor: 'garbage collection'! possibleRootStoreInto: oop value: valueObj "Called when storing the given value object into the given old object. If valueObj is young, record the fact that oldObj is now a root for incremental garbage collection." "Warning: No young objects should be recorded as roots." | header | self inline: false. ((valueObj >= youngStart) and: [(self isIntegerObject: valueObj) not]) ifTrue: [ header _ self longAt: oop. (header bitAnd: RootBit) = 0 ifTrue: [ "record oop as root only if not already recorded" rootTableCount < RootTableSize ifTrue: [ "record root only if there is room in the roots table" rootTableCount _ rootTableCount + 1. rootTable at: rootTableCount put: oop. self longAt: oop put: (header bitOr: RootBit). ]. ]. ].! ! !ObjectMemory methodsFor: 'gc -- mark and sweep'! aComment "The mark phase is based on a pointer reversing traversal. This is a little tricky because the class, which is needed by the traversal, may be in either the header (as a compact class index) or in the word above the header. See memo 'Revised object format'. Compact classes are marked and traced separately. How do you know that you are returning from having marked a class? Parent pointer has 10 in low bits. Here are the states an object may be in, followed by what to do next in brackets []: Start Object: parentField is set, [obj _ child]: obj is pointed at by a field in parent that is being traced now. obj is marked. [(parent goes up to the next field) field addr _ obj. go to Upward] obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has no pointers. [put 10 into low bits of header. field addr _ obj. go to Start Field (to process class word)] obj is pointed at by a field in parent that is being traced now. obj is unmarked. obj has pointers. [put 10 into low bits of header. point to last field. go to Start Field] Start Field: Field ends in 10. It is the header. Short Class is not 0. [Set low bits to correct value. (have parent pointer) go to Upward] Field ends in 10. It is the header. Short Class is 0. [child _ word above header. low bits of child _ 01. class word _ parentField. parentField _ loc of class word. go to Start Obj] Field is Integer. [point one word up, go to Start Field] Field is oop. [child _ field. field _ parentField. parentField _ loc of field. go to Start Obj] Upward [restore low bits of header (at field addr)]: parentField is 3. (bits 11, int 1). [done!!] parentField ends in 00. [child _ field addr. field addr _ parentField. parentField _ field addr contents. field addr contents _ child (addr of prev object. its oop). field addr - 4. go to Start Field] parentField ends in 01. Were tracing the class. [child _ field addr. field addr _ parentField (loc of class word). parentField _ field addr contents. field addr contents _ child (addr of prev object. its oop). field addr + 4 (header). go to Upward] "! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'ikp 1/3/98 23:10'! markAndTrace: oop "Mark all objects reachable from the given one. Trace from the given object even if it is old or already marked. Mark it only if it is a young object." "Tracer state variables: child object being examined field next field of child to examine parentField field where child was stored in its referencing object" | header lastFieldOffset action | "record tracing status in object's header" header _ self longAt: oop. header _ (header bitAnd: AllButTypeMask) bitOr: HeaderTypeGC. oop >= youngStart ifTrue: [ header _ header bitOr: MarkBit ]. "mark only if young" self longAt: oop put: header. "initialize the tracer state machine" parentField _ GCTopMarker. child _ oop. lastFieldOffset _ self lastPointerOf: oop. field _ oop + lastFieldOffset. action _ StartField. "run the tracer state machine until all objects reachable from oop are marked" [action = Done] whileFalse: [ action = StartField ifTrue: [ action _ self startField ]. action = StartObj ifTrue: [ action _ self startObj ]. action = Upward ifTrue: [ action _ self upward ]. ].! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'jm 12/6/1998 17:26'! markPhase "Mark phase of the mark and sweep garbage collector. Set the mark bits of all reachable objects. Free chunks are untouched by this process." "Assume: All non-free objects are initially unmarked. Root objects were unmarked when they were made roots. (Make sure this stays true!!!!)." | oop | self inline: false. "clear the recycled context lists" freeContexts _ NilContext. "trace the interpreter's objects, including the active stack and special objects array" self markAndTraceInterpreterOops. "trace the roots" 1 to: rootTableCount do: [ :i | oop _ rootTable at: i. (self isIntegerObject: oop) ifFalse: [ self markAndTrace: oop ]. ]. ! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'go 11/18/1998 11:04'! startField "Examine and possibly trace the next field of the object being traced. See comment in markAndTrace for explanation of tracer state variables." | typeBits childType | child _ self longAt: field. typeBits _ child bitAnd: TypeMask. (typeBits bitAnd: 1) = 1 ifTrue: [ "field contains a SmallInteger; skip it" field _ field - 4. ^ StartField ]. typeBits = 0 ifTrue: [ "normal oop, go down" self longAt: field put: parentField. parentField _ field. ^ StartObj ]. typeBits = 2 ifTrue: [ "reached the header; do we need to process the class word?" (child bitAnd: CompactClassMask) ~= 0 ifTrue: [ "object's class is compact; we're done" "restore the header type bits" child _ child bitAnd: AllButTypeMask. childType _ self rightType: child. self longAt: field put: (child bitOr: childType). ^ Upward ] ifFalse: [ "object has a full class word; process that class" child _ self longAt: (field - 4). "class word" child _ child bitAnd: AllButTypeMask. "clear type bits" self longAt: (field - 4) put: parentField. parentField _ (field - 4) bitOr: 1. "point at class word; mark as working on the class." ^ StartObj ]. ].! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'ar 3/23/98 22:46'! startObj "Start tracing the object 'child' and answer the next action. The object may be anywhere in the middle of being swept itself. See comment in markAndTrace for explanation of tracer state variables." | oop header lastFieldOffset | oop _ child. oop < youngStart ifTrue: [ "old object; skip it" field _ oop. ^ Upward ]. header _ self longAt: oop. (header bitAnd: MarkBit) = 0 ifTrue: [ "unmarked; mark and trace" "<-- Finalization support: Do not trace the object's indexed fields if it's a weak class -->" (self isWeak: oop) ifTrue:[ "Set lastFieldOffset before the weak fields in the receiver" lastFieldOffset := (self nonWeakFieldsOf: oop) << 2. ] ifFalse:[ "Do it the usual way" lastFieldOffset _ self lastPointerOf: oop. ]. header _ header bitAnd: AllButTypeMask. header _ (header bitOr: MarkBit) bitOr: HeaderTypeGC. self longAt: oop put: header. field _ oop + lastFieldOffset. ^ StartField "trace its fields and class" ] ifFalse: [ "already marked; skip it" field _ oop. ^ Upward ].! ! !ObjectMemory methodsFor: 'gc -- mark and sweep' stamp: 'di 1/12/1999 12:25'! sweepPhase "Sweep memory from youngStart through the end of memory. Free all inaccessible objects and coalesce adjacent free chunks. Clear the mark bits of accessible objects. Compute the starting point for the first pass of incremental compaction (compStart). Return the number of surviving objects." "Details: Each time a non-free object is encountered, decrement the number of available forward table entries. If all entries are spoken for (i.e., entriesAvailable reaches zero), set compStart to the last free chunk before that object or, if there is no free chunk before the given object, the first free chunk after it. Thus, at the end of the sweep phase, compStart through compEnd spans the highest collection of non-free objects that can be accomodated by the forwarding table. This information is used by the first pass of incremental compaction to ensure that space is initially freed at the end of memory. Note that there should always be at least one free chunk--the one at the end of the heap." | entriesAvailable survivors freeChunk firstFree oop oopHeader oopHeaderType hdrBytes oopSize freeChunkSize | self inline: false. entriesAvailable _ self fwdTableInit: 8. "Two-word blocks" . survivors _ 0. freeChunk _ nil. firstFree _ nil. "will be updated later" oop _ self oopFromChunk: youngStart. [oop < endOfMemory] whileTrue: [ "get oop's header, header type, size, and header size" oopHeader _ self baseHeader: oop. oopHeaderType _ oopHeader bitAnd: TypeMask. (oopHeaderType = HeaderTypeShort) ifTrue: [ oopSize _ oopHeader bitAnd: SizeMask. hdrBytes _ 0. ] ifFalse: [ (oopHeaderType = HeaderTypeClass) ifTrue: [ oopSize _ oopHeader bitAnd: SizeMask. hdrBytes _ 4. ] ifFalse: [ (oopHeaderType = HeaderTypeSizeAndClass) ifTrue: [ oopSize _ (self sizeHeader: oop) bitAnd: AllButTypeMask. hdrBytes _ 8. ] ifFalse: [ "free chunk" oopSize _ oopHeader bitAnd: AllButTypeMask. hdrBytes _ 0. ]. ]. ]. (oopHeader bitAnd: MarkBit) = 0 ifTrue: ["object is not marked; free it" "<-- Finalization support: We need to mark each oop chunk as free -->" self longAt: oop - hdrBytes put: HeaderTypeFree. freeChunk ~= nil ifTrue: [ "enlarge current free chunk to include this oop" freeChunkSize _ freeChunkSize + oopSize + hdrBytes. ] ifFalse: [ "start a new free chunk" freeChunk _ oop - hdrBytes. "chunk may start 4 or 8 bytes before oop" freeChunkSize _ oopSize + (oop - freeChunk). "adjust size for possible extra header bytes" firstFree = nil ifTrue: [ firstFree _ freeChunk ]. ]. ] ifFalse: [ "object is marked; clear its mark bit and possibly adjust the compaction start" self longAt: oop put: (oopHeader bitAnd: AllButMarkBit). "<-- Finalization support: Check if we're running about a weak class -->" (self isWeak: oop) ifTrue:[ self finalizeReference: oop. ]. entriesAvailable > 0 ifTrue: [ entriesAvailable _ entriesAvailable - 1. ] ifFalse: [ "start compaction at the last free chunk before this object" firstFree _ freeChunk. ]. freeChunk ~= nil ifTrue: [ "record the size of the last free chunk" self longAt: freeChunk put: ((freeChunkSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree). ]. freeChunk _ nil. survivors _ survivors + 1. ]. oop _ self oopFromChunk: (oop + oopSize). "get next oop" ]. freeChunk ~= nil ifTrue: [ "record size of final free chunk" self longAt: freeChunk put: ((freeChunkSize bitAnd: AllButTypeMask) bitOr: HeaderTypeFree). ]. oop = endOfMemory ifFalse: [ self error: 'sweep failed to find exact end of memory' ]. firstFree = nil ifTrue: [ self error: 'expected to find at least one free object' ] ifFalse: [ compStart _ firstFree ]. displayBits = 0 ifFalse: [ "TPR: clear mark bit of Acorn's displayBits object, which may lie outside object space" oopHeader _ self baseHeader: displayBits. self longAt: displayBits put: (oopHeader bitAnd: AllButMarkBit)]. ^ survivors ! ! !ObjectMemory methodsFor: 'gc -- mark and sweep'! upward "Return from marking an object below. Incoming: field = oop we just worked on, needs to be put away parentField = where to put it in our object NOTE: Type field of object below has already been restored!!!!!!" | type header | (parentField bitAnd: 1) = 1 ifTrue: [ parentField = GCTopMarker ifTrue: [ "top of the chain" header _ (self longAt: field) bitAnd: AllButTypeMask. type _ self rightType: header. self longAt: field put: header + type. "install type on class oop" ^ Done ] ifFalse: [ "was working on the extended class word" child _ field. "oop of class" field _ parentField - 1. "class word, ** clear the low bit **" parentField _ self longAt: field. header _ self longAt: field+4. "base header word" type _ self rightType: header. self longAt: field put: child + type. "install type on class oop" field _ field + 4. "point at header" "restore type bits" header _ header bitAnd: AllButTypeMask. self longAt: field put: (header + type). ^ Upward ]. ] ifFalse: [ "normal" child _ field. "who we worked on below" field _ parentField. "where to put it" parentField _ self longAt: field. self longAt: field put: child. field _ field - 4. "point at header" ^ StartField ].! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 19:41'! beRootWhileForwarding: oop "Record that the given oop in the old object area points to an object in the young area when oop may be forwarded. Like beRoot:" "Warning: No young objects should be recorded as roots. Callers are responsible for ensuring this constraint is not violated." | header forwarding fwdBlock newHeader | header _ self longAt: oop. (header bitAnd: MarkBit) ~= 0 ifTrue: [ forwarding _ true. fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. header _ self longAt: fwdBlock + 4. ] ifFalse: [ forwarding _ false. ]. (header bitAnd: RootBit) = 0 ifTrue: [ "record oop as root only if not already recorded" rootTableCount < RootTableSize ifTrue: [ "record root only if there is room in the roots table" rootTableCount _ rootTableCount + 1. rootTable at: rootTableCount put: oop. newHeader _ header bitOr: RootBit. forwarding ifTrue: [ self longAt: (fwdBlock + 4) put: newHeader ] ifFalse: [ self longAt: oop put: newHeader ]. ]. ].! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 14:09'! fwdBlockGet: blkSize "Return the address of a two- or four-word forwarding block or nil if no more entries are available." fwdTableNext _ fwdTableNext + blkSize. fwdTableNext <= fwdTableLast ifTrue: [ ^ fwdTableNext ] ifFalse: [ ^ nil ]. "no more forwarding blocks available"! ! !ObjectMemory methodsFor: 'gc -- compaction'! fwdBlockValidate: addr "Raise an error if the given address is not a valid forward table entry." (( addr > endOfMemory) and: [(addr <= fwdTableNext) and: [(addr bitAnd: 3) = 0]]) ifFalse: [ self error: 'invalid fwd table entry' ].! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 1/13/1999 10:55'! fwdTableInit: blkSize "Set the limits for a table of two- or three-word forwarding blocks above the last used oop. The pointer fwdTableNext moves up to fwdTableLast. Used for compaction of memory and become-ing objects. Returns the number of forwarding blocks available." self inline: false. "set endOfMemory to just after a minimum-sized free block" self setSizeOfFree: freeBlock to: BaseHeaderSize. endOfMemory _ freeBlock + BaseHeaderSize. "make a fake free chunk at endOfMemory for use as a sentinal in memory scans" self setSizeOfFree: endOfMemory to: BaseHeaderSize. "use all memory free between freeBlock and memoryLimit for forwarding table" "Note: Forward blocks must be quadword aligned." fwdTableNext _ (endOfMemory + BaseHeaderSize + 7) bitAnd: 16rFFFFFFF8. fwdTableLast _ memoryLimit - blkSize. "last forwarding table entry" "return the number of forwarding blocks available" ^ (fwdTableLast - fwdTableNext) // blkSize "round down"! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 12:25'! incCompBody "Move objects to consolidate free space into one big chunk. Return the newly created free chunk." | bytesFreed | self inline: false. "reserve memory for forwarding table" self fwdTableInit: 8. "Two-word blocks" "assign new oop locations, reverse their headers, and initialize forwarding blocks" bytesFreed _ self incCompMakeFwd. "update pointers to point at new oops" self mapPointersInObjectsFrom: youngStart to: endOfMemory. "move the objects and restore their original headers; return the new free chunk" ^ self incCompMove: bytesFreed! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 12:32'! incCompMakeFwd "Create and initialize forwarding blocks for all non-free objects following compStart. If the supply of forwarding blocks is exhausted, set compEnd to the first chunk above the area to be compacted; otherwise, set it to endOfMemory. Return the number of bytes to be freed." | bytesFreed oop fwdBlock newOop | bytesFreed _ 0. oop _ self oopFromChunk: compStart. [oop < endOfMemory] whileTrue: [ (self isFreeObject: oop) ifTrue: [ bytesFreed _ bytesFreed + (self sizeOfFree: oop). ] ifFalse: [ "create a forwarding block for oop" fwdBlock _ self fwdBlockGet: 8. "Two-word block" fwdBlock = nil ifTrue: [ "stop; we have used all available forwarding blocks" compEnd _ self chunkFromOop: oop. ^ bytesFreed ]. newOop _ oop - bytesFreed. self initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: false. ]. oop _ self objectAfterWhileForwarding: oop. ]. compEnd _ endOfMemory. ^ bytesFreed! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 19:45'! incCompMove: bytesFreed "Move all non-free objects between compStart and compEnd to their new locations, restoring their headers in the process. Create a new free block at the end of memory. Return the newly created free chunk." "Note: The free block used by the allocator always must be the last free block in memory. It may take several compaction passes to make all free space bubble up to the end of memory." | oop next fwdBlock newOop header bytesToMove firstWord lastWord newFreeChunk sz | newOop _ nil. oop _ self oopFromChunk: compStart. [oop < compEnd] whileTrue: [ next _ self objectAfterWhileForwarding: oop. (self isFreeObject: oop) ifFalse: [ "a moving object; unwind its forwarding block" fwdBlock _ ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. newOop _ self longAt: fwdBlock. header _ self longAt: fwdBlock + 4. self longAt: oop put: header. "restore the original header" bytesToMove _ oop - newOop. "move the oop (including any extra header words)" sz _ self sizeBitsOf: oop. firstWord _ oop - (self extraHeaderBytes: oop). lastWord _ (oop + sz) - BaseHeaderSize. firstWord to: lastWord by: 4 do: [ :w | self longAt: (w - bytesToMove) put: (self longAt: w). ]. ]. oop _ next. ]. newOop = nil ifTrue: [ "no objects moved" oop _ self oopFromChunk: compStart. ((self isFreeObject: oop) and: [(self objectAfter: oop) = (self oopFromChunk: compEnd)]) ifTrue: [ newFreeChunk _ oop ] ifFalse: [ newFreeChunk _ freeBlock ]. ] ifFalse: [ "initialize the newly freed memory chunk" "newOop is the last object moved; free chunk starts right after it" newFreeChunk _ newOop + (self sizeBitsOf: newOop). self setSizeOfFree: newFreeChunk to: bytesFreed. ]. DoAssertionChecks ifTrue: [ (self objectAfter: newFreeChunk) = (self oopFromChunk: compEnd) ifFalse: [ self error: 'problem creating free chunk after compaction' ]. ]. (self objectAfter: newFreeChunk) = endOfMemory ifTrue: [ self initializeMemoryFirstFree: newFreeChunk. ] ifFalse: [ "newFreeChunk is not at end of memory; re-install freeBlock" self initializeMemoryFirstFree: freeBlock. ]. ^ newFreeChunk! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 1/12/1999 14:08'! initForwardBlock: fwdBlock mapping: oop to: newOop withBackPtr: backFlag "Initialize the given forwarding block to map oop to newOop, and replace oop's header with a pointer to the fowarding block." "Details: The mark bit is used to indicate that an oop is forwarded. When an oop is forwarded, its header (minus the mark bit) contains the address of its forwarding block. (The forwarding block address is actually shifted right by one bit so that its top-most bit does not conflict with the header's mark bit; since fowarding blocks are stored on word boundaries, the low two bits of the address are always zero.) The first word of the forwarding block is the new oop; the second word is the oop's orginal header. In the case of a forward become, a four-word block is used, with the third field being a backpointer to the old oop (for header fixup), and the fourth word is unused. The type bits of the forwarding header are the same as those of the original header." | originalHeader originalHeaderType | self inline: true. originalHeader _ self longAt: oop. DoAssertionChecks ifTrue: [ fwdBlock = nil ifTrue: [ self error: 'ran out of forwarding blocks in become' ]. (originalHeader bitAnd: MarkBit) ~= 0 ifTrue: [ self error: 'object already has a forwarding table entry' ]. ]. originalHeaderType _ originalHeader bitAnd: TypeMask. self longAt: fwdBlock put: newOop. self longAt: fwdBlock + 4 put: originalHeader. backFlag ifTrue: [self longAt: fwdBlock + 8 put: oop]. self longAt: oop put: (fwdBlock >> 1 bitOr: (MarkBit bitOr: originalHeaderType)). ! ! !ObjectMemory methodsFor: 'gc -- compaction'! isObjectForwarded: oop "Return true if the given object has a forwarding table entry during a compaction or become operation." ^ (oop bitAnd: 1) = 0 "(isIntegerObject: oop) not" and: [ ((self longAt: oop) bitAnd: MarkBit) ~= 0 ]! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'di 12/27/1998 23:18'! lastPointerWhileForwarding: oop "The given object may have its header word in a forwarding block. Find the offset of the last pointer in the object in spite of this obstacle." | header fwdBlock fmt size methodHeader | self inline: true. header _ self longAt: oop. (header bitAnd: MarkBit) ~= 0 ifTrue: [ "oop is forwarded; get its real header from its forwarding table entry" fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. header _ self longAt: fwdBlock + 4. ]. fmt _ (header >> 8) bitAnd: 16rF. fmt <= 4 ifTrue: [(fmt = 3 and: [self isContextHeader: header]) ifTrue: ["contexts end at the stack pointer" ^ (CtxtTempFrameStart + (self fetchStackPointerOf: oop)) * 4]. "do sizeBitsOf: using the header we obtained" (header bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ size _ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ size _ header bitAnd: SizeMask ]. ^ size - BaseHeaderSize]. fmt < 12 ifTrue: [ ^ 0 ]. "no pointers" methodHeader _ self longAt: oop + BaseHeaderSize. ^ ((methodHeader >> 10) bitAnd: 16rFF) * 4 + BaseHeaderSize! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/15/2003 06:42'! mapPointersInObjectsFrom: memStart to: memEnd "Use the forwarding table to update the pointers of all non-free objects in the given range of memory. Also remap pointers in root objects which may contains pointers into the given memory range." | oop | self inline: false. "update interpreter variables" self mapInterpreterOops. "update pointers in root objects" 1 to: rootTableCount do: [ :i | oop _ rootTable at: i. ((oop < memStart) or: [oop >= memEnd]) ifTrue: [ "Note: must not remap the fields of any object twice!!" "remap this oop only if not in the memory range covered below" self remapFieldsAndClassOf: oop. ]. ]. "update pointers in the given memory range" oop _ self oopFromChunk: memStart. [oop < memEnd] whileTrue: [ (self isFreeObject: oop) ifFalse: [ self remapFieldsAndClassOf: oop. ]. oop _ self objectAfterWhileForwarding: oop. ].! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 19:59'! objectAfterWhileForwarding: oop "Return the oop of the object after the given oop when the actual header of the oop may be in the forwarding table." | header fwdBlock realHeader sz | self inline: true. header _ self longAt: oop. (header bitAnd: MarkBit) = 0 ifTrue: [ ^ self objectAfter: oop ]. "oop not forwarded" "Assume: mark bit cannot be set on a free chunk, so if we get here, oop is not free and it has a forwarding table entry" fwdBlock _ (header bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. realHeader _ self longAt: fwdBlock + 4. "following code is like sizeBitsOf:" (realHeader bitAnd: TypeMask) = HeaderTypeSizeAndClass ifTrue: [ sz _ (self sizeHeader: oop) bitAnd: AllButTypeMask ] ifFalse: [ sz _ realHeader bitAnd: SizeMask ]. ^ self oopFromChunk: (oop + sz)! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:00'! remap: oop "Map the given oop to its new value during a compaction or become: operation. If it has no forwarding table entry, return the oop itself." | fwdBlock | self inline: false. (self isObjectForwarded: oop) ifTrue: [ "get the new value for oop from its forwarding block" fwdBlock _ ((self longAt: oop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. ^ self longAt: fwdBlock ]. ^ oop! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:00'! remapClassOf: oop "Update the class of the given object, if necessary, using its forwarding table entry." "Note: Compact classes need not be remapped since the compact class field is just an index into the compact class table. The header type bits show if this object has a compact class; we needn't look up the oop's real header." | classHeader classOop fwdBlock newClassOop newClassHeader | (self headerType: oop) = HeaderTypeShort ifTrue: [ ^nil ]. "compact classes needn't be mapped" classHeader _ self longAt: (oop - 4). classOop _ classHeader bitAnd: AllButTypeMask. (self isObjectForwarded: classOop) ifTrue: [ fwdBlock _ ((self longAt: classOop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. newClassOop _ self longAt: fwdBlock. newClassHeader _ newClassOop bitOr: (classHeader bitAnd: TypeMask). self longAt: (oop - 4) put: newClassHeader. "The following ensures that become: into an old object's class makes it a root. It does nothing during either incremental or full compaction because oop will never be < youngStart." ((oop < youngStart) and: [newClassOop >= youngStart]) ifTrue: [ self beRootWhileForwarding: oop ]. ].! ! !ObjectMemory methodsFor: 'gc -- compaction' stamp: 'jm 11/25/1998 20:01'! remapFieldsAndClassOf: oop "Replace all forwarded pointers in this object with their new oops, using the forwarding table. Remap its class as well, if necessary." "Note: The given oop may be forwarded itself, which means that its real header is in its forwarding table entry." | fieldOffset fieldOop fwdBlock newOop | self inline: true. fieldOffset _ self lastPointerWhileForwarding: oop. [fieldOffset >= BaseHeaderSize] whileTrue: [ fieldOop _ self longAt: (oop + fieldOffset). (self isObjectForwarded: fieldOop) ifTrue: [ "update this oop from its forwarding block" fwdBlock _ ((self longAt: fieldOop) bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ self fwdBlockValidate: fwdBlock ]. newOop _ self longAt: fwdBlock. self longAt: (oop + fieldOffset) put: newOop. "The following ensures that become: into old object makes it a root. It does nothing during either incremental or full compaction because oop will never be < youngStart." ((oop < youngStart) and: [newOop >= youngStart]) ifTrue: [ self beRootWhileForwarding: oop ]. ]. fieldOffset _ fieldOffset - 4. ]. self remapClassOf: oop.! ! !ObjectMemory methodsFor: 'become'! allYoung: array1 and: array2 "Return true if all the oops in both arrays, and the arrays themselves, are in the young object space." | fieldOffset | array1 < youngStart ifTrue: [ ^ false ]. array2 < youngStart ifTrue: [ ^ false ]. fieldOffset _ self lastPointerOf: array1. "same size as array2" [fieldOffset >= BaseHeaderSize] whileTrue: [ (self longAt: array1 + fieldOffset) < youngStart ifTrue: [ ^ false ]. (self longAt: array2 + fieldOffset) < youngStart ifTrue: [ ^ false ]. fieldOffset _ fieldOffset - 4. ]. ^ true! ! !ObjectMemory methodsFor: 'become' stamp: 'di 1/12/1999 14:17'! become: array1 with: array2 twoWay: twoWayFlag "All references to each object in array1 are swapped with all references to the corresponding object in array2. That is, all pointers to one object are replaced with with pointers to the other. The arguments must be arrays of the same length. Returns true if the primitive succeeds." "Implementation: Uses forwarding blocks to update references as done in compaction." (self fetchClassOf: array1) = (self splObj: ClassArray) ifFalse: [ ^ false ]. (self fetchClassOf: array2) = (self splObj: ClassArray) ifFalse: [ ^ false ]. (self lastPointerOf: array1) = (self lastPointerOf: array2) ifFalse: [ ^ false ]. (self containOnlyOops: array1 and: array2) ifFalse: [ ^ false ]. (self prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag) ifFalse: [^ false]. "fail; not enough space for forwarding table" (self allYoung: array1 and: array2) ifTrue: [ "sweep only the young objects plus the roots" self mapPointersInObjectsFrom: youngStart to: endOfMemory. ] ifFalse: [ "sweep all objects" self mapPointersInObjectsFrom: (self startOfMemory) to: endOfMemory. ]. twoWayFlag ifTrue: [self restoreHeadersAfterBecoming: array1 with: array2] ifFalse: [self restoreHeadersAfterForwardBecome]. self initializeMemoryFirstFree: freeBlock. "re-initialize memory used for forwarding table" ^ true "success"! ! !ObjectMemory methodsFor: 'become'! containOnlyOops: array1 and: array2 "Return true if neither array contains a small integer. You can't become: integers!!" | fieldOffset | fieldOffset _ self lastPointerOf: array1. "same size as array2" [fieldOffset >= BaseHeaderSize] whileTrue: [ (self isIntegerObject: (self longAt: array1 + fieldOffset)) ifTrue: [ ^ false ]. (self isIntegerObject: (self longAt: array2 + fieldOffset)) ifTrue: [ ^ false ]. fieldOffset _ fieldOffset - 4. ]. ^ true! ! !ObjectMemory methodsFor: 'become'! exchangeHashBits: oop1 with: oop2 | hdr1 hdr2 | hdr1 _ self longAt: oop1. hdr2 _ self longAt: oop2. self longAt: oop1 put: ((hdr1 bitAnd: AllButHashBits) bitOr: (hdr2 bitAnd: HashBits)). self longAt: oop2 put: ((hdr2 bitAnd: AllButHashBits) bitOr: (hdr1 bitAnd: HashBits)). ! ! !ObjectMemory methodsFor: 'become' stamp: 'jm 1/13/1999 10:56'! prepareForwardingTableForBecoming: array1 with: array2 twoWay: twoWayFlag "Ensure that there are enough forwarding blocks to accomodate this become, then prepare forwarding blocks for the pointer swap. Return true if successful." "Details: Doing a GC might generate enough space for forwarding blocks if we're short. However, this is an uncommon enough case that it is better handled by primitive fail code at the Smalltalk level." | entriesNeeded entriesAvailable fieldOffset oop1 oop2 fwdBlock fwdBlkSize | entriesNeeded _ (self lastPointerOf: array1) // 4. "need enough entries for all oops" twoWayFlag ifTrue: ["Double the number of blocks for two-way become" entriesNeeded _ entriesNeeded * 2. fwdBlkSize _ 8 "Note: Forward blocks must be quadword aligned."] ifFalse: ["One-way become needs backPointers in fwd blocks." fwdBlkSize _ 16 "Note: Forward blocks must be quadword aligned."]. entriesAvailable _ self fwdTableInit: fwdBlkSize. entriesAvailable < entriesNeeded ifTrue: [self initializeMemoryFirstFree: freeBlock. "re-initialize the free block" ^ false]. fieldOffset _ self lastPointerOf: array1. [fieldOffset >= BaseHeaderSize] whileTrue: [oop1 _ self longAt: array1 + fieldOffset. oop2 _ self longAt: array2 + fieldOffset. fwdBlock _ self fwdBlockGet: fwdBlkSize. self initForwardBlock: fwdBlock mapping: oop1 to: oop2 withBackPtr: twoWayFlag not. twoWayFlag ifTrue: ["Second block maps oop2 back to oop1 for two-way become" fwdBlock _ self fwdBlockGet: fwdBlkSize. self initForwardBlock: fwdBlock mapping: oop2 to: oop1 withBackPtr: twoWayFlag not]. fieldOffset _ fieldOffset - 4]. ^ true! ! !ObjectMemory methodsFor: 'become' stamp: 'jm 11/25/1998 19:41'! restoreHeaderOf: oop "Restore the original header of the given oop from its forwarding block." | fwdHeader fwdBlock | fwdHeader _ self longAt: oop. fwdBlock _ (fwdHeader bitAnd: AllButMarkBitAndTypeMask) << 1. DoAssertionChecks ifTrue: [ (fwdHeader bitAnd: MarkBit) = 0 ifTrue: [ self error: 'attempting to restore the header of an object that has no forwarding block'. ]. self fwdBlockValidate: fwdBlock. ]. self longAt: oop put: (self longAt: fwdBlock + 4). "restore orginal header"! ! !ObjectMemory methodsFor: 'become'! restoreHeadersAfterBecoming: list1 with: list2 "Restore the headers of all oops in both lists. Exchange their hash bits so becoming objects in identity sets and dictionaries doesn't change their hash value." | fieldOffset oop1 oop2 | fieldOffset _ self lastPointerOf: list1. [fieldOffset >= BaseHeaderSize] whileTrue: [ oop1 _ self longAt: list1 + fieldOffset. oop2 _ self longAt: list2 + fieldOffset. self restoreHeaderOf: oop1. self restoreHeaderOf: oop2. self exchangeHashBits: oop1 with: oop2. fieldOffset _ fieldOffset - 4. ].! ! !ObjectMemory methodsFor: 'become' stamp: 'di 1/12/1999 14:06'! restoreHeadersAfterForwardBecome "Forward become leaves us with no original oops in the mutated object list, so we must enumerate the (four-word) forwarding blocks where we have stored backpointers." | oop1 fwdBlock | "This loop start is copied from fwdBlockGet:" fwdBlock _ (endOfMemory + BaseHeaderSize + 7) bitAnd: 16rFFFFFFF8. fwdBlock _ fwdBlock + 16. "fwdBlockGet: did a pre-increment" [fwdBlock <= fwdTableNext] "fwdTableNext points to the last active block" whileTrue: [oop1 _ self longAt: fwdBlock + 8. "Backpointer to mutated object." self restoreHeaderOf: oop1. fwdBlock _ fwdBlock + 16].! ! !ObjectMemory methodsFor: 'finalization' stamp: 'ar 3/21/98 23:14'! aFinalizationComment "This finalization scheme assumes to have weak classes in which the fields are not traced during the mark phase of a GC. This means, if an object is referenced only by any instances of weak classes it can be collected. In turn, we need to find out if an object referenced by a weak class is actually being collected because we have to invalidate the weak object pointer and to signal that the object has gone. How do we know that an object referenced by a weak class is being collected? Well, this is based on two observations. First, objects will not change their relative locations in memory, meaning that if object A is created BEFORE object B it will always have a physical memory address which is LESS than B. Secondly, GC always works from a given starting address (youngStart during incremental GC; startOfMemory during fullGC) up to end of memory. If we can somehow garantuee that the weak reference is created after the object it points to we can easily implement the following simple scheme: 1) Mark phase Do not trace the fields of any instances of weak classes. 2) Sweep phase: a) Explicitly mark all free objects. b) If a weak reference is encountered check the the object it points to. If the object is marked as free than we know that this weak reference's object is gone. Signal that it is gone. There is, however, one small problem with this approach. We cannot always garantuee that WeakReferences point backwards such as in the following piece of code: | o1 o2 w1 w2 | o1 _ Object new. w1 _ WeakReference on: o1. o2 _ Object new. w2 _ WeakReference on: o2. o1 become: o2. The become: operation makes w1 point to o2 and because o2 has been created AFTER w1 the object reference in w1 points forward. Why might this be a problem? Well, if the GC would start after the weak reference AND free the object then the weak reference would simply point to an invalid memory location (since we've not been checking the weak reference during sweep phase). Fortunately, this can not happen in the current ObjectMemory implementation. Why? Well, the only GC not starting at the beginning of the memory is incremental GC. Incremental GC however is only executed in so-called youngSpace. If both, the weak reference AND the object it points to reside in youngSpace then we can still check the weak reference. If however, the weak reference is not in youngSpace but the object is, then the object is itself a root in young space and will be marked by the GC even if it is only referenced by the WeakReference. In the end, we just need a little adjustment in step 2b) of the above procedure which looks as follows: If the weak reference points * backwards: check if the object header is marked free * forwards: check if the object has been marked in markPhase. Note that a number of finalizations will only be executed during a fullGC. This happens if either the WeakReference or the object reside outside youngSpace. So, if you must garantuee that some object has been finalized you definitely need to do a fullGC. ar 3/20/98 17:20" self error:'Comment only'.! ! !ObjectMemory methodsFor: 'finalization' stamp: 'ar 3/23/98 22:39'! finalizeReference: oop "During sweep phase we have encountered a weak reference. Check if its object has gone away (or is about to) and if so, signal a semaphore." | weakOop oopGone chunk firstField lastField | "Do *not* inline this in sweepPhase - it is quite an unlikely case to run into a weak reference" self inline: false. firstField := BaseHeaderSize + ((self nonWeakFieldsOf: oop) << 2). lastField := self lastPointerOf: oop. firstField to: lastField by: 4 do:[:i| weakOop := self longAt: oop+i. ((weakOop == nilObj) or:[(self isIntegerObject: weakOop)]) ifFalse:[ "Check if the object is being collected. If the weak reference points * backward: check if the weakOops chunk is free * forward: check if the weakOoop has been marked by GC" weakOop < oop ifTrue:[ chunk _ self chunkFromOop: weakOop. oopGone _ ((self longAt: chunk) bitAnd: TypeMask) = HeaderTypeFree] ifFalse:[oopGone _ ((self baseHeader: weakOop) bitAnd: MarkBit) = 0]. oopGone ifTrue:[ "Store nil in the pointer and signal the interpreter" self longAt: oop+i put: nilObj. self signalFinalization: oop]. ]. ].! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'jm 12/20/2003 19:12'! initialize "ObjectMemory initialize" "Note: Table sizes tweaked for MicroSqueak." "Translation flags (booleans that control code generation via conditional translation):" DoAssertionChecks _ false. "generate assertion checks" self initializeSpecialObjectIndices. self initializeObjectHeaderConstants. LargeContextSize _ 156. SmallContextSize _ 76. CtxtTempFrameStart _ 6. "Copy of TempFrameStart in Interp" NilContext _ 1. "the oop for the integer 0; used to mark the end of context lists" MinimumForwardTableBytes _ 10000. "bytes reserved for forwarding table (8 bytes/entry)" RemapBufferSize _ 5. RootTableSize _ 500. "number of root table entries (4 bytes/entry)" "tracer actions" StartField _ 1. StartObj _ 2. Upward _ 3. Done _ 4.! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'go 11/18/1998 10:42'! initializeObjectHeaderConstants BaseHeaderSize _ 4. "masks for type field" TypeMask _ 3. AllButTypeMask _ 16rFFFFFFFF - TypeMask. "type field values" HeaderTypeSizeAndClass _ 0. HeaderTypeClass _ 1. HeaderTypeFree _ 2. HeaderTypeShort _ 3. "type field values used during the mark phase of GC" HeaderTypeGC _ 2. GCTopMarker _ 3. "neither an oop, nor an oop+1, this value signals that we have crawled back up to the top of the marking phase." "base header word bit fields" HashBits _ 16r1FFE0000. AllButHashBits _ 16rFFFFFFFF - HashBits. HashBitsOffset _ 17. SizeMask _ 16rFC. CompactClassMask _ 16r1F000. "masks for root and mark bits" MarkBit _ 16r80000000. RootBit _ 16r40000000. AllButMarkBit _ 16rFFFFFFFF - MarkBit. AllButRootBit _ 16rFFFFFFFF - RootBit. AllButMarkBitAndTypeMask _ AllButTypeMask - MarkBit.! ! !ObjectMemory class methodsFor: 'initialization' stamp: 'jm 12/30/2003 20:43'! initializeSpecialObjectIndices "Initialize indices into specialObjects array." NilObject _ 0. FalseObject _ 1. TrueObject _ 2. SchedulerAssociation _ 3. "ClassBitmap _ 4." "not used" ClassInteger _ 5. "ClassString _ 6." "not used" ClassArray _ 7. "SmalltalkDictionary _ 8." "Do not delete!!" ClassFloat _ 9. ClassMethodContext _ 10. ClassBlockContext _ 11. ClassPoint _ 12. ClassLargePositiveInteger _ 13. TheDisplay _ 14. ClassMessage _ 15. ClassCompiledMethod _ 16. TheLowSpaceSemaphore _ 17. ClassSemaphore _ 18. ClassCharacter _ 19. SelectorDoesNotUnderstand _ 20. SelectorCannotReturn _ 21. "TheInputSemaphore _ 22." "not used" SpecialSelectors _ 23. CharacterTable _ 24. SelectorMustBeBoolean _ 25. ClassByteArray _ 26. "ClassProcess _ 27." "not used" CompactClasses _ 28. TheTimerSemaphore _ 29. TheInterruptSemaphore _ 30. FloatProto _ 31. "SmallMethodContext _ 34." "not used" "SmallBlockContext _ 36." "not used" ExternalObjectsArray _ 38. "ClassPseudoContext _ 39." "not used" "ClassTranslatedMethod _ 40." "not used" TheFinalizationSemaphore _ 41.! ! !ObjectMemory class methodsFor: 'translation'! declareCVarsIn: aCCodeGenerator aCCodeGenerator var: 'memory' declareC: 'unsigned char *memory'. aCCodeGenerator var: 'remapBuffer' declareC: 'int remapBuffer[', (RemapBufferSize + 1) printString, ']'. aCCodeGenerator var: 'rootTable' declareC: 'int rootTable[', (RootTableSize + 1) printString, ']'.! ! I represent a collection of objects ordered by the collector.! !OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'! size "Answer how many elements the receiver contains." ^ lastIndex - firstIndex + 1! ! !OrderedCollection methodsFor: 'adding' stamp: 'di 3/15/1999 14:01'! add: newObject afterIndex: index "Add the argument, newObject, as an element of the receiver. Put it in the sequence just after index. Answer newObject." self insert: newObject before: firstIndex + index. ^ newObject! ! !OrderedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 11:26'! addAll: aCollection "Add each element of aCollection at my end. Answer aCollection." ^ self addAllLast: aCollection! ! !OrderedCollection methodsFor: 'removing' stamp: 'sma 5/12/2000 11:24'! removeAllSuchThat: aBlock "Evaluate aBlock for each element and remove all that elements from the receiver for that aBlock evaluates to true." | index | index _ firstIndex. [index <= lastIndex] whileTrue: [(aBlock value: (array at: index)) ifTrue: [self removeIndex: index] ifFalse: [index _ index + 1]]! ! !OrderedCollection methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'! removeAt: index | removed | removed _ self at: index. self removeIndex: index + firstIndex - 1. ^removed! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'! collect: aBlock "Evaluate aBlock with each of my elements as the argument. Collect the resulting values into a collection that is like me. Answer the new collection. Override superclass in order to use addLast:, not at:put:." | newCollection | newCollection _ self species new: self size. firstIndex to: lastIndex do: [:index | newCollection addLast: (aBlock value: (array at: index))]. ^ newCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:13'! select: aBlock "Evaluate aBlock with each of my elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true." | newCollection element | newCollection _ self copyEmpty. firstIndex to: lastIndex do: [:index | (aBlock value: (element _ array at: index)) ifTrue: [newCollection addLast: element]]. ^ newCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'! with: otherCollection collect: twoArgBlock "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." | result | otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. result _ self species new: self size. 1 to: self size do: [:index | result addLast: (twoArgBlock value: (self at: index) value: (otherCollection at: index))]. ^ result! ! !OrderedCollection methodsFor: 'private' stamp: 'sma 5/12/2000 11:20'! find: oldObject | index | index _ firstIndex. [index <= lastIndex and: [oldObject ~= (array at: index)]] whileTrue: [index _ index + 1]. index <= lastIndex ifTrue: [^ index] ifFalse: [self errorNotFound: oldObject]! ! !OrderedCollection methodsFor: 'private' stamp: 'ar 5/22/2000 12:17'! removeIndex: removedIndex array replaceFrom: removedIndex to: lastIndex - 1 with: array startingAt: removedIndex+1. array at: lastIndex put: nil. lastIndex _ lastIndex - 1.! ! !OrderedCollection methodsFor: 'private' stamp: 'ar 4/16/1999 07:59'! resetTo: index firstIndex _ index. lastIndex _ firstIndex - 1! ! !OrderedCollection methodsFor: 'testing' stamp: 'bf 8/20/1999 15:08'! hasContentsInExplorer ^self isEmpty not! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:41'! new ^ self new: 10! ! !OrderedCollection class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 17:42'! new: anInteger ^ super new setCollection: (Array new: anInteger)! ! Post Office Protocol. This is used to download email over the network, usually from an intermittent connection. To see how to use it, see POPSocket classe>>example.! !POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:14'! addProgressObserver: anObserver "progress will be sent to anObserver. anObserver should respond to show:, endEntry, cr.... Transcript things" progressObservers add: anObserver! ! !POPSocket methodsFor: 'initialization' stamp: 'ar 5/5/1999 23:25'! initialize: socketType super initialize: socketType. progressObservers _ IdentitySet new.! ! !POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:10'! password: aString "set the password to use" password _ aString ! ! !POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:22'! serverName: aString "set the server name to connect to" serverName _ aString! ! !POPSocket methodsFor: 'initialization' stamp: 'ls 9/7/1998 05:10'! userName: aString "set the username to use" userName _ aString! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/14/1998 12:51'! connectToPOP "connect to the POP server" | address response | Socket initializeNetwork. address _ NetNameResolver addressForName: serverName timeout: 15. address = nil ifTrue: [ self error: 'Could not find host address']. "connect the socket" self connectTo: address port: 110. (self waitForConnectionUntil: POPSocket standardDeadline) ifFalse: [ self close. self reportToObservers: 'failed to connect to server'. ^false ]. "get a hello message" self reportToObservers: (response _ self getResponse). (response beginsWith: '+') ifFalse: [ self close. ^false ]. "login" self sendCommand: 'USER ', userName. self reportToObservers: (response _ self getResponse). (response beginsWith: '+') ifFalse: [ self close. ^false ]. self sendCommand: 'PASS ', password. self reportToObservers: (response _ self getResponse). (response beginsWith: '+') ifFalse: [ self close. ^false ]. ^true! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 01:55'! deleteAllMessages "delete all messages" 1 to: self numMessages do: [ :num | self deleteMessage: num ]! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/7/1998 06:07'! deleteMessage: num "delete the numbered message" self sendCommand: 'DELE ', num printString. self reportToObservers: self getResponse. ! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/2/1998 16:05'! disconnectFromPOP "Send a QUIT message, then disconnect." self isValid ifFalse: [^ self]. "already closed" self reportToObservers: 'closing connection'. numMessages _ nil. self sendCommand: 'QUIT'. self reportToObservers: self getResponse. self closeAndDestroy. ! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 01:54'! messagesDo: aBlock "perform aBlock on each message text" | thisMessage | 1 to: self numMessages do: [ :num | thisMessage _ self retrieveMessage: num. aBlock value: thisMessage. ]. ! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'mdr 2/16/1999 12:53'! numMessages "Query the server and answer the number of messages that are in the user's mailbox." | response answerString | numMessages ifNotNil: [^ numMessages]. "cached result of earlier query" self sendCommand: 'STAT'. response _ self getResponse. self reportToObservers: response. (response beginsWith: '+OK') ifFalse: [^ 0]. "error" answerString _ (response findTokens: Character separators) second. "NB: It is important to cache the result so that all operations, especially delete and deleteAll, are done on the same set of messages" numMessages _ answerString asNumber asInteger. "cache the result" ^ numMessages! ! !POPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/7/1998 06:04'! retrieveMessage: number "retrieve the numbered message" | response | self sendCommand: 'RETR ', number printString. response _ self getResponse. self reportToObservers: response. (response beginsWith: '+OK') ifFalse: [ self error: 'error: ', response ]. ^self getMultilineResponse.! ! !POPSocket methodsFor: 'private' stamp: 'ls 9/10/1998 19:57'! reportToObservers: aString "send aString to all observers" progressObservers do: [ :observer | observer show: aString. aString last = Character cr ifFalse: [ observer show: String cr ]].! ! !POPSocket class methodsFor: 'as yet unclassified' stamp: 'ls 9/10/1998 19:44'! example "POPSocket example" "download a user's messages into an OrderedCollection and inspect the OrderedCollection" | ps messages | ps _ POPSocket new. ps serverName: (FillInTheBlank request: 'POP server'). ps userName: (FillInTheBlank request: 'POP username'). ps password: (FillInTheBlank request: 'POP password'). ps addProgressObserver: Transcript. messages _ OrderedCollection new. ps connectToPOP. ps messagesDo: [ :messageText | messages add: messageText ]. ps disconnectFromPOP. messages inspect.! ! !POPSocket class methodsFor: 'as yet unclassified' stamp: 'jm 10/26/2002 09:59'! example2 "POPSocket example2" "Download my messages into an OrderedCollection and inspect the OrderedCollection." | ps messages | ps _ POPSocket new. ps serverName: 'pop.earthlink.net'. ps userName: 'JohnMaloney'. ps password: (FillInTheBlank request: 'POP password'). ps addProgressObserver: Transcript. messages _ OrderedCollection new. ps connectToPOP. ps messagesDo: [:messageText |messages add: messageText ]. ps disconnectFromPOP. messages inspect. ! ! !PaintBoxColorPicker methodsFor: 'initialization' stamp: 'jm 10/10/2002 16:20'! initialize super initialize. currentColor _ Color black. locOfCurrent _ nil. selectingColor _ false. ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:06'! handlesMouseDown: evt ^ true ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:14'! handlesMouseOver: evt ^ true ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:24'! mouseDown: evt "Start color selection. Make me stay up as long as the mouse is down." selectingColor _ true. self selectColor: evt. ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:17'! mouseLeave: evt selectingColor ifFalse: [self delete]. ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:27'! mouseMove: evt "Update current color and report it to paint box." self selectColor: evt. ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 10/10/2002 16:25'! mouseUp: evt "Update current color and report it to paint box." selectingColor _ false. self selectColor: evt. ! ! !PaintBoxColorPicker methodsFor: 'event handling' stamp: 'jm 11/13/2002 10:59'! selectColor: evt "Update the receiver from the given event. Constrain locOfCurrent's center to lie within the color selection area. If it is partially in the transparent area, snap it entirely into it vertically." | r | locOfCurrent _ evt cursorPoint - self topLeft. r _ Rectangle center: locOfCurrent extent: 9@9. locOfCurrent _ locOfCurrent + (r amountToTranslateWithin: (5@11 corner: 140@136)). locOfCurrent x > 128 ifTrue: [locOfCurrent _ 135@locOfCurrent y]. "snap into grayscale" locOfCurrent y < 17 ifTrue: [ locOfCurrent _ locOfCurrent x@11. "snap into transparent" currentColor _ Color transparent] ifFalse: [ currentColor _ form colorAt: locOfCurrent]. (owner isKindOf: PaintBoxMorph) ifTrue: [owner takeColorFrom: self]. self changed. ! ! I am Squeak's image creation and editing tool, originally written by Ted Kaehler for use the EToy programming system. ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'bf 1/5/2000 19:42'! createButtons "Create buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button nib | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: pickup: "pickup: pickup: pickup:" stamp: "stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | (self findButton: sel) ifNil: [ PopUpMenu notify: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. button actionSelector: #tool:action:cursor:; arguments: (Array with: button with: sel with: nil). button actWhen: #buttonUp; target: self. ]]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | (self findButton: sel) ifNil: [ PopUpMenu notify: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ ThreePhaseButtonMorph new. button onImage: nil; bounds: rect. self addMorph: button. nib _ Form dotOfSize: (#(1 2 3 6 11 26) at: ind). button actionSelector: #brush:action:nib:; arguments: (Array with: button with: sel with: nib). button actWhen: #buttonUp; target: self. ]]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'jm 6/15/2003 18:03'! loadRotScalePics "Load up class vars with .bmp files for the images of the Rotation control button and the Scale control button." rotationTabForm _ (Form fromFileNamed: 'Rotaball.bmp') asFormOfDepth: 16. scaleTabForm _ (Form fromFileNamed: 'Scalball.bmp') asFormOfDepth: 16. ! ! !PaintBoxMorph methodsFor: 'initialization' stamp: 'bf 1/5/2000 19:42'! moveButtons "Move buttons one at a time and let the user place them over the background. Later can move them again by turning on AuthorModeOwner in ThreePhaseButtonMorph. self createButtons. " | rect button | #(erase: eyedropper: fill: paint: rect: ellipse: polygon: line: star: "pickup: pickup: pickup: pickup:" "stamp: stamp: stamp: stamp:" undo: keep: toss: prevStamp: nextStamp:) do: [:sel | PopUpMenu notify: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self findButton: sel. button bounds: rect. "image is nil" ]. #(brush1: brush2: brush3: brush4: brush5: brush6: ) doWithIndex: [:sel :ind | PopUpMenu notify: 'Rectangle for ',sel. rect _ Rectangle fromUser. button _ self findButton: sel. button bounds: rect. "image is nil" ]. "stamp: Stamps are held in a ScrollingToolHolder. Pickups and stamps and brushes are id-ed by the button == with item from a list." " " ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'jm 6/16/2003 23:08'! focusMorph "Search the world for a SketchEditorMorph if the current focus morph is nil." ^ focusMorph ifNil:[focusMorph _ self world findA: SketchEditorMorph] ! ! !PaintBoxMorph methodsFor: 'other' stamp: 'jm 6/16/2003 23:09'! focusMorph: newFocus "Set the new focus morph." focusMorph _ newFocus. ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 5/25/2000 18:00'! actionCursor "Return the cursor to use with this painting action/tool. Offset of the form must be set." | ff width co larger c box | action == #paint: ifTrue: ["Make a cursor from the brush and the color" width _ self getNib width. c _ self ringColor. co _ (currentCursor offset - ((width//4)@34-(width//6))) min: (0@0). larger _ width negated + 10@0 extent: currentCursor extent + (width@width). ff _ currentCursor copy: larger. ff colors at: 1 put: Color transparent. ff colors at: 2 put: Color transparent. ff offset: co - (width@width //2). (ff getCanvas) fillOval: (Rectangle center: ff offset negated extent: width@width) color: Color transparent borderWidth: 1 borderColor: c. ^ ff]. action == #erase: ifTrue: ["Make a cursor from the cursor and the color" width _ self getNib width. co _ (currentCursor offset + (width//2@4)) min: (0@0). larger _ 0@0 extent: currentCursor extent + (width@width). ff _ currentCursor copy: larger. ff offset: co - (width@width //2). ff fill: (box _ co negated extent: (width@width)) fillColor: (Color r: 0.5 g: 0.5 b: 1.0). ff fill: (box insetBy: 1@1) fillColor: Color transparent. ^ ff]. ^ currentCursor ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 3/23/2000 14:25'! clear: clearButton with: clearSelector | ss | (ss _ self focusMorph) ifNotNil: [ss clearPainting: self] ifNil: [self notCurrentlyPainting]. clearButton state: #off.! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'kfr 4/26/2000 22:25'! eyedropper: aButton action: aSelector cursor: aCursor "Take total control and pick up a color!!!!" | pt feedbackColor | aButton state: #on. tool ifNotNil: [tool state: #off]. currentCursor _ aCursor. self activeHand showTemporaryCursor: currentCursor hotSpotOffset: 6 negated @ 4 negated. "<<<< the form was changed a bit??" feedbackColor _ Display colorAt: Sensor cursorPoint. self addMorphFront: colorMemory. "Full color picker" [Sensor anyButtonPressed] whileFalse: [pt _ Sensor cursorPoint. "deal with the fact that 32 bit displays may have garbage in the alpha bits" feedbackColor _ Display depth = 32 ifTrue: [ Color colorFromPixelValue: ((Display pixelValueAt: pt) bitOr: 16rFF000000) depth: 32 ] ifFalse: [ Display colorAt: pt ]. "the hand needs to be drawn" self activeHand position: pt. self world displayWorldSafely. Display fill: colorPatch bounds fillColor: feedbackColor]. Sensor waitNoButton. self activeHand showTemporaryCursor: nil hotSpotOffset: 0 @ 0. self currentColor: feedbackColor. colorMemory delete. tool ifNotNil: [tool state: #on. currentCursor _ tool arguments at: 3]. aButton state: #off! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 3/23/2000 14:25'! keep: keepButton with: keepSelector "Showing of the corrent palette (viewer or noPalette) is done by the block submitted to the SketchMorphEditor, see (EToyHand makeNewDrawing) and (SketchMorph editDrawingInWorld:forBackground:)." | ss | owner ifNil: [^ self]. keepButton ifNotNil: [keepButton state: #off]. (ss _ self focusMorph) ifNotNil: [ss savePainting: self] ifNil: [keepSelector == #silent ifTrue: [^ self]. self notCurrentlyPainting].! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 3/23/2000 14:22'! pickup: actionButton action: aSelector cursor: aCursor "Special version for pickup: and stamp:, because of these tests" | ss picker old map stamper | self tool: actionButton action: aSelector cursor: aCursor. aSelector == #stamp: ifTrue: [ (stampHolder pickupButtons includes: actionButton) ifTrue: [ stamper _ stampHolder otherButtonFor: actionButton. ^ self pickup: stamper action: #stamp: cursor: (stamper arguments at: 3)]. (stampHolder stampFormFor: actionButton) ifNil: [ "If not stamp there, go to pickup mode" picker _ stampHolder otherButtonFor: actionButton. picker state: #on. ^ self pickup: picker action: #pickup: cursor: (picker arguments at: 3)] ifNotNil: [ old _ stampHolder stampFormFor: actionButton. currentCursor _ ColorForm extent: old extent depth: 8. old displayOn: currentCursor. map _ Color indexedColors copy. map at: 1 put: Color transparent. currentCursor colors: map. currentCursor offset: currentCursor extent // -2. "Emphisize the stamp button" actionButton owner "layoutMorph" "color: (Color r: 1.0 g: 0.645 b: 0.419);" borderColor: (Color r: 0.65 g: 0.599 b: 0.8). ]]. aSelector == #pickup: ifTrue: [ ss _ self focusMorph. ss ifNotNil: [currentCursor _ aCursor] ifNil: [self notCurrentlyPainting. self setAction: #paint:]]. ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'kfr 4/26/2000 21:17'! ringColor "Choose a color that contrasts with my current color. If that color isn't redish, return red. Otherwise, return green" currentColor isTransparent ifTrue: [^ Color red]. currentColor red < 0.5 ifTrue: [^ Color red]. currentColor red > (currentColor green + (currentColor blue * 0.5)) ifTrue: [^ Color green] ifFalse: [^ Color red]. ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'jm 10/11/2002 20:31'! showColorPalette | | colorMemory align: colorMemory bounds topRight with: colorMemoryThin bounds topRight. self addMorphFront: colorMemory. ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'tk 3/8/1999 22:35'! stampCursorBeCursorFor: anAction "User just chose a stamp. Take that stamp picture and make it be the cursor for the tool named." "self stampCursorBeCursorFor: #star:. currentCursor offset: -9@-3. Has side effect on the saved cursor." (self findButton: anAction) arguments at: 3 put: currentCursor. "Already converted to 8 bits and in the right form"! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'di 9/2/1999 09:25'! takeColorEvt: evt from: colorPicker ^ self takeColorFrom: colorPicker! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'di 9/2/1999 09:18'! takeColorFrom: colorPicker "Accept a new color from the colorMemory. Programs use currentColor: instead. Do not do this before the picker has a chance to set its own color!!" currentColor _ colorPicker currentColor. self showColor. self colorable ifFalse: [self setAction: #paint:]. "User now thinking of painting"! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 3/23/2000 14:24'! toss: cancelButton with: cancelSelector "Reject the painting. Showing noPalette is done by the block submitted to the SketchEditorMorph" | focus | owner ifNil: ["it happens" ^ self]. (focus _ self focusMorph) ifNotNil: [focus cancelPainting: self] ifNil: [self delete]. cancelButton state: #off. ! ! !PaintBoxMorph methodsFor: 'actions' stamp: 'ar 3/23/2000 14:24'! undo: undoButton with: undoSelector | ss | (ss _ self focusMorph) ifNotNil: [ss undoPainting: self] ifNil: [self notCurrentlyPainting]. undoButton state: #off.! ! !PaintBoxMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 20:41'! step "Pop out the ColorPalette when the mouse goes over colorMemoryThin." colorMemoryThin isNil | colorMemory isNil ifTrue: [^ self]. ((colorMemory isInWorld not) and: [colorMemoryThin containsPoint: self world hands first position]) ifTrue: [self showColorPalette]. ! ! !PaintBoxMorph methodsFor: 'event handling' stamp: 'jm 10/11/2002 20:38'! stepTime ^ 100 ! ! !PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'ar 5/25/2000 18:00'! new | pb button dualUse formCanvas rect | pb _ Prototype fullCopy. "Assume that the PaintBox does not contain any scripted Players!!" pb stampHolder normalize. "Get the stamps to show" "Get my own copies of the brushes so I can modify them" #(brush1: brush2: brush3: brush4: brush5: brush6:) do: [:sel | button _ pb findButton: sel. button offImage: button offImage deepCopy. dualUse _ button onImage == button pressedImage. "sometimes shared" button onImage: button onImage deepCopy. dualUse ifTrue: [button pressedImage: button onImage] ifFalse: [button pressedImage: button pressedImage deepCopy]. "force color maps for later mapping" button offImage. button onImage. button pressedImage. formCanvas _ button onImage getCanvas. formCanvas _ formCanvas copyOrigin: 0@0 clipRect: (rect _ 0@0 extent: button onImage extent). (#(brush1: brush3:) includes: sel) ifTrue: [ rect _ rect origin corner: rect corner - (2@2)]. (#brush2: == sel) ifTrue: [ rect _ rect origin corner: rect corner - (2@4)]. formCanvas frameAndFillRectangle: rect fillColor: Color transparent borderWidth: 2 borderColor: (Color r: 0.599 g: 0.8 b: 1.0). ]. pb showColor. ^ pb! ! !PaintBoxMorph class methodsFor: 'as yet unclassified' stamp: 'jm 10/11/2002 20:42'! prototype "Answer my prototype." ^ Prototype ! ! I represent displayable text that has been decoraged with margin alignment, line leading, and tab settings.! !Paragraph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'! replaceFrom: start to: stop with: aText displaying: displayBoolean "Replace the receiver's text starting at position start, stopping at stop, by the characters in aText. It is expected that most requirements for modifications to the receiver will call this code. Certainly all cut's or paste's." | compositionScanner obsoleteLines obsoleteLastLine firstLineIndex lastLineIndex startLine stopLine replacementRange visibleRectangle startIndex newLine done newStop obsoleteY newY moveRectangle | text replaceFrom: start to: stop with: aText. "Update the text." lastLine = 0 ifTrue: ["if lines have never been set up, measure them and display all the lines falling in the visibleRectangle" self composeAll. displayBoolean ifTrue: [^ self displayLines: (1 to: lastLine)]]. "save -- things get pretty mashed as we go along" obsoleteLines _ lines copy. obsoleteLastLine _ lastLine. "find the starting and stopping lines" firstLineIndex _ startLine _ self lineIndexOfCharacterIndex: start. stopLine _ self lineIndexOfCharacterIndex: stop. "how many characters being inserted or deleted -- negative if aText size is < characterInterval size." replacementRange _ aText size - (stop - start + 1). "Give ourselves plenty of elbow room." compositionRectangle _ compositionRectangle withHeight: (textStyle lineGrid * 9999). "build a boundingBox of the actual screen space in question -- we'll need it later" visibleRectangle _ (clippingRectangle intersect: compositionRectangle) intersect: destinationForm boundingBox. compositionScanner _ CompositionScanner new forParagraph: self. "Initialize a scanner." "If the starting line is not also the first line, then measuring must commence from line preceding the one in which characterInterval start appears. For example, deleting a line with only a carriage return may move characters following the deleted portion of text into the line preceding the deleted line." startIndex _ (lines at: firstLineIndex) first. startLine > 1 ifTrue: [newLine _ compositionScanner composeLine: startLine - 1 fromCharacterIndex: (lines at: startLine - 1) first inParagraph: self. (lines at: startLine - 1) = newLine ifFalse: ["start in line preceding the one with the starting character" startLine _ startLine - 1. self lineAt: startLine put: newLine. startIndex _ newLine last + 1]]. startIndex > text size ifTrue: ["nil lines after a deletion -- remeasure last line below" self trimLinesTo: (firstLineIndex - 1 max: 0). text size = 0 ifTrue: ["entire text deleted -- clear visibleRectangle and return." displayBoolean ifTrue: [destinationForm fill: visibleRectangle rule: rule fillColor: self backgroundColor]. self updateCompositionHeight. ^self]]. "Now we really get to it." done _ false. lastLineIndex _ stopLine. [done or: [startIndex > text size]] whileFalse: [self lineAt: firstLineIndex put: (newLine _ compositionScanner composeLine: firstLineIndex fromCharacterIndex: startIndex inParagraph: self). [(lastLineIndex > obsoleteLastLine or: ["no more old lines to compare with?" newLine last < (newStop _ (obsoleteLines at: lastLineIndex) last + replacementRange)]) or: [done]] whileFalse: [newStop = newLine last ifTrue: ["got the match" "get source and dest y's for moving the unchanged lines" obsoleteY _ self topAtLineIndex: lastLineIndex + 1 using: obsoleteLines and: obsoleteLastLine. newY _ self topAtLineIndex: firstLineIndex + 1. stopLine _ firstLineIndex. done _ true. "Fill in the new line vector with the old unchanged lines. Update their starting and stopping indices on the way." ((lastLineIndex _ lastLineIndex + 1) to: obsoleteLastLine) do: [:upDatedIndex | self lineAt: (firstLineIndex _ firstLineIndex + 1) put: ((obsoleteLines at: upDatedIndex) slide: replacementRange)]. "trim off obsolete lines, if any" self trimLinesTo: firstLineIndex] ifFalse: [lastLineIndex _ lastLineIndex + 1]]. startIndex _ newLine last + 1. firstLineIndex _ firstLineIndex + 1]. "Now the lines are up to date -- Whew!!. What remains is to move the 'unchanged' lines and display those which have changed." displayBoolean "Not much to do if not displaying" ifFalse: [^ self updateCompositionHeight]. startIndex > text size ifTrue: ["If at the end of previous lines simply display lines from the line in which the first character of the replacement occured through the end of the paragraph." self updateCompositionHeight. self displayLines: (startLine to: (stopLine _ firstLineIndex min: lastLine)). destinationForm "Clear out area at the bottom" fill: ((visibleRectangle left @ (self topAtLineIndex: lastLine + 1) extent: visibleRectangle extent) intersect: visibleRectangle) rule: rule fillColor: self backgroundColor] ifFalse: [newY ~= obsoleteY ifTrue: ["Otherwise first move the unchanged lines within the visibleRectangle with a good old bitblt." moveRectangle _ visibleRectangle left @ (obsoleteY max: visibleRectangle top) corner: visibleRectangle corner. destinationForm copyBits: moveRectangle from: destinationForm at: moveRectangle origin + (0 @ (newY-obsoleteY)) clippingBox: visibleRectangle rule: Form over fillColor: nil]. "Then display the altered lines." self displayLines: (startLine to: stopLine). newY < obsoleteY ifTrue: [(self topAtLineIndex: obsoleteLastLine+1 using: obsoleteLines and: obsoleteLastLine) > visibleRectangle bottom ifTrue: ["A deletion may have 'pulled' previously undisplayed lines into the visibleRectangle. If so, display them." self displayLines: ((self lineIndexOfTop: visibleRectangle bottom - (obsoleteY - newY)) to: (self lineIndexOfTop: visibleRectangle bottom))]. "Clear out obsolete material at the bottom of the visibleRectangle." destinationForm fill: ((visibleRectangle left @ ((self bottomAtLineIndex: lastLine) + 1) extent: visibleRectangle extent) intersect: visibleRectangle) "How about just corner: ??" rule: rule fillColor: self backgroundColor]. (newY > obsoleteY and: [obsoleteY < visibleRectangle top]) ifTrue: ["An insertion may have 'pushed' previously undisplayed lines into the visibleRectangle. If so, display them." self displayLines: ((self lineIndexOfTop: visibleRectangle top) to: (self lineIndexOfTop: visibleRectangle top + (newY-obsoleteY)))]. self updateCompositionHeight]! ! !Paragraph methodsFor: 'accessing' stamp: 'sw 10/29/1999 18:11'! stringAtLineNumber: aNumber (aNumber > lastLine or: [aNumber < 1]) ifTrue: [^ nil]. ^ (text string copyFrom: (lines at: aNumber) first to: (lines at: aNumber) last) copyWithout: Character cr! ! !Paragraph methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:21'! computeBoundingBox ^ offset extent: compositionRectangle extent ! ! !Paragraph methodsFor: 'composition' stamp: 'ar 5/18/2000 18:34'! composeAll "Compose a collection of characters into a collection of lines." | startIndex stopIndex lineIndex maximumRightX compositionScanner | lines _ Array new: 32. lastLine _ 0. maximumRightX _ 0. text size = 0 ifTrue: [compositionRectangle _ compositionRectangle withHeight: 0. ^maximumRightX]. startIndex _ lineIndex _ 1. stopIndex _ text size. compositionScanner _ CompositionScanner new forParagraph: self. [startIndex > stopIndex] whileFalse: [self lineAt: lineIndex put: (compositionScanner composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: self). maximumRightX _ compositionScanner rightX max: maximumRightX. startIndex _ (lines at: lineIndex) last + 1. lineIndex _ lineIndex + 1]. self updateCompositionHeight. self trimLinesTo: lineIndex - 1. ^ maximumRightX! ! !Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for characters in the text at point aPoint. It is assumed that aPoint has been transformed into coordinates appropriate to the receiver's destinationForm rectangle and the compositionRectangle." ^CharacterBlockScanner new characterBlockAtPoint: aPoint in: self! ! !Paragraph methodsFor: 'character location' stamp: 'ar 5/18/2000 18:33'! characterBlockForIndex: targetIndex "Answer a CharacterBlock for character in the text at targetIndex. The coordinates in the CharacterBlock will be appropriate to the intersection of the destinationForm rectangle and the compositionRectangle." ^CharacterBlockScanner new characterBlockForIndex: targetIndex in: self! ! !Paragraph methodsFor: 'character location' stamp: 'di 10/5/1998 12:59'! defaultCharacterBlock ^ CharacterBlock new stringIndex: 1 text: text topLeft: compositionRectangle topLeft extent: 0 @ 0! ! !Paragraph methodsFor: 'selecting' stamp: 'jm 5/29/2003 18:02'! caretFormForDepth: depth "Return a caret form for the given depth." "(Paragraph new caretFormForDepth: Display depth) displayOn: Display at: 0@0 rule: Form reverse" | box f bb map | box _ CaretForm boundingBox. f _ Form extent: box extent depth: depth. map _ (Color cachedColormapFrom: CaretForm depth to: depth) copy. map at: 1 put: (Color transparent pixelValueForDepth: depth). map at: 2 put: (Color quickHighLight: depth) first. "pixel value for reversing" bb _ BitBlt toForm: f. bb sourceForm: CaretForm; sourceRect: box; destOrigin: 0@0; colorMap: map; combinationRule: Form over; copyBits. ^ f! ! !Paragraph methodsFor: 'selecting' stamp: 'sw 12/7/1999 12:26'! clickAt: clickPoint for: model controller: aController "Give sensitive text a chance to fire. Display flash: (100@100 extent: 100@100)." | startBlock action range box boxes | action _ false. startBlock _ self characterBlockAtPoint: clickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) do: [:att | att mayActOnClick ifTrue: [range _ text rangeOf: att startingAt: startBlock stringIndex forStyle: textStyle. boxes _ self selectionRectsFrom: (self characterBlockForIndex: range first) to: (self characterBlockForIndex: range last). box _ boxes detect: [:each | each containsPoint: clickPoint] ifNone: [^ action]. Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [aController terminateAndInitializeAround: [(att actOnClickFor: model) ifTrue: [action _ true]]]]]. ^ action! ! !Paragraph methodsFor: 'selecting' stamp: 'jm 7/1/1999 12:31'! hiliteRect: rect | highlightColor | highlightColor _ Color quickHighLight: destinationForm depth. rect ifNotNil: [ destinationForm fill: rect rule: Form reverse fillColor: highlightColor. "destinationForm fill: (rect translateBy: 1@1) rule: Form reverse fillColor: highlightColor" ]. ! ! !Paragraph methodsFor: 'private' stamp: 'ar 5/18/2000 18:34'! displayLines: linesInterval affectedRectangle: affectedRectangle "This is the first level workhorse in the display portion of the TextForm routines. It checks to see which lines in the interval are actually visible, has the CharacterScanner display only those, clears out the areas in which display will occur, and clears any space remaining in the visibleRectangle following the space occupied by lastLine." | lineGrid topY firstLineIndex lastLineIndex lastLineIndexBottom | "Save some time by only displaying visible lines" firstLineIndex _ self lineIndexOfTop: affectedRectangle top. firstLineIndex < linesInterval first ifTrue: [firstLineIndex _ linesInterval first]. lastLineIndex _ self lineIndexOfTop: affectedRectangle bottom - 1. lastLineIndex > linesInterval last ifTrue: [linesInterval last > lastLine ifTrue: [lastLineIndex _ lastLine] ifFalse: [lastLineIndex _ linesInterval last]]. lastLineIndexBottom _ (self bottomAtLineIndex: lastLineIndex). ((Rectangle origin: affectedRectangle left @ (topY _ self topAtLineIndex: firstLineIndex) corner: affectedRectangle right @ lastLineIndexBottom) intersects: affectedRectangle) ifTrue: [ " . . . (skip to clear-below if no lines displayed)" DisplayScanner new displayLines: (firstLineIndex to: lastLineIndex) in: self clippedBy: affectedRectangle]. lastLineIndex = lastLine ifTrue: [destinationForm "Clear out white space below last line" fill: (affectedRectangle left @ (lastLineIndexBottom max: affectedRectangle top) corner: affectedRectangle bottomRight) rule: rule fillColor: self backgroundColor]! ! I am a Controller for editing a Paragraph. I am a kind of ScrollController, so that more text can be created for the Paragraph than can be viewed on the screen. Editing messages are sent by issuing commands from a yellow button menu or from keys on the keyboard. My instances keep control as long as the cursor is within the view when the red or yellow mouse button is pressed; they give up control if the blue button is pressed.! !ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 11/30/97 10:13'! resetState "Establish the initial conditions for editing the paragraph: place caret before first character, set the emphasis to that of the first character, and save the paragraph for purposes of canceling." startBlock _ paragraph defaultCharacterBlock. stopBlock _ startBlock copy. beginTypeInBlock _ nil. UndoInterval _ otherInterval _ 1 to: 0. self setEmphasisHere. selectionShowing _ false. initialText _ paragraph text copy! ! !ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 5/15/2000 13:51'! stateArray ^ {ChangeText. FindText. UndoInterval. UndoMessage. UndoParagraph. UndoSelection. Undone. self selectionInterval. self startOfTyping. emphasisHere}! ! !ParagraphEditor methodsFor: 'initialize-release' stamp: 'di 10/5/1998 17:03'! stateArrayPut: stateArray | sel | ChangeText _ stateArray at: 1. FindText _ stateArray at: 2. UndoInterval _ stateArray at: 3. UndoMessage _ stateArray at: 4. UndoParagraph _ stateArray at: 5. UndoSelection _ stateArray at: 6. Undone _ stateArray at: 7. sel _ stateArray at: 8. self selectFrom: sel first to: sel last. beginTypeInBlock _ stateArray at: 9. emphasisHere _ stateArray at: 10.! ! !ParagraphEditor methodsFor: 'accessing' stamp: 'sw 12/7/1999 11:39'! zapSelectionWith: aText "Deselect, and replace the selection text by aText. Remember the resulting selectionInterval in UndoInterval and otherInterval. Do not set up for undo." | start stop | self deselect. start _ startBlock stringIndex. stop _ stopBlock stringIndex. (aText isEmpty and: [stop > start]) ifTrue: ["If deleting, then set emphasisHere from 1st character of the deletion" emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle) select: [:att | att mayBeExtended]]. (start = stop and: [aText size = 0]) ifFalse: [paragraph replaceFrom: start to: stop - 1 with: aText displaying: true. self computeIntervalFrom: start to: start + aText size - 1. UndoInterval _ otherInterval _ self selectionInterval]! ! !ParagraphEditor methodsFor: 'controlling' stamp: 'sma 3/11/2000 15:17'! normalActivity self processKeyboard. self processMouseButtons! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 5/4/2000 13:45'! browseClassFromIt "Launch a hierarchy browser for the class indicated by the current selection. If multiple classes matching the selection exist, let the user choose among them." | aClass | self lineSelectAndEmptyCheck: [^ self]. aClass _ Utilities classFromPattern: (self selection string copyWithout: Character cr) withCaption: 'choose a class to browse...'. aClass ifNil: [^ view flash]. self terminateAndInitializeAround: [Utilities spawnHierarchyForClass: aClass selector: nil]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 4/20/2000 12:18'! browseIt "Launch a browser for the current selection, if appropriate" | aSymbol anEntry brow | Preferences alternativeBrowseIt ifTrue: [^ self browseClassFromIt]. self lineSelectAndEmptyCheck: [^ self]. (aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash]. self terminateAndInitializeAround: [aSymbol first isUppercase ifTrue: [anEntry _ (Smalltalk at: aSymbol ifAbsent: [Smalltalk browseAllImplementorsOf: aSymbol. ^ nil]). anEntry isNil ifTrue: [^ view flash]. (anEntry isKindOf: Class) ifFalse: [anEntry _ anEntry class]. brow _ Preferences browseToolClass new. brow setClass: anEntry selector: nil. brow class openBrowserView: (brow openEditString: nil) label: 'System Browser'] ifFalse: [Smalltalk browseAllImplementorsOf: aSymbol]]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 6/23/1998 11:08'! browseItHere "Retarget the receiver's window to look at the selected class, if appropriate. 3/1/96 sw" | aSymbol foundClass b | (((b _ model) isKindOf: Browser) and: [b couldBrowseAnyClass]) ifFalse: [^ view flash]. model okToChange ifFalse: [^ view flash]. self selectionInterval isEmpty ifTrue: [self selectWord]. (aSymbol _ self selectedSymbol) isNil ifTrue: [^ view flash]. self terminateAndInitializeAround: [foundClass _ (Smalltalk at: aSymbol ifAbsent: [nil]). foundClass isNil ifTrue: [^ view flash]. (foundClass isKindOf: Class) ifTrue: [model systemCategoryListIndex: (model systemCategoryList indexOf: foundClass category). model classListIndex: (model classList indexOf: foundClass name)]]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:42'! changeEmphasisOrAlignment | aList reply | aList _ #(plain bold italic narrow underlined struckOut leftFlush centered rightFlush justified). reply _ (SelectionMenu labelList: aList lines: #(6) selections: aList) startUp. reply ~~ nil ifTrue: [(#(leftFlush centered rightFlush justified) includes: reply) ifTrue: [paragraph perform: reply. self recomputeInterval] ifFalse: [self setEmphasis: reply. paragraph composeAll. self recomputeSelection. self mvcRedisplay]]. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 12/30/1999 15:29'! changeStyle "Let user change styles for the current text pane Moved from experimentalCommand to its own method " | aList reply style | aList _ StrikeFont familyNames remove: 'DefaultTextStyle' ifAbsent: []; asOrderedCollection. aList addFirst: 'DefaultTextStyle'. reply _ (SelectionMenu labelList: aList lines: #(1) selections: aList) startUp. reply ~~ nil ifTrue: [(style _ TextStyle named: reply) ifNil: [self beep. ^ true]. paragraph textStyle: style copy. paragraph composeAll. self recomputeSelection. self mvcRedisplay]. ^ true! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 9/27/1999 11:54'! chooseAlignment self changeAlignment! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 4/28/1999 11:39'! clipboardText ^ self class clipboardText! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 4/28/1999 11:40'! clipboardTextPut: text ^ self class clipboardTextPut: text! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 11/23/1998 15:21'! compareToClipboard "Check to see if whether the receiver's text is the same as the text currently on the clipboard, and inform the user." | s1 s2 | s1 _ self clipboardText string. s2 _ paragraph text string. s1 = s2 ifTrue: [^ self inform: 'Exact match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2)) openLabel: 'Comparison to Clipboard Text'! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'ls 10/10/1999 11:36'! explain "Try to shed some light on what kind of entity the current selection is. The selection must be a single token or construct. Insert the answer after the selection. Send private messages whose names begin with 'explain' that return a string if they recognize the selection, else nil." | string tiVars cgVars selectors delimitors numbers sorry reply symbol | Cursor execute showWhile: [sorry _ '"Sorry, I can''t explain that. Please select a single token, construct, or special character.'. sorry _ sorry , (view canDiscardEdits ifFalse: [' Also, please cancel or accept."'] ifTrue: ['"']). (string _ self selection asString) isEmpty ifTrue: [reply _ ''] ifFalse: [string _ self explainScan: string. "Remove space, tab, cr" "Temps and Instance vars need only test strings that are all letters" (string detect: [:char | (char isLetter or: [char isDigit]) not] ifNone: []) ifNil: [tiVars _ self explainTemp: string. tiVars == nil ifTrue: [tiVars _ self explainInst: string]]. (tiVars == nil and: [model respondsTo: #explainSpecial:]) ifTrue: [tiVars _ model explainSpecial: string]. tiVars == nil ifTrue: [tiVars _ ''] ifFalse: [tiVars _ tiVars , '\' withCRs]. "Context, Class, Pool, and Global vars, and Selectors need only test symbols" (Symbol hasInterned: string ifTrue: [:s | symbol _ s]) ifTrue: [cgVars _ self explainCtxt: symbol. cgVars == nil ifTrue: [cgVars _ self explainClass: symbol. cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]]. "See if it is a Selector (sent here or not)" selectors _ self explainMySel: symbol. selectors == nil ifTrue: [selectors _ self explainPartSel: string. selectors == nil ifTrue: [ selectors _ self explainAnySel: symbol]]] ifFalse: [selectors _ self explainPartSel: string]. cgVars == nil ifTrue: [cgVars _ ''] ifFalse: [cgVars _ cgVars , '\' withCRs]. selectors == nil ifTrue: [selectors _ ''] ifFalse: [selectors _ selectors , '\' withCRs]. string size = 1 ifTrue: ["single special characters" delimitors _ self explainChar: string] ifFalse: ["matched delimitors" delimitors _ self explainDelimitor: string]. numbers _ self explainNumber: string. numbers == nil ifTrue: [numbers _ '']. delimitors == nil ifTrue: [delimitors _ '']. reply _ tiVars , cgVars , selectors , delimitors , numbers]. reply size = 0 ifTrue: [reply _ sorry]. self afterSelectionInsertAndSelect: reply]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:41'! fileItIn "Make a Stream on the text selection and fileIn it. 1/24/96 sw: moved here from FileController; this function can be useful from any text window that shows stuff in chunk format" | selection | selection _ self selection. self terminateAndInitializeAround: [(ReadWriteStream on: selection string from: 1 to: selection size) fileIn]. ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 10/5/1998 21:55'! find "Prompt the user for a string to search for, and search the receiver from the current selection onward for it. 1/26/96 sw" | reply | reply _ FillInTheBlank request: 'Find what? ' initialAnswer: ''. reply size == 0 ifTrue: [^ self]. self setSearch: reply. ChangeText _ FindText. "Implies no replacement to againOnce: method" self againOrSame: true ! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sw 11/2/1998 09:43'! lineSelectAndEmptyCheck: returnBlock "If the current selection is an insertion point, expand it to be the entire current line; if after that's done the selection is still empty, then evaluate the returnBlock, which will typically consist of '[^ self]' in the caller -- check senders of this method to understand this." self selectLine. "if current selection is an insertion point, then first select the entire line in which occurs before proceeding" startBlock = stopBlock ifTrue: [self flash. ^ returnBlock value]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 4/26/2000 21:57'! pasteRecent "Paste an item chose from RecentClippings." | clipping | (clipping _ self class chooseRecentClipping) ifNil: [^ self]. CurrentSelection _ clipping. ^ self paste! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:40'! prettyPrint self prettyPrint: false! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'sma 5/28/2000 09:41'! prettyPrint: decorated "Reformat the contents of the receiver's view (a Browser)." | selectedClass newText | model selectedMessageCategoryName ifNil: [^ view flash]. selectedClass _ model selectedClassOrMetaClass. newText _ selectedClass compilerClass new format: self text in: selectedClass notifying: self decorated: decorated. newText ifNotNil: [self deselect; selectInvisiblyFrom: 1 to: paragraph text size. self replaceSelectionWith: (newText asText makeSelectorBoldIn: selectedClass). self selectAt: 1]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 6/26/1998 10:04'! referencesToIt "Open a references browser on the selected symbol" | aSymbol | self selectionInterval isEmpty ifTrue: [self selectWord]. ((aSymbol _ self selectedSymbol) == nil or: [(Smalltalk includesKey: aSymbol) not]) ifTrue: [^ view flash]. self terminateAndInitializeAround: [Smalltalk browseAllCallsOn: (Smalltalk associationAt: self selectedSymbol)]! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'dew 3/9/2000 00:15'! saveContentsInFile | fileName stringToSave parentWindow labelToUse | stringToSave _ paragraph text string. stringToSave size == 0 ifTrue: [^ self inform: 'nothing to save.']. parentWindow _ self model dependents detect: [:dep | dep isKindOf: SystemWindow] ifNone: [nil]. parentWindow isNil ifTrue: [labelToUse _ 'Untitled'] ifFalse: [labelToUse _ parentWindow label]. fileName _ FillInTheBlank request: 'File name? (".text" will be added to end)' initialAnswer: labelToUse. fileName size == 0 ifTrue: [^ self beep]. (fileName asLowercase endsWith: '.text') ifFalse: [fileName _ fileName,'.text']. (FileStream newFileNamed: fileName) nextPutAll: stringToSave; close! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'bf 10/13/1999 09:09'! selectedSelector "Try to make a selector out of the current text selection" ^self selection string findSelector! ! !ParagraphEditor methodsFor: 'menu messages' stamp: 'di 9/7/1999 08:44'! spawnWorkspace | toUse | self selectLine. toUse _ self selection asString. toUse size > 0 ifFalse: [toUse _ paragraph text string. toUse size > 0 ifFalse: [^ self flash]]. "NB: BrowserCodeController's version does a cancel here" self terminateAndInitializeAround: [Utilities openScratchWorkspaceLabeled: 'Untitled' contents: toUse]! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/14/1999 15:07'! explainChar: string "Does string start with a special character?" | char | char _ string at: 1. char = $. ifTrue: [^'"Period marks the end of a Smalltalk statement. A period in the middle of a number means a decimal point. (The number is an instance of class Float)."']. char = $' ifTrue: [^'"The characters between two single quotes are made into an instance of class String"']. char = $" ifTrue: [^'"Double quotes enclose a comment. Smalltalk ignores everything between double quotes."']. char = $# ifTrue: [^'"The characters following a hash mark are made into an instance of class Symbol. If parenthesis follow a hash mark, an instance of class Array is made. It contains literal constants."']. (char = $( or: [char = $)]) ifTrue: [^'"Expressions enclosed in parenthesis are evaluated first"']. (char = $[ or: [char = $]]) ifTrue: [^'"The code inside square brackets is an unevaluated block of code. It becomes an instance of BlockContext and is usually passed as an argument."']. (char = $< or: [char = $>]) ifTrue: [^'"<primitive: xx> means that this method is usually preformed directly by the virtual machine. If this method is primitive, its Smalltalk code is executed only when the primitive fails."']. char = $^ ifTrue: [^'"Uparrow means return from this method. The value returned is the expression following the ^"']. char = $| ifTrue: [^'"Vertical bars enclose the names of the temporary variables used in this method. In a block, the vertical bar separates the argument names from the rest of the code."']. char = $_ ifTrue: [^'"Left arrow means assignment. The value of the expression after the left arrow is stored into the variable before it."']. char = $; ifTrue: [^'"Semicolon means cascading. The message after the semicolon is sent to the same object which received the message before the semicolon."']. char = $: ifTrue: [^'"A colon at the end of a keyword means that an argument is expected to follow. Methods which take more than one argument have selectors with more than one keyword. (One keyword, ending with a colon, appears before each argument).', '\\' withCRs, 'A colon before a variable name just inside a block means that the block takes an agrument. (When the block is evaluated, the argument will be assigned to the variable whose name appears after the colon)."']. char = $$ ifTrue: [^'"The single character following a dollar sign is made into an instance of class Character"']. char = $- ifTrue: [^'"A minus sign in front of a number means a negative number."']. char = $e ifTrue: [^'"An e in the middle of a number means that the exponent follows."']. char = $r ifTrue: [^'"An r in the middle of a bunch of digits is an instance of Integer expressed in a certain radix. The digits before the r denote the base and the digits after it express a number in that base."']. char = Character space ifTrue: [^'"the space Character"']. char = Character tab ifTrue: [^'"the tab Character"']. char = Character cr ifTrue: [^'"the carriage return Character"']. ^nil! ! !ParagraphEditor methodsFor: 'explain' stamp: 'ar 2/13/1999 21:17'! explainClass: symbol "Is symbol a class variable or a pool variable?" | class reply classes | (model respondsTo: #selectedClassOrMetaClass) ifFalse: [^ nil]. (class _ model selectedClassOrMetaClass) ifNil: [^nil]. "no class is selected" (class isKindOf: Metaclass) ifTrue: [class _ class soleInstance]. classes _ (Array with: class) , class allSuperclasses. "class variables" reply _ classes detect: [:each | (each classVarNames detect: [:name | symbol = name] ifNone: []) ~~ nil] ifNone: []. reply == nil ifFalse: [^'"is a class variable; defined in class ' , reply printString, '"\' withCRs, 'Smalltalk browseAllCallsOn: (', reply printString, ' classPool associationAt: #', symbol, ').']. "pool variables" classes do: [:each | (each sharedPools detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]] ifNone: []) ~~ nil]. reply == nil ifTrue: [(Undeclared includesKey: symbol) ifTrue: [reply _ Undeclared]]. reply == nil ifFalse: [classes _ WriteStream on: Array new. Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply] ifNone: []) ~~ nil ifTrue: [classes nextPut: each]]. "Perhaps not print whole list of classes if too long. (unlikely)" ^'"is a pool variable from the pool ' , (Smalltalk keyAtIdentityValue: reply), ', which is used by the following classes ' , classes contents printString , '"\' withCRs, 'Smalltalk browseAllCallsOn: (', (Smalltalk keyAtIdentityValue: reply) printString, ' associationAt: #', symbol, ').']. ^nil! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/20/1999 09:48'! explainMySel: symbol "Is symbol the selector of this method? Is it sent by this method? If not, then expalin will call (explainPartSel:) to see if it is a fragment of a selector sent here. If not, explain will call (explainAnySel:) to catch any selector. " | lits classes msg | (model respondsTo: #selectedMessageName) ifFalse: [^ nil]. (msg _ model selectedMessageName) ifNil: [^nil]. "not in a message" classes _ Smalltalk allClassesImplementing: symbol. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. msg = symbol ifTrue: [^ '"' , symbol , ' is the selector of this very method!! It is defined in ', classes , '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'] ifFalse: [lits _ (model selectedClassOrMetaClass compiledMethodAt: msg) messages. (lits detect: [:each | each == symbol] ifNone: []) == nil ifTrue: [^nil]. ^ '"' , symbol , ' is a message selector which is defined in ', classes , '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'].! ! !ParagraphEditor methodsFor: 'explain' stamp: 'apb 1/5/2000 16:56'! explainNumber: string "Is string a Number?" | strm c | (c _ string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1 and: [(string at: 2) isDigit]]) ifFalse: [^nil]]. strm _ ReadStream on: string. c _ Number readFrom: strm. strm atEnd ifFalse: [^nil]. c printString = string ifTrue: [^'"' , string , ' is a ' , c class name , '"'] ifFalse: [^'"' , string , ' (= ' , c printString , ') is a ' , c class name , '"']! ! !ParagraphEditor methodsFor: 'explain' stamp: 'tk 4/20/1999 09:51'! explainPartSel: string "Is this a fragment of a multiple-argument selector sent in this method?" | lits whole reply classes s msg | (model respondsTo: #selectedMessageName) ifFalse: [^ nil]. (msg _ model selectedMessageName) ifNil: [^ nil]. "not in a message" string last == $: ifFalse: [^ nil]. "Name of this method" lits _ Array with: msg. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifTrue: [reply _ ', which is the selector of this very method!!'. s _ '. To see the other definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."'] ifFalse: ["Selectors called from this method" lits _ (model selectedClassOrMetaClass compiledMethodAt: msg) messages. (whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string] ifNone: []) ~~ nil] ifNone: []) ~~ nil ifFalse: [string = 'primitive:' ifTrue: [^self explainChar: '<'] ifFalse: [^nil]]. reply _ '.'. s _ '. To see the definitions, go to the message list pane, get the menu from the top of the scroll bar, and select ''implementors of...''."']. classes _ Smalltalk allClassesImplementing: whole. classes size > 12 ifTrue: [classes _ 'many classes'] ifFalse: [classes _ 'these classes ' , classes printString]. ^ '"' , string , ' is one part of the message selector ' , whole, reply , ' It is defined in ' , classes , s! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:40'! cancel: characterStream "Cancel unsubmitted changes. Flushes typeahead. 1/12/96 sw 1/22/96 sw: put in control terminate/init" sensor keyboard. self terminateAndInitializeAround: [self cancel]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 12/7/1999 11:37'! changeEmphasis: characterStream "Change the emphasis of the current selection or prepare to accept characters with the change in emphasis. Emphasis change amounts to a font change. Keeps typeahead." | keyCode attribute oldAttributes index thisSel colors | "control 0..9 -> 0..9" keyCode _ ('0123456789-=' indexOf: sensor keyboard ifAbsent: [1]) - 1. oldAttributes _ paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle. thisSel _ self selection. "Decipher keyCodes for Command 0-9..." (keyCode between: 1 and: 5) ifTrue: [attribute _ TextFontChange fontNumber: keyCode]. keyCode = 6 ifTrue: [colors _ #(black magenta red yellow green blue cyan white). index _ (PopUpMenu labelArray: colors , #('Do it' 'Link to comment of class' 'Link to definition of class' 'Link to hierarchy of class' 'Link to method' 'URL' 'Copy hidden info') lines: (Array with: colors size)) startUp. index = 0 ifTrue: [^ true]. index <= colors size ifTrue: [attribute _ TextColor color: (Color perform: (colors at: index))] ifFalse: [index _ index - colors size. index = 1 ifTrue: [attribute _ TextDoIt new. thisSel _ attribute analyze: self selection asString]. index = 2 ifTrue: [attribute _ TextLink new. thisSel _ attribute analyze: self selection asString with: 'Comment']. index = 3 ifTrue: [attribute _ TextLink new. thisSel _ attribute analyze: self selection asString with: 'Definition']. index = 4 ifTrue: [attribute _ TextLink new. thisSel _ attribute analyze: self selection asString with: 'Hierarchy']. index = 5 ifTrue: [attribute _ TextLink new. thisSel _ attribute analyze: self selection asString]. index = 6 ifTrue: [attribute _ TextURL new. thisSel _ attribute analyze: self selection asString]. index = 7 ifTrue: ["Copy hidden info" self copyHiddenInfo. ^ true]. "no other action" thisSel ifNil: [^ true]]. "Could not figure out what to link to" ]. (keyCode between: 7 and: 11) ifTrue: [sensor leftShiftDown ifTrue: [keyCode = 10 ifTrue: [attribute _ TextKern kern: -1]. keyCode = 11 ifTrue: [attribute _ TextKern kern: 1]] ifFalse: [attribute _ TextEmphasis perform: (#(bold italic narrow underlined struckOut) at: keyCode - 6). oldAttributes do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]]. (keyCode = 0) ifTrue: [attribute _ TextEmphasis normal]. beginTypeInBlock ~~ nil ifTrue: "only change emphasisHere while typing" [self insertTypeAhead: characterStream. emphasisHere _ Text addAttribute: attribute toArray: oldAttributes. ^ true]. self replaceSelectionWith: (thisSel asText addAttribute: attribute). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 11:58'! changeLfToCr: characterStream "Replace all LFs by CRs. Triggered by Cmd-U -- useful when getting code from FTP sites" | cr lf | sensor keyboard. "flush the triggering cmd-key character" cr _ Character cr. lf _ Character linefeed. self replaceSelectionWith: (Text fromString: (self selection string collect: [:c | c = lf ifTrue: [cr] ifFalse: [c]])). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:31'! compareToClipboard: characterStream "Compare the receiver to the text on the clipboard. Flushes typeahead. 5/1/96 sw" sensor keyboard. self terminateAndInitializeAround: [self compareToClipboard]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'bf 3/16/2000 18:25'! copyHiddenInfo "In TextLinks, TextDoits, TextColor, and TextURLs, there is hidden info. Copy that to the clipboard. You can paste it and see what it is. Usually enclosed in <>." | attrList | attrList _ paragraph text attributesAt: (startBlock stringIndex + stopBlock stringIndex)//2 forStyle: paragraph textStyle. attrList do: [:attr | (attr isKindOf: TextAction) ifTrue: [^ self clipboardTextPut: ('<', attr info, '>') asText]]. "If none of the above" attrList do: [:attr | attr class == TextColor ifTrue: [^ self clipboardTextPut: attr color printString asText]]. ^ self clipboardTextPut: '[No hidden info]' asText! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:23'! doIt: characterStream "Called when user hits cmd-d. Select the current line, if relevant, then evaluate and execute. 2/1/96 sw. 2/29/96 sw: don't call selectLine; it's done by doIt now" sensor keyboard. self terminateAndInitializeAround: [self doIt]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'acg 12/7/1999 07:56'! exploreIt: characterStream "Explore the selection -- invoked via cmd-shift-I. If there is no current selection, use the current line." sensor keyboard. "flush character" self terminateAndInitializeAround: [self exploreIt]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'! inspectIt: characterStream "Inspect the selection -- invoked via cmd-i. If there is no current selection, use the current line. 1/17/96 sw 2/29/96 sw: don't call selectLine; it's done by inspectIt now" sensor keyboard. "flush character" self terminateAndInitializeAround: [self inspectIt]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:06'! makeCapitalized: characterStream "Force the current selection to uppercase. Triggered by Cmd-X." | prev | sensor keyboard. "flush the triggering cmd-key character" prev _ $-. "not a letter" self replaceSelectionWith: (Text fromString: (self selection string collect: [:c | prev _ prev isLetter ifTrue: [c asLowercase] ifFalse: [c asUppercase]])). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:00'! makeLowercase: characterStream "Force the current selection to lowercase. Triggered by Cmd-X." sensor keyboard. "flush the triggering cmd-key character" self replaceSelectionWith: (Text fromString: (self selection string asLowercase)). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 5/28/1998 12:00'! makeUppercase: characterStream "Force the current selection to uppercase. Triggered by Cmd-X." sensor keyboard. "flush the triggering cmd-key character" self replaceSelectionWith: (Text fromString: (self selection string asUppercase)). ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'jm 6/9/2003 21:52'! offerFontMenu "Present a menu of available fonts, and if one is chosen, apply it to the current selection. Use only names of Fonts of this paragraph " | aList reply | aList _ paragraph textStyle fontNamesWithHeights. reply _ (SelectionMenu labelList: aList selections: aList) startUp. reply ~~ nil ifTrue: [self replaceSelectionWith: (Text string: self selection asString attribute: (TextFontChange fontNumber: (aList indexOf: reply)))] ! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:25'! printIt: characterStream "Print the results of evaluting the selection -- invoked via cmd-p. If there is no current selection, use the current line. 1/17/96 sw 2/29/96 sw: don't call selectLine now, since it's called by doIt" sensor keyboard. "flush character" self terminateAndInitializeAround: [self printIt]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'! save: characterStream "Submit the current text. Equivalent to 'accept' 1/18/96 sw Keeps typeahead." sensor keyboard. "flush character" self closeTypeIn: characterStream. self terminateAndInitializeAround: [self accept]. ^ true! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'sw 12/7/1999 11:38'! setEmphasis: emphasisSymbol "Change the emphasis of the current selection." | oldAttributes attribute | oldAttributes _ paragraph text attributesAt: startBlock stringIndex forStyle: paragraph textStyle. (emphasisSymbol == #plain) ifTrue: [attribute _ TextEmphasis normal] ifFalse: [attribute _ TextEmphasis perform: emphasisSymbol. oldAttributes do: [:att | (att dominates: attribute) ifTrue: [attribute turnOff]]]. self replaceSelectionWith: (self selection addAttribute: attribute)! ! !ParagraphEditor methodsFor: 'editing keys' stamp: 'di 9/7/1999 08:43'! spawnIt: characterStream "Triggered by Cmd-o; spawn a new code window, if it makes sense." sensor keyboard. self terminateAndInitializeAround: [self spawn]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:51'! comment "All key actions that are neither editing nor typing actions have to send closeTypeIn at first. See comment in openTypeIn closeTypeIn"! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:31'! cursorDown: characterStream "Private - Move cursor from position in current line to same position in next line. If next line too short, put at end. If shift key down, select." | shift string right left start position textSize| self closeTypeIn: characterStream. shift := sensor leftShiftDown. sensor keyboard. string _ paragraph text string. textSize _ string size. left _ right _ stopBlock stringIndex. [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1]. position _ stopBlock stringIndex - left. [right < textSize and: [(string at: right) ~= Character cr]] whileTrue: [right _ right + 1]. right _ start _ right + 1. [right < textSize and: [(string at: right) ~= Character cr]] whileTrue: [right _ right + 1]. shift ifTrue: [ start + position > right ifTrue: [self selectFrom: startBlock stringIndex to: right - 1] ifFalse: [self selectFrom: startBlock stringIndex to: start + position - 1] ] ifFalse: [ start + position > right ifTrue: [self selectFrom: right to: right - 1] ifFalse: [self selectFrom: start + position to: start + position - 1] ]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/22/2000 17:42'! cursorEnd: characterStream "Private - Move cursor end of current line. If cursor already at end of line, put cursor at end of text" | string right stringSize | self closeTypeIn: characterStream. sensor keyboard. string _ paragraph text string. stringSize _ string size. right _ stopBlock stringIndex. [right <= stringSize and: [(string at: right) ~= Character cr]] whileTrue: [right _ right + 1]. sensor commandKeyPressed ifTrue: [right _ stringSize + 1]. sensor leftShiftDown ifTrue: [self selectFrom: startBlock stringIndex to: right - 1] ifFalse: [self selectAt: right]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/22/2000 17:42'! cursorHome: characterStream "Private - Move cursor from position in current line to beginning of current line. If cursor already at beginning of line, put cursor at beginning of text" | string left | self closeTypeIn: characterStream. sensor keyboard. string _ paragraph text string. left _ startBlock stringIndex. [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1]. sensor commandKeyPressed ifTrue: [left _ 1]. sensor leftShiftDown ifTrue: [self selectFrom: left to: stopBlock stringIndex - 1] ifFalse: [self selectAt: left]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:54'! cursorLeft: characterStream "Private - Move cursor left one character if nothing selected, otherwise move cursor to beginning of selection. If the shift key is down, start selecting or extending current selection. Don't allow cursor past beginning of text" | shift left | self closeTypeIn: characterStream. shift _ sensor leftShiftDown. left _ startBlock stringIndex - 1. sensor controlKeyPressed ifTrue: [left _ self previousWord: left]. sensor keyboard. shift ifTrue: [startBlock stringIndex > 1 ifTrue: [self selectFrom: left to: stopBlock stringIndex - 1]] ifFalse: [(startBlock stringIndex == stopBlock stringIndex and: [startBlock stringIndex > 1]) ifTrue: [self selectAt: left] ifFalse: [self selectAt: startBlock stringIndex]]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sbw 10/12/1999 12:11'! cursorPageDown: characterStream ^self cursorPageJump: characterStream down: true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'! cursorPageJump: characterStream down: aBoolean "Private - Move cursor from position in current line to same position in the line on the next page up or down (direction is controlled by <aBoolean>. If next line too short, put at end. If shift key down, select. This method is similar to #cursorDown:. Haven't figured out how to intercept the shift key yet. See Utilities createPageTestWorkspace to create a test MVC workspace." | string right left start position textSize currentLineNumber howManyLines visibleHeight totalHeight ratio deltaLines targetLine offsetAtTargetLine | self closeTypeIn: characterStream. sensor keyboard. "Eat the key stroke." string _ paragraph text string. textSize _ string size. left _ right _ stopBlock stringIndex. "Calculate the position of the left edge." [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1]. "Calculate the offset from the left edge where cursor is now." position _ stopBlock stringIndex - left. "Calculate the current line number." currentLineNumber _ paragraph lineIndexOfCharacterIndex: stopBlock stringIndex. howManyLines _ paragraph numberOfLines. visibleHeight _ self visibleHeight. totalHeight _ self totalTextHeight. ratio _ visibleHeight / totalHeight. deltaLines _ (ratio * howManyLines) rounded - 2. targetLine _ aBoolean ifTrue: [(currentLineNumber + deltaLines) min: howManyLines] ifFalse: [(currentLineNumber - deltaLines) max: 1]. offsetAtTargetLine _ (paragraph lines at: targetLine) first. "Calculate the position of the right edge of text of target line." right _ offsetAtTargetLine. [right < textSize and: [(string at: right) ~= Character cr]] whileTrue: [right _ right + 1]. start _ offsetAtTargetLine. start + position > right ifTrue: [self selectForTopFrom: right to: right - 1] ifFalse: [self selectForTopFrom: start + position to: start + position - 1]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sbw 10/12/1999 12:11'! cursorPageUp: characterStream ^self cursorPageJump: characterStream down: false! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'! cursorRight: characterStream "Private - Move cursor right one character if nothing selected, otherwise move cursor to end of selection. If the shift key is down, start selecting characters or extending already selected characters. Don't allow cursor past end of text" | shift right | self closeTypeIn: characterStream. shift _ sensor leftShiftDown. right _ stopBlock stringIndex + 1. sensor controlKeyPressed ifTrue: [right _ self nextWord: right]. sensor keyboard. shift ifTrue: [self selectFrom: startBlock stringIndex to: right - 1] ifFalse: [startBlock stringIndex == stopBlock stringIndex ifTrue: [self selectAt: right] ifFalse: [self selectAt: stopBlock stringIndex]]. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'! cursorUp: characterStream "Private - Move cursor from position in current line to same position in prior line. If prior line too short, put at end" | shift string left position start | self closeTypeIn: characterStream. shift := sensor leftShiftDown. sensor keyboard. string _ paragraph text string. left _ startBlock stringIndex. [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1]. position _ startBlock stringIndex - left. start _ left. left _ left - 1. [left > 1 and: [(string at: (left - 1)) ~= Character cr]] whileTrue: [left _ left - 1]. left < 1 ifTrue: [left _ 1]. start = 1 ifTrue: [position _ 0]. shift ifTrue: [ (start - left < position and: [start > 1]) ifTrue: [self selectFrom: start - 1 to: stopBlock stringIndex - 1] ifFalse: [self selectFrom: left + position to: stopBlock stringIndex - 1] ] ifFalse: [ (start - left < position and: [start > 1]) ifTrue: [self selectFrom: start - 1 to: start - 2] ifFalse: [self selectFrom: left + position to: left + position - 1] ]. ^true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'! selectCurrentTypeIn: characterStream "Select what would be replaced by an undo (e.g., the last typeIn)." | prior | self closeTypeIn: characterStream. prior _ otherInterval. sensor keyboard. "flush character" self closeTypeIn: characterStream. self selectInterval: UndoInterval. otherInterval _ prior. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'sma 12/15/1999 11:46'! selectWord: characterStream sensor keyboard. self closeTypeIn: characterStream. self selectWord. ^ true! ! !ParagraphEditor methodsFor: 'nonediting/nontyping keys' stamp: 'th 1/21/2000 18:55'! setSearchString: characterStream "Establish the current selection as the current search string." | aString | self closeTypeIn: characterStream. sensor keyboard. self lineSelectAndEmptyCheck: [^ true]. aString _ self selection string. aString size == 0 ifTrue: [self flash] ifFalse: [self setSearch: aString]. ^ true! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sma 2/12/2000 20:17'! backspace: characterStream "Backspace over the last character." | startIndex | sensor leftShiftDown ifTrue: [^ self backWord: characterStream]. characterStream isEmpty ifTrue: [startIndex _ startBlock stringIndex + (startBlock = stopBlock ifTrue: [0] ifFalse: [1]). [sensor keyboardPressed and: [sensor keyboardPeek asciiValue = 8]] whileTrue: [ "process multiple backspaces" sensor keyboard. startIndex _ 1 max: startIndex - 1. ]. self backTo: startIndex] ifFalse: [sensor keyboard. characterStream skip: -1]. ^false! ! !ParagraphEditor methodsFor: 'typing/selecting keys' stamp: 'sma 12/15/1999 12:20'! forwardDelete: characterStream "Delete forward over the next character. Make Undo work on the whole type-in, not just the one char. wod 11/3/1998: If there was a selection use #zapSelectionWith: rather than #backspace: which was 'one off' in deleting the selection. Handling of things like undo or typeIn area were not fully considered." | startIndex usel upara uinterval ind stopIndex | startIndex _ startBlock stringIndex. startIndex > paragraph text size ifTrue: [sensor keyboard. ^ false]. startIndex = stopBlock stringIndex ifFalse: ["there was a selection" sensor keyboard. self zapSelectionWith: self nullText. ^ false]. "Null selection - do the delete forward" beginTypeInBlock == nil "no previous typing. openTypeIn" ifTrue: [self openTypeIn. UndoSelection _ self nullText]. uinterval _ UndoInterval deepCopy. "umes _ UndoMessage deepCopy. Set already by openTypeIn" "usel _ UndoSelection deepCopy." upara _ UndoParagraph deepCopy. stopIndex := startIndex. (sensor keyboard asciiValue = 127 and: [sensor leftShiftDown]) ifTrue: [stopIndex := (self nextWord: stopIndex) - 1]. self selectFrom: startIndex to: stopIndex. self replaceSelectionWith: self nullText. self selectFrom: startIndex to: startIndex-1. UndoParagraph _ upara. UndoInterval _ uinterval. UndoMessage selector == #noUndoer ifTrue: [ (UndoSelection isText) ifTrue: [ usel _ UndoSelection. ind _ startIndex. "UndoInterval startIndex" usel replaceFrom: usel size + 1 to: usel size with: (UndoParagraph text copyFrom: ind to: ind). UndoParagraph text replaceFrom: ind to: ind with: self nullText]]. ^false! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:43'! backTo: startIndex "During typing, backspace to startIndex. Deleted characters fall into three clusters, from left to right in the text: (1) preexisting characters that were backed over; (2) newly typed characters that were backed over (excluding typeahead, which never even appears); (3) preexisting characters that were highlighted before typing began. If typing has not yet been opened, open it and watch for the first and third cluster. If typing has been opened, watch for the first and second cluster. Save characters from the first and third cluster in UndoSelection. Tally characters from the first cluster in UndoMessage's parameter. Delete all the clusters. Do not alter Undoer or UndoInterval (except via openTypeIn). The code is shorter than the comment." | saveLimit newBackovers | saveLimit _ beginTypeInBlock == nil ifTrue: [self openTypeIn. UndoSelection _ self nullText. stopBlock stringIndex] ifFalse: [self startOfTyping]. startBlock _ paragraph characterBlockForIndex: startIndex. startIndex < saveLimit ifTrue: [newBackovers _ self startOfTyping - startIndex. beginTypeInBlock _ startBlock stringIndex. UndoSelection replaceFrom: 1 to: 0 with: (paragraph text copyFrom: startIndex to: saveLimit - 1). UndoMessage argument: (UndoMessage argument ifNil: [1]) + newBackovers]. self zapSelectionWith: self nullText. startBlock _ stopBlock copy! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:31'! closeTypeIn "See comment in openTypeIn. It is important to call closeTypeIn before executing any non-typing key, making a new selection, etc. It is called automatically for menu commands. Typing commands can call 'closeTypeIn: aCharacterStream' instead of this to save typeahead. Undoer & Redoer: undoAndReselect:redoAndReselect:." | begin start stop | beginTypeInBlock == nil ifFalse: [(UndoMessage sends: #noUndoer) ifTrue: "should always be true, but just in case..." [begin _ self startOfTyping. start _ startBlock stringIndex. stop _ stopBlock stringIndex. self undoer: #undoAndReselect:redoAndReselect: with: (begin + UndoMessage argument to: begin + UndoSelection size - 1) with: (stop to: stop - 1). UndoInterval _ begin to: stop - 1]. beginTypeInBlock _ nil]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'sma 12/15/1999 13:21'! dispatchOnCharacter: char with: typeAheadStream "Carry out the action associated with this character, if any. Type-ahead is passed so some routines can flush or use it." | honorCommandKeys | ((honorCommandKeys _ Preferences cmdKeysInText) and: [char = Character enter]) ifTrue: [^ self dispatchOnEnterWith: typeAheadStream]. "Special keys overwrite crtl+key combinations - at least on Windows. To resolve this conflict, assume that keys other than cursor keys aren't used together with Crtl." ((self class specialShiftCmdKeys includes: char asciiValue) and: [char asciiValue < 27]) ifTrue: [^ sensor controlKeyPressed ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]]. "backspace, and escape keys (ascii 8 and 27) are command keys" ((honorCommandKeys and: [sensor commandKeyPressed]) or: [self class specialShiftCmdKeys includes: char asciiValue]) ifTrue: [^ sensor leftShiftDown ifTrue: [self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream] ifFalse: [self perform: (CmdActions at: char asciiValue + 1) with: typeAheadStream]]. "the control key can be used to invoke shift-cmd shortcuts" (honorCommandKeys and: [sensor controlKeyPressed]) ifTrue: [^ self perform: (ShiftCmdActions at: char asciiValue + 1) with: typeAheadStream]. ^ self perform: #normalCharacter: with: typeAheadStream! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 9/7/1999 11:26'! dispatchOnEnterWith: typeAheadStream "Enter key hit. Treat is as an 'accept', viz a synonym for cmd-s. If cmd key is down, treat is as a synonym for print-it. " sensor keyboard. "consume enter key" self terminateAndInitializeAround: [ sensor commandKeyPressed ifTrue: [self printIt.] ifFalse: [self closeTypeIn: typeAheadStream. self accept]. ]. ^ true! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'! doneTyping beginTypeInBlock _ nil! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'sma 4/22/2000 17:21'! insertTypeAhead: typeAhead typeAhead position = 0 ifFalse: [self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). typeAhead reset. startBlock _ stopBlock copy]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:39'! openTypeIn "Set up UndoSelection to null text (to be added to by readKeyboard and backTo:), beginTypeInBlock to keep track of the leftmost backspace, and UndoParameter to tally how many deleted characters were backspaced over rather than 'cut'. You can't undo typing until after closeTypeIn." beginTypeInBlock == nil ifTrue: [UndoSelection _ self nullText. self undoer: #noUndoer with: 0. beginTypeInBlock _ startBlock stringIndex]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 6/14/1998 13:08'! readKeyboard "Key struck on the keyboard. Find out which one and, if special, carry out the associated special action. Otherwise, add the character to the stream of characters. Undoer & Redoer: see closeTypeIn." | typeAhead char | typeAhead _ WriteStream on: (String new: 128). [sensor keyboardPressed] whileTrue: [self deselect. [sensor keyboardPressed] whileTrue: [char _ sensor keyboardPeek. (self dispatchOnCharacter: char with: typeAhead) ifTrue: [self doneTyping. ^self selectAndScroll; updateMarker]. self openTypeIn]. startBlock = stopBlock ifFalse: "save highlighted characters" [UndoSelection _ self selection]. self zapSelectionWith: (Text string: typeAhead contents emphasis: emphasisHere). typeAhead reset. startBlock _ stopBlock copy. sensor keyboardPressed ifFalse: [self selectAndScroll. sensor keyboardPressed ifFalse: [self updateMarker]]]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'sw 12/7/1999 11:39'! setEmphasisHere emphasisHere _ (paragraph text attributesAt: (startBlock stringIndex-1 max: 1) forStyle: paragraph textStyle) select: [:att | att mayBeExtended]! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'sw 12/16/1998 13:14'! simulatedKeystroke: char "Accept char as if it were struck on the keyboard. This version does not yet deal with command keys, and achieves update in the receiver's typically inactive window via the sledge-hammer of uncache-bits." self deselect. self openTypeIn. startBlock = stopBlock ifFalse: [UndoSelection _ self selection]. self zapSelectionWith: (Text string: char asString emphasis: emphasisHere). self userHasEdited. startBlock _ stopBlock copy. self selectAndScroll. self updateMarker. view ifNotNil: [view topView uncacheBits "in mvc, this makes sure the recognized character shows up in the pane right now; in morphic, a different mechanism is used for the same effect -- see TextMorphEditor method #recognizeCharactersWhileMouseIn:"] ! ! !ParagraphEditor methodsFor: 'typing support' stamp: 'di 10/6/1998 08:45'! startOfTyping "Compatibility during change from characterBlock to integer" beginTypeInBlock == nil ifTrue: [^ nil]. beginTypeInBlock isNumber ifTrue: [^ beginTypeInBlock]. "Last line for compatibility during change from CharacterBlock to Integer." ^ beginTypeInBlock stringIndex ! ! !ParagraphEditor methodsFor: 'current selection' stamp: 'sbw 10/12/1999 16:51'! selectAndScrollToTop "Scroll until the selection is in the view and then highlight it." | lineHeight deltaY clippingRectangle | self select. lineHeight _ paragraph textStyle lineGrid. clippingRectangle _ paragraph clippingRectangle. deltaY _ stopBlock top - clippingRectangle top. deltaY ~= 0 ifTrue: [self scrollBy: (deltaY abs + lineHeight - 1 truncateTo: lineHeight) * deltaY sign]! ! !ParagraphEditor methodsFor: 'new selection' stamp: 'di 12/17/1998 09:41'! insertAndSelect: aString at: anInteger self replace: (anInteger to: anInteger - 1) with: (Text string: (' ' , aString) attributes: emphasisHere) and: [self selectAndScroll]! ! !ParagraphEditor methodsFor: 'private' stamp: 'sw 9/24/1999 15:41'! againOnce: indices "Find the next occurrence of FindText. If none, answer false. Append the start index of the occurrence to the stream indices, and, if ChangeText is not the same object as FindText, replace the occurrence by it. Note that the search is case-sensitive for replacements, otherwise not." | where | where _ paragraph text findString: FindText startingAt: stopBlock stringIndex caseSensitive: ((ChangeText ~~ FindText) or: [Preferences caseSensitiveFinds]). where = 0 ifTrue: [^ false]. self deselect; selectInvisiblyFrom: where to: where + FindText size - 1. ChangeText ~~ FindText ifTrue: [self zapSelectionWith: ChangeText]. indices nextPut: where. self selectAndScroll. ^ true! ! !ParagraphEditor methodsFor: 'private' stamp: 'rhi 4/27/2000 09:03'! getPluggableYellowButtonMenu: shiftKeyState | customMenu | ^(customMenu _ view getMenu: shiftKeyState) notNil ifTrue: [customMenu] ifFalse: [shiftKeyState ifTrue: [self class shiftedYellowButtonMenu] ifFalse: [self class yellowButtonMenu]]! ! !ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:32'! nextWord: position | string index | string _ paragraph text string. index _ position. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] whileTrue: [index _ index + 1]. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] whileTrue: [index _ index + 1]. ^ index! ! !ParagraphEditor methodsFor: 'private' stamp: 'sma 12/15/1999 11:33'! previousWord: position | string index | string _ paragraph text string. index _ position. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric not]] whileTrue: [index _ index - 1]. [(index between: 1 and: string size) and: [(string at: index) isAlphaNumeric]] whileTrue: [index _ index - 1]. ^ index + 1! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'jm 11/23/2003 10:45'! evaluateSelection "Treat the current selection as an expression; evaluate it and return the result" | result rcvr ctxt | self lineSelectAndEmptyCheck: [^ '']. (model respondsTo: #doItReceiver) ifTrue: [FakeClassPool adopt: model selectedClass. "Include model pool vars if any" rcvr _ model doItReceiver. ctxt _ model doItContext] ifFalse: [rcvr _ ctxt _ nil]. result _ Compiler new evaluate: self selectionAsStream in: ctxt to: rcvr notifying: self ifFail: [FakeClassPool adopt: nil. ^ #failedDoit]. FakeClassPool adopt: nil. Smalltalk logChange: self selection string. ^ result! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'acg 12/7/1999 07:53'! exploreIt | result | result _ self evaluateSelection. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [view flash] ifFalse: [result explore]. ! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'di 9/7/1999 11:25'! inspectIt "1/13/96 sw: minor fixup" | result | result _ self evaluateSelection. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [view flash] ifFalse: [result inspect]. ! ! !ParagraphEditor methodsFor: 'do-its' stamp: 'di 9/7/1999 08:42'! objectsReferencingIt "Open a list inspector on all objects that reference the object that results when the current selection is evaluated. " | result | self terminateAndInitializeAround: [ result _ self evaluateSelection. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [view flash] ifFalse: [Smalltalk browseAllObjectReferencesTo: result except: #() ifNone: [:obj | view topView flash]]. ]! ! !ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:40'! totalTextHeight ^paragraph boundingBox height! ! !ParagraphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:33'! visibleHeight ^paragraph clippingRectangle height! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'di 4/17/1999 01:25'! initialize "Initialize the keyboard shortcut maps and the shared buffers for copying text across views and managing again and undo. Marked this method changed to trigger reinit" "ParagraphEditor initialize" CurrentSelection _ UndoSelection _ FindText _ ChangeText _ Text new. UndoMessage _ Message selector: #halt. self initializeCmdKeyShortcuts. self initializeShiftCmdKeyShortcuts. self initializeTextEditorMenus ! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'jm 9/25/2006 21:52'! initializeTextEditorMenus "ParagraphEditor initializeTextEditorMenus" "Initialize the yellow button pop-up menu and corresponding messages." TextEditorYellowButtonMenu _ SelectionMenu labels: 'find...(f) find again (g) set search string (e) do again (j) undo (z) copy (c) cut (x) paste (v) paste... do it (d) print it (p) inspect it (i) accept (s) cancel (l) show bytecodes more...' lines: #(3 5 9 12 14 15) selections: #(find findAgain setSearchString again undo copySelection cut paste pasteRecent doIt printIt inspectIt accept cancel showBytecodes shiftedYellowButtonActivity) ! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'jm 5/31/2003 15:56'! shiftedYellowButtonMenu "Answer the menu to be presented when the yellow button is pressed while the shift key is down." ^ SelectionMenu fromArray: #( ('set font... (k)' offerFontMenu) ('set style... (K)' changeStyle) ('set alignment...' chooseAlignment) - ('explain' explain) ('pretty print' prettyPrint) ('file it in' fileItIn) ('spawn (o)' spawn) - ('browse it (b)' browseIt) ('senders of it (n)' sendersOfIt) ('implementors of it (m)' implementorsOfIt) ('references to it (N)' referencesToIt) ('selectors containing it (W)' methodNamesContainingIt) ('method strings with it (E)' methodStringsContainingit) ('method source with it' methodSourceContainingIt) - ('save contents to file...' saveContentsInFile) - ('more...' yellowButtonActivity)) ! ! !ParagraphEditor class methodsFor: 'class initialization' stamp: 'di 4/17/1999 00:33'! yellowButtonMessages ^ TextEditorYellowButtonMenu selections! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'jm 9/25/2006 21:55'! initializeCmdKeyShortcuts "Initialize the (unshifted) command-key shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "ParagraphEditor initialize" | cmdMap cmds | cmdMap _ Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" cmdMap at: ( 8 + 1) put: #backspace:. "ctrl-H or delete key" cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" cmdMap at: (13 + 1) put: #crWithIndent:. "cmd-Return" cmdMap at: (27 + 1) put: #selectCurrentTypeIn:. "escape key" cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" cmdMap at: (32 + 1) put: #selectWord:. "space bar key" cmdMap at: (127 + 1) put: #forwardDelete:. "del key" '0123456789-=' do: [ :char | cmdMap at: (char asciiValue + 1) put: #changeEmphasis: ]. '([{''"<' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose: ]. cmdMap at: ($, asciiValue + 1) put: #shiftEnclose:. cmds _ #( $a selectAll: $b browseIt: $c copySelection: $d doIt: $e setSearchString: $f find: $g findAgain: $i inspectIt: $j doAgainOnce: $k offerFontMenu: $l cancel: $m implementorsOfIt: $n sendersOfIt: $o spawnIt: $p printIt: $q querySymbol: $s save: $u align: $v paste: $w backWord: $x cut: $y swapChars: $z undo: ). 1 to: cmds size by: 2 do: [ :i | cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). ]. CmdActions _ cmdMap ! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sma 2/26/2000 18:19'! initializeShiftCmdKeyShortcuts "Initialize the shift-command-key (or control-key) shortcut table." "NOTE: if you don't know what your keyboard generates, use Sensor kbdTest" "wod 11/3/1998: Fix setting of cmdMap for shifted keys to actually use the capitalized versions of the letters. TPR 2/18/99: add the plain ascii values back in for those VMs that don't return the shifted values." | cmdMap cmds | "shift-command and control shortcuts" cmdMap _ Array new: 256 withAll: #noop:. "use temp in case of a crash" cmdMap at: ( 1 + 1) put: #cursorHome:. "home key" cmdMap at: ( 4 + 1) put: #cursorEnd:. "end key" cmdMap at: ( 8 + 1) put: #forwardDelete:. "ctrl-H or delete key" cmdMap at: (11 + 1) put: #cursorPageUp:. "page up key" cmdMap at: (12 + 1) put: #cursorPageDown:. "page down key" cmdMap at: (13 + 1) put: #crWithIndent:. "ctrl-Return" cmdMap at: (27 + 1) put: #selectCurrentTypeIn:. "escape key" cmdMap at: (28 + 1) put: #cursorLeft:. "left arrow key" cmdMap at: (29 + 1) put: #cursorRight:. "right arrow key" cmdMap at: (30 + 1) put: #cursorUp:. "up arrow key" cmdMap at: (31 + 1) put: #cursorDown:. "down arrow key" cmdMap at: (32 + 1) put: #selectWord:. "space bar key" cmdMap at: (45 + 1) put: #changeEmphasis:. "cmd-sh-minus" cmdMap at: (61 + 1) put: #changeEmphasis:. "cmd-sh-plus" cmdMap at: (127 + 1) put: #forwardDelete:. "del key" "Note: Command key overrides shift key, so, for example, cmd-shift-9 produces $9 not $(" '9[,''' do: [ :char | cmdMap at: (char asciiValue + 1) put: #shiftEnclose: ]. "({< and double-quote" "Note: Must use cmd-9 or ctrl-9 to get '()' since cmd-shift-9 is a Mac FKey command." cmdMap at: (27 + 1) put: #shiftEnclose:. "ctrl-[" "'""''(' do: [ :char | cmdMap at: (char asciiValue + 1) put: #enclose:]." cmds _ #( $a argAdvance: $b browseItHere: $c compareToClipboard: $d duplicate: $e methodStringsContainingIt: $f displayIfFalse: $i exploreIt: $j doAgainMany: $k changeStyle: $n referencesToIt: $r indent: $l outdent: $s search: $t displayIfTrue: $u changeLfToCr: $v pasteInitials: $w methodNamesContainingIt: $x makeLowercase: $y makeUppercase: $z makeCapitalized: ). 1 to: cmds size by: 2 do: [ :i | cmdMap at: ((cmds at: i) asciiValue + 1) put: (cmds at: i + 1). "plain keys" cmdMap at: ((cmds at: i) asciiValue - 32 + 1) put: (cmds at: i + 1). "shifted keys" cmdMap at: ((cmds at: i) asciiValue - 96 + 1) put: (cmds at: i + 1). "ctrl keys" ]. ShiftCmdActions _ cmdMap! ! !ParagraphEditor class methodsFor: 'keyboard shortcut tables' stamp: 'sbw 10/8/1999 21:42'! specialShiftCmdKeys "Private - return array of key codes that represent single keys acting as if shift-command were also being pressed" ^#( 1 "home" 3 "enter" 4 "end" 8 "backspace" 11 "page up" 12 "page down" 27 "escape" 28 "left arrow" 29 "right arrow" 30 "up arrow" 31 "down arrow" 127 "delete" )! ! !ParagraphEditor class methodsFor: 'clipboard access' stamp: 'di 4/26/2000 21:55'! chooseRecentClipping "ParagraphEditor chooseRecentClipping" "Choose by menu from among the recent clippings" RecentClippings ifNil: [^ nil]. ^ (SelectionMenu labelList: (RecentClippings collect: [:txt | ((txt asString contractTo: 50) copyReplaceAll: Character cr asString with: '\') copyReplaceAll: Character tab asString with: '|']) selections: RecentClippings) startUp. ! ! !ParagraphEditor class methodsFor: 'clipboard access' stamp: 'di 4/28/1999 11:30'! clipboardText "Return the text currently in the clipboard. If the system clipboard is empty, or if it differs from the Smalltalk clipboard text, use the Smalltalk clipboard. This is done since (a) the Mac clipboard gives up on very large chunks of text and (b) since not all platforms support the notion of a clipboard." | s | s _ Smalltalk clipboardText. (s isEmpty or: [s = CurrentSelection string]) ifTrue: [^ CurrentSelection] ifFalse: [^ s asText]! ! !ParagraphEditor class methodsFor: 'clipboard access' stamp: 'di 4/26/2000 20:54'! clipboardTextPut: text "Set text currently on the clipboard. Also export to Mac" CurrentSelection _ text. self noteRecentClipping: text. Smalltalk clipboardText: CurrentSelection string! ! !ParagraphEditor class methodsFor: 'clipboard access' stamp: 'di 4/26/2000 22:29'! noteRecentClipping: text "Keep most recent clippings in a queue for pasteRecent (paste... command)" text isEmpty ifTrue: [^ self]. text size > 50000 ifTrue: [^ self]. RecentClippings ifNil: [RecentClippings _ OrderedCollection new]. (RecentClippings includes: text) ifTrue: [^ self]. RecentClippings addFirst: text. [RecentClippings size > 5] whileTrue: [RecentClippings removeLast]. ! ! This superclass of most compiler/decompiler classes declares common class variables, default messages, and the code emitters for jumps. Some of the class variables are initialized here; the rest are initialized in class VariableNode.! !ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'! isSelfPseudoVariable "Overridden in VariableNode." ^false! ! !ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'! isTemp ^ false! ! !ParseNode methodsFor: 'printing' stamp: 'sw 11/15/1999 22:23'! printCommentOn: aStream indent: indent | thisComment | comment == nil ifTrue: [^ self]. aStream withAttributes: (Preferences syntaxAttributesFor: #comment) do: [1 to: comment size do: [:index | index > 1 ifTrue: [aStream crtab: indent]. aStream nextPut: $". thisComment _ comment at: index. self printSingleComment: thisComment on: aStream indent: indent. aStream nextPut: $"]]. comment _ nil! ! !ParseNode methodsFor: 'private' stamp: 'sma 5/28/2000 10:47'! nextWordFrom: aStream setCharacter: aBlock | outStream char | outStream _ WriteStream on: (String new: 16). [(aStream peekFor: Character space) or: [aStream peekFor: Character tab]] whileTrue. [aStream atEnd or: [char _ aStream next. char = Character cr or: [char = Character space]]] whileFalse: [outStream nextPut: char]. aBlock value: char. ^ outStream contents! ! !ParseNode methodsFor: 'private' stamp: 'sma 5/28/2000 10:45'! printSingleComment: aString on: aStream indent: indent "Print the comment string, assuming it has been indented indent tabs. Break the string at word breaks, given the widths in the default font, at 450 points." | readStream word position lineBreak font wordWidth tabWidth spaceWidth lastChar | readStream _ ReadStream on: aString. font _ TextStyle default defaultFont. tabWidth _ TextConstants at: #DefaultTab. spaceWidth _ font widthOf: Character space. position _ indent * tabWidth. lineBreak _ 450. [readStream atEnd] whileFalse: [word _ self nextWordFrom: readStream setCharacter: [:lc | lastChar _ lc]. wordWidth _ word inject: 0 into: [:width :char | width + (font widthOf: char)]. position _ position + wordWidth. position > lineBreak ifTrue: [aStream crtab: indent. position _ indent * tabWidth + wordWidth + spaceWidth. lastChar = Character cr ifTrue: [[readStream peekFor: Character tab] whileTrue]. word isEmpty ifFalse: [aStream nextPutAll: word; space]] ifFalse: [aStream nextPutAll: word. readStream atEnd ifFalse: [position _ position + spaceWidth. aStream space]. lastChar = Character cr ifTrue: [aStream crtab: indent. position _ indent * tabWidth. [readStream peekFor: Character tab] whileTrue]]]! ! I keep track of the current and high position of the stack that will be needed by code being compiled.! I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.! !Parser methodsFor: 'public access' stamp: 'jm 5/23/2003 11:31'! parse: sourceStream class: class noPattern: noPattern context: ctxt notifying: req ifFail: aBlock "Answer a MethodNode for the argument, sourceStream, that is the root of a parse tree. Parsing is done with respect to the argument, class, to find instance, class, and pool variables; and with respect to the argument, ctxt, to find temporary variables. Errors in parsing are reported to the argument, req, if not nil; otherwise aBlock is evaluated. The argument noPattern is a Boolean that is true if the the sourceStream does not contain a method header (i.e., for DoIts)." | meth | self init: sourceStream notifying: req failBlock: [^aBlock value]. doitFlag _ noPattern. encoder _ Encoder new init: class context: ctxt notifying: self. failBlock _ aBlock. meth _ self method: noPattern context: ctxt. encoder _ failBlock _ requestor _ parseNode _ nil. "break cycles & mitigate refct overflow" ^ meth ! ! !Parser methodsFor: 'public access' stamp: 'tk 2/4/2000 18:39'! parseArgsAndTemps: aString notifying: req "Parse the argument, aString, notifying req if an error occurs. Otherwise, answer a two-element Array containing Arrays of strings (the argument names and temporary variable names)." aString == nil ifTrue: [^#()]. doitFlag _ false. "Don't really know if a doit or not!!" ^self initPattern: aString notifying: req return: [:pattern | (pattern at: 2) , self temporaries]! ! !Parser methodsFor: 'expression types' stamp: 'sma 2/27/2000 22:38'! blockExpression "[ ({:var} |) (| {temps} |) (statements) ] => BlockNode." | variableNodes temporaryBlockVariables | variableNodes _ OrderedCollection new. "Gather parameters." [self match: #colon] whileTrue: [variableNodes addLast: (encoder autoBind: self argumentName)]. (variableNodes size > 0 & (hereType ~~ #rightBracket) and: [(self match: #verticalBar) not]) ifTrue: [^self expected: 'Vertical bar']. temporaryBlockVariables _ self temporaryBlockVariables. self statements: variableNodes innerBlock: true. parseNode temporaries: temporaryBlockVariables. (self match: #rightBracket) ifFalse: [^self expected: 'Period or right bracket']. "The scope of the parameters and temporary block variables is no longer active." temporaryBlockVariables do: [:variable | variable scope: -1]. variableNodes do: [:variable | variable scope: -1]! ! !Parser methodsFor: 'expression types' stamp: 'di 3/8/2000 09:36'! braceExpression " { elements } => BraceNode." | elements locations loc more | elements _ OrderedCollection new. locations _ OrderedCollection new. self advance. more _ hereType ~~ #rightBrace. [more] whileTrue: [loc _ hereMark + requestorOffset. self expression ifTrue: [elements addLast: parseNode. locations addLast: loc] ifFalse: [^self expected: 'Variable or expression']. (self match: #period) ifTrue: [more _ hereType ~~ #rightBrace] ifFalse: [more _ false]]. parseNode _ BraceNode new elements: elements sourceLocations: locations. (self match: #rightBrace) ifFalse: [^self expected: 'Period or right brace']. ^true! ! !Parser methodsFor: 'expression types' stamp: 'di 11/19/1999 07:43'! expression (hereType == #word and: [tokenType == #leftArrow]) ifTrue: [^ self assignment: self variable]. hereType == #leftBrace ifTrue: [self braceExpression] ifFalse: [self primaryExpression ifFalse: [^ false]]. (self messagePart: 3 repeat: true) ifTrue: [hereType == #semicolon ifTrue: [self cascade]]. ^ true! ! !Parser methodsFor: 'expression types' stamp: 'sma 2/10/2000 23:29'! pattern: fromDoit inContext: ctxt " unarySelector | binarySelector arg | keyword arg {keyword arg} => {selector, arguments, precedence}." | args selector | doitFlag _ fromDoit. fromDoit ifTrue: [ctxt == nil ifTrue: [^Array with: #DoIt with: #() with: 1] ifFalse: [^Array with: #DoItIn: with: (Array with: (encoder encodeVariable: 'homeContext')) with: 3]]. hereType == #word ifTrue: [^Array with: self advance asSymbol with: #() with: 1]. (hereType == #binary or: [hereType == #verticalBar]) ifTrue: [selector _ self advance asSymbol. args _ Array with: (encoder bindArg: self argumentName). ^Array with: selector with: args with: 2]. hereType == #keyword ifTrue: [selector _ WriteStream on: (String new: 32). args _ OrderedCollection new. [hereType == #keyword] whileTrue: [selector nextPutAll: self advance. args addLast: (encoder bindArg: self argumentName)]. ^Array with: selector contents asSymbol with: args with: 3]. ^self expected: 'Message pattern'! ! !Parser methodsFor: 'expression types' stamp: 'tk 1/3/2000 13:56'! temporaries " [ '|' (variable)* '|' ]" | vars theActualText | (self match: #verticalBar) ifFalse: ["no temps" doitFlag ifTrue: [requestor ifNil: [tempsMark _ 1] ifNotNil: [tempsMark _ requestor selectionInterval first]. ^ #()]. tempsMark _ prevMark + prevToken. tempsMark > 0 ifTrue: [theActualText _ source contents. [tempsMark < theActualText size and: [(theActualText at: tempsMark) isSeparator]] whileTrue: [tempsMark _ tempsMark + 1]]. ^ #()]. vars _ OrderedCollection new. [hereType == #word] whileTrue: [vars addLast: (encoder bindTemp: self advance)]. (self match: #verticalBar) ifTrue: [tempsMark _ prevMark. ^ vars]. ^ self expected: 'Vertical bar'! ! !Parser methodsFor: 'expression types' stamp: 'crl 2/26/1999 12:22'! temporaryBlockVariables "Scan and answer temporary block variables." | variables | (self match: #verticalBar) ifFalse: [ "There are't any temporary variables." ^#()]. variables _ OrderedCollection new. [hereType == #word] whileTrue: [variables addLast: (encoder bindBlockTemp: self advance)]. (self match: #verticalBar) ifTrue: [^variables]. ^self expected: 'Vertical bar'! ! !Parser methodsFor: 'expression types' stamp: 'di 12/4/1999 21:04'! variable | varName varStart varEnd | varStart _ self startOfNextToken + requestorOffset. varName _ self advance. varEnd _ self endOfLastToken + requestorOffset. ^ encoder encodeVariable: varName sourceRange: (varStart to: varEnd) ifUnknown: [self correctVariable: varName interval: (varStart to: varEnd)]! ! !Parser methodsFor: 'scanning' stamp: 'sn 9/19/97 19:32'! advance | this | prevMark _ hereMark. prevToken _ "Now means prev size" self previousTokenSize. this _ here. here _ token. hereType _ tokenType. hereMark _ mark. self scanToken. ^this! ! !Parser methodsFor: 'error handling'! notify: string at: location requestor isNil ifTrue: [(encoder == self or: [encoder isNil]) ifTrue: [^ self fail "failure setting up syntax error"]. SyntaxError errorInClass: encoder classEncoding withCode: (source contents copyReplaceFrom: location to: location - 1 with: string , ' ->') doitFlag: doitFlag] ifFalse: [requestor notify: string , ' ->' at: location in: source]. ^self fail! ! !Parser methodsFor: 'error handling' stamp: 'di 2/9/1999 15:43'! offEnd: aString "Notify a problem beyond 'here' (in lookAhead token). Don't be offEnded!!" requestorOffset == nil ifTrue: [^ self notify: aString at: mark] ifFalse: [^ self notify: aString at: mark + requestorOffset] ! ! !Parser methodsFor: 'error correction' stamp: 'tk 8/11/1998 21:52'! correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction fullSearch: tryHard "Correct the proposedKeyword to some selector symbol, correcting the original text if such action is indicated. abortAction is invoked if the proposedKeyword couldn't be converted into a valid selector. Spots is an ordered collection of intervals within the test stream of the for each of the keyword parts." | alternatives aStream choice correctSelector userSelection lines firstLine | "If we can't ask the user, assume that the keyword will be defined later" self interactive ifFalse: [ ^ proposedKeyword asSymbol ]. userSelection _ requestor selectionInterval. requestor selectFrom: spots first first to: spots last last. requestor select. alternatives _ tryHard ifFalse: [ Symbol possibleSelectorsFor: proposedKeyword ] ifTrue: [ Symbol morePossibleSelectorsFor: proposedKeyword ]. aStream _ WriteStream on: (String new: 200). aStream nextPutAll: (proposedKeyword contractTo: 35); cr. firstLine _ 1. alternatives do: [:sel | aStream nextPutAll: (sel contractTo: 35); nextPut: Character cr]. aStream nextPutAll: 'cancel'. lines _ Array with: firstLine with: (alternatives size + firstLine). tryHard ifFalse: [aStream cr; nextPutAll: 'try harder'. lines _ lines copyWith: (alternatives size + firstLine + 1)]. choice _ (PopUpMenu labels: aStream contents lines: lines) startUpWithCaption: 'Unknown selector, please confirm, correct, or cancel'. tryHard not & (choice > lines last) ifTrue: [^ self correctSelector: proposedKeyword wordIntervals: spots exprInterval: expInt ifAbort: abortAction fullSearch: true ]. (choice = 0) | (choice > (lines at: 2)) ifTrue: [ ^ abortAction value ]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. choice = 1 ifTrue: [ ^ proposedKeyword asSymbol ]. correctSelector _ alternatives at: choice - 1. self substituteSelector: correctSelector keywords wordIntervals: spots. ((proposedKeyword last ~~ $:) and: [correctSelector last == $:]) ifTrue: [ ^ abortAction value]. ^ correctSelector. ! ! !Parser methodsFor: 'error correction' stamp: 'sw 11/10/1999 13:26'! correctVariable: proposedVariable interval: spot "Correct the proposedVariable to a known variable, or declare it as a new variable if such action is requested. We support declaring lowercase variables as temps, and uppercase variables as Globals or ClassVars, depending on whether the context is nil (class=UndefinedObject). Spot is the interval within the test stream of the variable." | alternatives aStream choice userSelection temp binding globalToo | "If we can't ask the user for correction, make it undeclared" self interactive ifFalse: [^ encoder undeclared: proposedVariable]. temp _ proposedVariable first isLowercase. "First check to see if the requestor knows anything about the variable" (temp and: [(binding _ requestor bindingOf: proposedVariable) notNil]) ifTrue: [^ encoder global: binding name: proposedVariable]. userSelection _ requestor selectionInterval. requestor selectFrom: spot first to: spot last. requestor select. alternatives _ encoder possibleVariablesFor: proposedVariable. aStream _ WriteStream on: (String new: 200). globalToo _ 0. aStream nextPutAll: 'declare ' , (temp ifTrue: ['temp'] ifFalse: [encoder classEncoding == UndefinedObject ifTrue: ['Global'] ifFalse: [globalToo _ 1. 'Class Variable']]); cr. globalToo = 1 ifTrue: [aStream nextPutAll: 'declare Global'; cr]. alternatives do: [:sel | aStream nextPutAll: sel; cr]. aStream nextPutAll: 'cancel'. choice _ (PopUpMenu labels: aStream contents lines: (Array with: (globalToo + 1) with: (globalToo + alternatives size + 1))) startUpWithCaption: (('Unknown variable: ', proposedVariable, ' please correct, or cancel:') asText makeBoldFrom: 19 to: 19 + proposedVariable size). (choice = 0) | (choice > (globalToo + alternatives size + 1)) ifTrue: [^ self fail]. requestor deselect. requestor selectInvisiblyFrom: userSelection first to: userSelection last. choice =1 ifTrue: [temp ifTrue: [^ self declareTempAndPaste: proposedVariable] ifFalse: [encoder classEncoding == UndefinedObject ifTrue: [^ self declareGlobal: proposedVariable] ifFalse: [^ self declareClassVar: proposedVariable]]]. (choice = 2) & (globalToo = 1) ifTrue: [^ self declareGlobal: proposedVariable]. "Spelling correction" self substituteWord: (alternatives at: choice-1-globalToo) wordInterval: spot offset: 0. ^ encoder encodeVariable: (alternatives at: choice-1-globalToo)! ! !Parser methodsFor: 'error correction' stamp: 'di 10/12/1999 15:17'! declareTempAndPaste: name | insertion tabbed | (requestor text string at: tempsMark) = $| ifTrue: "Paste it before the second vertical bar" [insertion _ name, ' '. (requestor text string at: tempsMark-1) isSeparator ifFalse: [ insertion _ ' ', insertion]. tempsMark _ tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0)] ifFalse: "No bars - insert some with CR, tab" [insertion _ '| ' , name , ' | '. tabbed _ tempsMark > 1 and: [(requestor text string at: tempsMark-1) = Character tab]. tabbed ifTrue: [insertion _ insertion , (String with: Character tab)]. tempsMark _ tempsMark + (self substituteWord: insertion wordInterval: (tempsMark to: tempsMark-1) offset: 0) - (tabbed ifTrue: [3] ifFalse: [2])]. ^ encoder bindAndJuggle: name! ! !Parser methodsFor: 'error correction' stamp: 'jm 5/23/2003 11:36'! removeUnusedTemps | str end start | str _ requestor text string. ((tempsMark between: 1 and: str size) and: [(str at: tempsMark) = $|]) ifFalse: [^ self]. encoder unusedTempNames do: [:temp | ((PopUpMenu labels: 'yes\no' withCRs) startUpWithCaption: ((temp , ' appears to be unused in this method. OK to remove it?') asText makeBoldFrom: 1 to: temp size)) = 1 ifTrue: [(encoder encodeVariable: temp) isUndefTemp ifTrue: [end _ tempsMark. ["Beginning at right temp marker..." start _ end - temp size + 1. end < temp size or: [temp = (str copyFrom: start to: end) and: [(str at: start-1) isSeparator & (str at: end+1) isSeparator]]] whileFalse: ["Search left for the unused temp" end _ requestor nextTokenFrom: end direction: -1]. end < temp size ifFalse: [(str at: start-1) = $ ifTrue: [start _ start-1]. requestor correctFrom: start to: end with: ''. str _ str copyReplaceFrom: start to: end with: ''. tempsMark _ tempsMark - (end-start+1)]] ifFalse: [PopUpMenu notify: 'You''ll first have to remove the statement where it''s stored into']]] ! ! !Parser methodsFor: 'private' stamp: 'di 3/29/1999 13:10'! previousTokenSize "Answer the size of the previous token. Bugfix for Strings." | hereSize | hereType == #number ifTrue: [^ mark - prevMark]. hereSize _ here ifNil: [0] ifNotNil: [here size]. hereType == #string ifTrue: [^ hereSize + 2]. "One for each single quote" ^ hereSize! ! !Parser methodsFor: 'primitives' stamp: 'jm 10/30/2002 19:28'! primitiveDeclarations | prim module | (self matchToken: 'primitive:') ifFalse: [^ self expected: 'primitive:']. prim _ here. (self match: #number) ifTrue: [^ prim]. "indexed primitives" (self match: #string) ifFalse: [^ self expected: 'Integer or String']. (self matchToken: 'module:') ifTrue: [ module _ here. (self match: #string) ifFalse: [^ self expected: 'String']. module _ module asSymbol]. encoder litIndex: (Array with: module with: prim asSymbol with: 0 with: 0). ^ 117 ! ! A morph whose submorphs comprise a paste-up of rectangular subparts which "show through". Facilities commonly needed on pages of graphical presentations and on simulation playfields, such as the painting of new objects, turtle trails, gradient fills, background paintings, parts-bin behavior, collision-detection, etc., are (or will be) provided. A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. Morph subclasses that have specialized menus (BookMorph) build them in the message addBookMenuItemsTo:hand:. A PasteUpMorph that is a world, builds its menu in HandMorph buildWorldMenu. This class is young and still under construction, and a number of its (many) instance variables are not yet fully deployed.! !PasteUpMorph methodsFor: 'initialization' stamp: 'jm 2/4/2003 13:30'! initialize super initialize. borderColor _ Color r: 0.861 g: 1.0 b: 0.722. color _ Color r: 0.8 g: 1.0 b: 0.6. bounds _ 0@0 corner: 50@40. cursor _ 1. padding _ 3. autoLineLayout _ false. self enableDragNDrop: true. ! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'jm 7/17/2003 23:05'! releaseCachedState super releaseCachedState. turtleTrailsForm ifNotNil: [turtleTrailsForm hibernate]. ! ! !PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'! isWorldMorph ^ worldState notNil! ! !PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'! world worldState == nil ifTrue: [^ super world]. ^ self! ! !PasteUpMorph methodsFor: 'cursor' stamp: 'di 7/27/1999 10:24'! cursor ^ cursor ! ! !PasteUpMorph methodsFor: 'cursor' stamp: 'jm 11/24/2002 18:47'! valueAtCursor: aMorph submorphs isEmpty ifTrue: [^ self]. cursor _ ((cursor truncated max: 1) min: submorphs size). self replaceSubmorph: self valueAtCursor by: aMorph. ! ! !PasteUpMorph methodsFor: 'display' stamp: 'ar 5/29/1999 05:03'! drawSubmorphsOn: aCanvas aCanvas clipBy: self innerBounds during:[:clippedCanvas| super drawSubmorphsOn: clippedCanvas].! ! !PasteUpMorph methodsFor: 'display' stamp: 'jm 11/24/2002 10:35'! pseudoDraw: aRectangle on: aCanvas | c | c _ aCanvas copyClipRect: aRectangle. color isTranslucent ifTrue: [c fillColor: Color black]. c fillRectangle: bounds color: color. turtleTrailsForm ifNotNil: [c paintImage: turtleTrailsForm at: 0@0]. ^ c ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jm 10/13/2002 19:26'! acceptDroppingMorph: aMorph event: evt self isWorldMorph ifTrue: ["Add the given morph to this world and start stepping it if it wants to be." self addMorphFront: aMorph. (aMorph fullBounds intersects: ("0@0 extent:" self viewBox "extent")) ifFalse: [self beep. aMorph position: self bounds center]] ifFalse: [self privateAddMorph: aMorph atIndex: (self insertionIndexFor: aMorph). self changed. self layoutChanged]. aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]]. self autoLineLayout ifTrue: [self fixLayout]. self isPartsBin ifTrue: [aMorph isPartsDonor: true. aMorph allMorphsDo: [:m | m stopStepping]] ifFalse: [self world startSteppingSubmorphsOf: aMorph]. ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:48'! allowSubmorphExtraction ^self dragNDropEnabled and: [isPartsBin ~~ true] ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'sw 5/17/2000 12:05'! repelsMorph: aMorph event: ev aMorph willingToBeEmbeddedUponLanding ifFalse: [^ false]. self dragNDropEnabled ifFalse: [^ true]. (self wantsDroppedMorph: aMorph event: ev) ifFalse: [^ true]. ^ super repelsMorph: aMorph event: ev "consults #repelling flag"! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jm 10/15/2002 17:22'! rootForGrabOf: aMorph "If open to drag-n-drop, allow submorph to be extracted. If parts bin, copy the submorph." | root | root _ aMorph. [root = self] whileFalse: [ root owner == self ifTrue: [ self isPartsBin ifTrue: [ (root isKindOf: MorphThumbnail) ifTrue: [ ^ root morphRepresented fullCopy position: root position] ifFalse: [ ^ root fullCopy]]. self dragNDropEnabled ifTrue: [^ root]]. root _ root owner]. ^ super rootForGrabOf: aMorph ! ! !PasteUpMorph methodsFor: 'dropping/grabbing' stamp: 'jm 10/13/2002 18:23'! wantsDroppedMorph: aMorph event: evt aMorph willingToBeEmbeddedUponLanding ifFalse: [^ false]. self isHidden ifTrue: [^ false]. self dragNDropEnabled ifFalse: [^ false]. (self bounds containsPoint: (self pointFromWorld: evt cursorPoint)) ifFalse: [^ false]. ^ true ! ! !PasteUpMorph methodsFor: 'layout' stamp: 'sw 3/24/1999 14:11'! addCenteredAtBottom: aMorph offset: anOffset "Add aMorph beneath all other morphs currently in the receiver, centered horizontally, with the vertical offset from the bottom of the previous morph given by anOffset" | curBot | curBot _ 0. submorphs do: [:m | curBot _ curBot max: m bottom]. self addMorphBack: aMorph. aMorph position: ((self center x - (aMorph width // 2)) @ (curBot + anOffset))! ! !PasteUpMorph methodsFor: 'layout' stamp: 'sw 6/4/2000 23:58'! fixLayout "Pack my submorphs into rows that fit within my width, if autoLineLayout is true." | nextY i morphsForThisRow | self invalidRect: bounds. self autoLineLayout ifTrue: [nextY _ bounds top + borderWidth. i _ 1. [i <= submorphs size] whileTrue: [morphsForThisRow _ self rowMorphsStartingAt: i. nextY _ self layoutRow: morphsForThisRow lastRowBase: nextY. i _ i + morphsForThisRow size]] ! ! !PasteUpMorph methodsFor: 'layout' stamp: 'sw 8/3/1998 13:43'! laySubpartsOutInOneRow | aPosition | aPosition _ 0 @ padding. submorphs do: [:aMorph | aMorph position: (aPosition + (padding @ 0)). aPosition _ aMorph topRight]! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'jm 7/20/2003 20:39'! addCustomMenuItems: menu hand: aHandMorph super addCustomMenuItems: menu hand: aHandMorph. menu add: 'clear pen trails' action: #clearTurtleTrails. menu add: 'playfield options...' target: self action: #presentPlayfieldMenu. ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/11/1999 16:58'! autoLineLayoutString ^ self autoLineLayout ifTrue: ['stop doing auto-line-layout'] ifFalse: ['start doing auto-line-layout'] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 1/10/2000 16:44'! defersHaloOnClickTo: aSubMorph "If a cmd-click on aSubMorph would make it a preferred recipient of the halo, answer true" ^ true ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/11/1999 16:54'! indicateCursorString ^ self indicateCursor ifTrue: ['stop indicating cursor'] ifFalse: ['start indicating cursor'] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'jm 2/4/2003 13:36'! isOpenForDragNDropString ^ self dragNDropEnabled ifTrue: ['stop being open to drag & drop'] ifFalse: ['start being open to drag & drop']. ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/11/1999 16:55'! isPartsBinString ^ self isPartsBin ifTrue: ['stop being a parts bin'] ifFalse: ['start being a parts bin'] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/11/1999 15:05'! mouseOverHalosString ^ self wantsMouseOverHalos ifTrue: ['stop using mouse-over halos'] ifFalse: ['start using mouse-over halos'] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'jm 6/15/2003 12:24'! playfieldOptionsMenu | aMenu isWorld | isWorld _ self isWorldMorph. aMenu _ MenuMorph new defaultTarget: self. aMenu addStayUpItem. #( (autoLineLayoutString toggleAutoLineLayout 'whether submorphs should automatically be laid out in lines') (indicateCursorString toggleIndicateCursor 'whether the "current" submorph should be indicated with a dark black border') (isPartsBinString toggleIsPartsBin 'whether dragging an object from the interior should produce a COPY of the object') (isOpenForDragNDropString toggleDragNDrop 'whether objects can be dropped into and dragged out of me') (mouseOverHalosString toggleMouseOverHalos 'whether objects should put up halos when the mouse is over them') (showThumbnailString toggleAlwaysShowThumbnail 'whether large objects should be represented by thumbnail miniatures of themselves')) do: [:triplet | (isWorld and: [#(toggleAutoLineLayout toggleIndicateCursor toggleIsPartsBin toggleAlwaysShowThumbnail) includes: triplet second]) ifFalse: [aMenu addUpdating: triplet first action: triplet second. aMenu balloonTextForLastItem: triplet third]]. isWorld ifFalse: [aMenu add: 'set thumbnail height...' action: #setThumbnailHeight. aMenu balloonTextForLastItem: 'if currently showing thumbnails governs the standard height for them']. aMenu balloonTextForLastItem: 'governs whether, when an object is touched inside me, a viewer should automatically be launched for it.'. isWorld ifFalse: [aMenu add: 'behave like a Holder' action: #becomeLikeAHolder. aMenu balloonTextForLastItem: 'Set properties to make this object nicely set up to hold frames of a scripted animation.']. aMenu addTitle: 'playfield options...'. ^ aMenu ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'jm 5/31/2003 16:31'! presentPlayfieldMenu self playfieldOptionsMenu popUpForHand: self activeHand. ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 12/30/1999 19:51'! seeksOutHalo "Answer whether the receiver is an eager recipient of the halo" ^ false! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 6/11/1999 16:56'! showThumbnailString ^( self hasProperty: #alwaysShowThumbnail) ifTrue: ['stop showing thumbnails'] ifFalse: ['start showing thumbnails'] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'jm 10/13/2002 18:23'! wantsHaloFor: aSubMorph "Answer whether the receiver wishes for a mouse-over halo to be produced for aSubMorph" ^ wantsMouseOverHalos == true and: [self isHidden not and: [isPartsBin ~~ true and: [self dragNDropEnabled and: [self isWorldMorph not]]]] ! ! !PasteUpMorph methodsFor: 'menu & halo' stamp: 'sw 1/25/2000 17:44'! wantsHaloFromClick ^ (owner isKindOf: SystemWindow) not! ! !PasteUpMorph methodsFor: 'model' stamp: 'jm 3/13/2003 17:04'! model "Return nil. Models are being eliminated from PasteUpMorph." ^ nil ! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 14:06'! becomeLikeAHolder (self autoLineLayout and: [self indicateCursor]) ifTrue: [^ self inform: 'This view is ALREADY behaving like a holder, which is to say, it is set to indicate the cursor and to have auto-line-layout.']. self behaveLikeHolder ! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 14:06'! behaveLikeHolder self resizeToFit: true; autoLineLayout: true; indicateCursor: true; fixLayout; layoutChanged ! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/3/2000 01:08'! resizeToFit "Answer whether the receiver exhibits the #resizeToFit property. Formerly of greater use, this is an obscure backwater not meriting much attention. For most practical purposes, this is just always false. The feature doesn't quite work right even where used, e.g. in the Tabs sorter" ^ resizeToFit ifNil: [resizeToFit _ false]! ! !PasteUpMorph methodsFor: 'options' stamp: 'jm 2/4/2003 13:32'! setPartsBinStatusTo: aBoolean isPartsBin _ aBoolean. isPartsBin ifTrue: [ self enableDragNDrop: true. submorphs do: [:m | m stopStepping; isPartsDonor: true]] ifFalse: [ submorphs do: [:m | m isPartsDonor: false]. self world ifNotNil: [self world startSteppingSubmorphsOf: self]]. ! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 11:05'! setThumbnailHeight | reply | (self hasProperty: #alwaysShowThumbnail) ifFalse: [^ self inform: 'setting the thumbnail height is only applicable when you are currently showing thumbnails.']. reply _ FillInTheBlank request: 'New height for thumbnails? ' initialAnswer: self heightForThumbnails printString. reply isEmpty ifTrue: [^ self]. reply _ reply asNumber. (reply > 0 and: [reply <= 150]) ifFalse: [^ self inform: 'Please be reasonable!!']. self setProperty: #heightForThumbnails toValue: reply. self updateSubmorphThumbnails! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 7/6/1998 16:26'! toggleAlwaysShowThumbnail (self hasProperty: #alwaysShowThumbnail) ifTrue: [self removeProperty: #alwaysShowThumbnail] ifFalse: [self setProperty: #alwaysShowThumbnail toValue: true]. self updateSubmorphThumbnails! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/16/1999 09:06'! toggleIndicateCursor indicateCursor _ self indicateCursor not. self fixLayout. self layoutChanged. self changed.! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 9/30/1998 17:24'! toggleIsPartsBin "Not entirely happy with the openToDragNDrop not being directly manipulable etc, but still living with it for now." self setPartsBinStatusTo: self isPartsBin not! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 1/27/2000 14:51'! toggleMouseOverHalos wantsMouseOverHalos _ self wantsMouseOverHalos not! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 11/13/1998 09:56'! updateSubmorphThumbnails | thumbsUp itsThumbnail heightForThumbnails maxHeightToAvoidThumbnailing maxWidthForThumbnails | thumbsUp _ self alwaysShowThumbnail. heightForThumbnails _ self heightForThumbnails. maxHeightToAvoidThumbnailing _ self maxHeightToAvoidThumbnailing. maxWidthForThumbnails _ self maximumThumbnailWidth. self submorphs do: [:aMorph | thumbsUp ifTrue: [itsThumbnail _ aMorph representativeNoTallerThan: maxHeightToAvoidThumbnailing norWiderThan: maxWidthForThumbnails thumbnailHeight: heightForThumbnails. (aMorph == itsThumbnail) ifFalse: [self replaceSubmorph: aMorph by: itsThumbnail]] ifFalse: [(aMorph isKindOf: MorphThumbnail) ifTrue: [self replaceSubmorph: aMorph by: aMorph morphRepresented]]]! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'! wantsMouseOverHalos ^ wantsMouseOverHalos == true! ! !PasteUpMorph methodsFor: 'options' stamp: 'sw 6/5/1998 18:13'! wantsMouseOverHalos: aBoolean wantsMouseOverHalos _ aBoolean! ! !PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/22/1998 12:26'! paintingBoundsAround: aPoint "Return a rectangle for painting centered on the given point. Both the argument point and the result rectangle are in world coordinates." | paintExtent maxPaintArea myBnds | paintExtent _ self reasonablePaintingExtent. maxPaintArea _ paintExtent x * paintExtent y. myBnds _ self boundsInWorld. (myBnds area <= maxPaintArea) ifTrue: [^ myBnds]. ^ (aPoint - (paintExtent // 2) extent: paintExtent) intersect: myBnds ! ! !PasteUpMorph methodsFor: 'painting' stamp: 'sw 9/29/1998 07:35'! reasonablePaintingExtent ^ Preferences unlimitedPaintArea ifTrue: [3000 @ 3000] ifFalse: [Preferences defaultPaintingExtent]! ! !PasteUpMorph methodsFor: 'pen' stamp: 'jm 7/17/2003 23:03'! clearTurtleTrails "Remove my turtle trails Form. It will be recreated if it is needed." turtleTrailsForm _ nil. self changed. ! ! !PasteUpMorph methodsFor: 'pen' stamp: 'jm 7/19/2003 14:52'! createOrResizeTrailsForm "If necessary, create a new turtleTrailsForm or resize the existing one to fill my bounds. On return, turtleTrailsForm will be an 8-bit Form of the correct size." | newForm | turtleTrailsForm ifNil: [ turtleTrailsForm _ Form extent: self extent depth: 8. ^ self]. turtleTrailsForm extent = self extent ifFalse: [ "resize trails Form to my current exent" newForm _ Form extent: self extent depth: 8. newForm copy: turtleTrailsForm boundingBox from: turtleTrailsForm to: 0@0 rule: Form paint. turtleTrailsForm _ newForm]. ! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 7/6/1998 14:19'! alwaysShowThumbnail ^ self hasProperty: #alwaysShowThumbnail! ! !PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'! cachedOrNewThumbnailFrom: newThumbnail "If I have a cached thumbnail, and it is of the desired extent, then ruturn it. Otherwise produce one in newThumbnail and return it (after caching). This code parallels what happens in page: to match resultant extent." | cachedThumbnail scale ext | scale _ newThumbnail height / self fullBounds height. ext _ (self fullBounds extent * scale) truncated. (cachedThumbnail _ self valueOfProperty: #cachedThumbnail) ifNotNil: [cachedThumbnail extent = ext ifTrue: [^ cachedThumbnail]]. self setProperty: #cachedThumbnail toValue: (newThumbnail page: self). ^ newThumbnail! ! !PasteUpMorph methodsFor: 'misc' stamp: 'jm 11/15/2003 05:20'! drawInvalidAreasOn: aCanvas "Redraw the damaged areas of the given canvas and clear the damage list. Return a collection of the areas that were redrawn." | rectList c i n mm morphs rects rectToFill remnants rect | rectList _ self damageRecorder invalidRectsFullBounds: self viewBox. self damageRecorder reset. n _ self submorphs size. morphs _ OrderedCollection new: n*2. rects _ OrderedCollection new: n*2. rectList do: [:r | true ifTrue: ["Experimental top-down drawing -- Traverses top to bottom, stopping if the entire area is filled. If only a single rectangle remains, then continue with the reduced rectangle." rectToFill _ r. i _ 1. [rectToFill == nil or: [i > n]] whileFalse: [mm _ submorphs at: i. ((mm fullBounds intersects: r) and: [mm isHidden not]) ifTrue: [morphs addLast: mm. rects addLast: rectToFill. remnants _ mm areasRemainingToFill: rectToFill. remnants size = 1 ifTrue: [rectToFill _ remnants first]. remnants size = 0 ifTrue: [rectToFill _ nil]]. i _ i+1]. "Now paint from bottom to top, but using the reduced rectangles." rectToFill ifNotNil: [c _ self pseudoDraw: rectToFill on: aCanvas]. [morphs isEmpty] whileFalse: [(rect _ rects removeLast) == rectToFill ifFalse: [c _ aCanvas copyClipRect: (rectToFill _ rect)]. morphs removeLast fullDrawOn: c]. morphs reset. rects reset] ifFalse: [c _ self pseudoDraw: r on: aCanvas. submorphs reverseDo: [:m | m fullDrawOn: c]] ]. ^ rectList! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/5/2000 18:09'! fullBounds | result oldBounds | (fullBounds == nil and: [self autoLineLayout]) ifTrue: [oldBounds _ bounds. self fixLayout. self resizeToFit ifTrue: [result _ self boundingBoxOfSubmorphs. bounds _ bounds withBottom: result bottom]. fullBounds _ bounds. self invalidRect: oldBounds. self changed. ^ bounds]. "compute fullBounds before calling changed to avoid infinite recursion!!" ^ fullBounds _ bounds ! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'! heightForThumbnails ^ self valueOfProperty: #heightForThumbnails ifAbsent: [50]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'ar 3/14/2000 16:04'! invalidRect: damageRect "Clip damage reports to my bounds, since drawing is clipped to my bounds." self isWorldMorph ifTrue: [self damageRecorder ifNotNil: [self damageRecorder recordInvalidRect: damageRect]] ifFalse: [super invalidRect: (damageRect intersect: bounds)] ! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 10/8/1998 16:50'! maxHeightToAvoidThumbnailing ^ self valueOfProperty: #maxHeightToAvoidThumbnailing ifAbsent: [80]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 11/13/1998 10:06'! maximumThumbnailWidth ^ self valueOfProperty: #maximumThumbnailWidth ifAbsent: [200 min: (self width - 10)]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/3/2000 00:54'! morphsAt: aPoint addTo: mList "Overridden to exclude spurious hits on extralimital submorphs." (self containsPoint: aPoint) ifTrue: [submorphs size > 0 ifTrue: [submorphs do: [:m | m morphsAt: aPoint addTo: mList]]. mList addLast: self]. ^ mList! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/5/1999 16:07'! mouseX ^ self isInWorld ifTrue: [(self cursorPoint x) - self left] ifFalse: [0]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 1/5/1999 16:55'! mouseY ^ self isInWorld ifTrue: [self bottom - (self cursorPoint y)] ifFalse: [0]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'bf 9/22/1999 14:55'! position: aPoint "Prevent moving a world (e.g. via HandMorph>>specialGesture:)" self isWorldMorph ifFalse: [super position: aPoint] ! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/5/1998 22:53'! replaceSubmorph: oldMorph by: newMorph super replaceSubmorph: oldMorph by: newMorph. self autoLineLayout ifTrue: [self fixLayout]! ! !PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:45'! smallThumbnailForPageSorter ^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new smaller! ! !PasteUpMorph methodsFor: 'misc' stamp: 'di 12/23/1998 14:44'! thumbnailForPageSorter ^ self cachedOrNewThumbnailFrom: BookPageThumbnailMorph new! ! !PasteUpMorph methodsFor: 'misc' stamp: 'jm 10/14/2002 08:57'! unhideHiddenObjects self allMorphsDo: [:m | m isHidden: false]. ! ! !PasteUpMorph methodsFor: 'misc' stamp: 'sw 6/4/2000 21:42'! unlockedMorphsAt: aPoint addTo: mList "Overridden to exclude spurious hits on extralimital submorphs." ((self containsPoint: aPoint) and: [self isLocked not]) ifTrue: [submorphs size > 0 ifTrue: [submorphs do: [:m | m unlockedMorphsAt: aPoint addTo: mList]]. mList addLast: self]. ^ mList! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! activeHand ^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! activeHand: x worldState activeHand: x! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! canvas ^ worldState canvas! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! canvas: x worldState canvas: x. ! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! damageRecorder ^ worldState damageRecorder! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! firstHand ^ worldState hands first! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! hands ^ worldState hands! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! hands: x worldState hands: x! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! handsDo: aBlock ^ worldState hands do: aBlock! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 10/9/1999 22:51'! isStepping: aMorph ^ worldState isStepping: aMorph! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! lastCycleTime ^ worldState lastCycleTime! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! lastCycleTime: x worldState lastCycleTime: x! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! lastStepTime ^ worldState lastStepTime! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! lastStepTime: x worldState lastStepTime: x! ! !PasteUpMorph methodsFor: 'project state' stamp: 'jm 10/15/2002 15:32'! modelWakeUp | aWindow | "I am the model of a SystemWindow, that has just been activated" owner == nil ifTrue: [^ self]. "Not in Morphic world" (aWindow _ self containingWindow) ifNotNil: [self viewBox = aWindow panelRect ifFalse: [self viewBox: aWindow panelRect]]. ! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! stepList ^ worldState stepList! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! stepList: x worldState stepList: x! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 12/13/1999 12:26'! viewBox "This tortured workaround arises from a situation encountered in which a PasteUpMorph was directliy lodged as a submorph of another PasteUpMorph of identical size, with the former bearing flaps but the latter being the world" ^ worldState ifNotNil: [worldState viewBox] ifNil: [self pasteUpMorph viewBox]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! viewBox: newViewBox | vb | ((vb _ self viewBox) == nil or: [vb extent ~= newViewBox extent]) ifTrue: [self canvas: nil]. worldState viewBox: newViewBox. bounds _ 0@0 extent: newViewBox extent. "Paragraph problem workaround; clear selections to avoid screen droppings:" self handsDo: [:h | h newKeyboardFocus: nil]. self fullRepaintNeeded. ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'tk 3/7/2000 22:48'! cleanseStepList "Remove morphs from the step list that are not in this World. Often were in a flap that has moved on to another world." | deletions morphToStep | deletions _ nil. self stepList do: [:entry | morphToStep _ entry at: 1. morphToStep world == self ifFalse: [deletions ifNil: [deletions _ OrderedCollection new]. deletions addLast: morphToStep]]. deletions ifNotNil: [deletions do: [:deletedM | self stopStepping: deletedM. deletedM stopStepping]]. ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'sw 10/20/1999 15:50'! runStepMethods "Run morph 'step' methods whose time has come. Purge any morphs that are no longer in this world. ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors." | now deletions wakeupTime morphToStep | self stepList size = 0 ifTrue: [^ self]. now _ Time millisecondClockValue. ((now < self lastStepTime) or: [(now - self lastStepTime) > 5000]) ifTrue: [self adjustWakeupTimes]. "clock slipped" deletions _ nil. "Note: Put the following into an error handler to prevent errors happening on stepping" [self stepList do: [:entry | wakeupTime _ entry at: 2. morphToStep _ entry at: 1. morphToStep world == self ifTrue: [wakeupTime <= now ifTrue: [morphToStep stepAt: now. entry at: 2 put: now + morphToStep stepTime]] ifFalse: [deletions ifNil: [deletions _ OrderedCollection new]. deletions addLast: morphToStep]]] ifError: [:err :rcvr | self stopStepping: morphToStep. "Stop this guy right now" morphToStep setProperty: #errorOnStep toValue: true. "Remember stepping" Processor activeProcess errorHandler: nil. "So we don't handle this guy twice" rcvr error: err. "And re-raise the error from here so the stack is still valid"]. deletions ifNotNil: [deletions do: [:deletedM | self stopStepping: deletedM. deletedM stopStepping]]. self lastStepTime: now. ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'di 7/15/1999 09:51'! startStepping: aMorph "Add the given morph to the step list. Do nothing if it is already being stepped." self stepList do: [:entry | entry first = aMorph ifTrue: [^ self]]. "already stepping" self adjustWakeupTimesIfNecessary. self stepList add: (Array with: aMorph with: Time millisecondClockValue). ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'di 7/15/1999 09:51'! stopStepping: aMorph "Remove the given morph from the step list." self stepList copy do: [:entry | entry first == aMorph ifTrue: [self stepList remove: entry ifAbsent: []]]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! abandonAllHalos self haloMorphs do: [:m | m delete]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! addAllMorphs: array super addAllMorphs: array. self isWorldMorph ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! addHand: aHandMorph "Add the given hand to the list of hands for this world." self hands: (self hands copyWith: aHandMorph). aHandMorph privateOwner: self. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! addMorph: aMorph centeredNear: aPoint "Add the given morph to this world, attempting to keep its center as close to the given point possible while also keeping the it entirely within the bounds of this world." | trialRect delta | trialRect _ Rectangle center: aPoint extent: aMorph fullBounds extent. delta _ trialRect amountToTranslateWithin: bounds. aMorph position: trialRect origin + delta. self addMorph: aMorph. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! allMorphsDo: aBlock "Enumerate all morphs in the world, including those held in hands." super allMorphsDo: aBlock. self isWorldMorph ifTrue: [self hands reverseDo: [:h | h allMorphsDo: aBlock]]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 13:18'! assureNotPaintingElse: aBlock "If painting is already underway in the receiver, put up an informer to that effect and evalute aBlock" self sketchEditorOrNil ifNotNil: [self inform: 'Sorry, you can only paint one object at a time'. Cursor normal show. ^ aBlock value] ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 11/24/2002 10:49'! assuredCanvas (self canvas == nil or: [(self canvas extent ~= self viewBox extent) or: [self canvas form depth ~= Display depth]]) ifTrue: ["allocate a new offscreen canvas the size of the window" self canvas: (FormCanvas extent: self viewBox extent)]. ^ self canvas! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/4/2002 09:24'! beWorldForProject: aProject self privateOwner: nil. worldState _ WorldState new. self addHand: HandMorph new. self startSteppingSubmorphsOf: self. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'bf 1/5/2000 19:25'! chooseClickTarget Cursor crossHair showWhile: [Sensor waitButton]. Cursor down showWhile: [Sensor anyButtonPressed]. ^ (self morphsAt: Sensor cursorPoint) first! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 11/24/2002 12:19'! colorAt: aPoint belowMorph: aMorph "Return the color of the pixel immediately behind the given morph at the given point." "NOTE: due to some bounds wobble in flexing, take the middle of 3x3 patch." ^ (self patchAt: (aPoint-1 extent: 3) without: aMorph andNothingAbove: true) colorAt: 1@1 ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 5/30/2003 11:19'! displayWorld "Update this world's display." | deferredUpdateMode updateNeeded worldDamageRects handsToDraw handDamageRects allDamage | submorphs do: [:m | m fullBounds]. "force re-layout if needed" updateNeeded _ self damageRecorder updateIsNeeded. updateNeeded ifFalse: [ self handsDo: [:h | (h hasChanged and: [h needsToBeDrawn]) ifTrue: [updateNeeded _ true]]]. updateNeeded ifFalse: [^ self]. "display is already up-to-date" deferredUpdateMode _ self doDeferredUpdating. deferredUpdateMode ifFalse: [self assuredCanvas]. worldDamageRects _ self drawInvalidAreasOn: self canvas. "repair world's damage on canvas" "Uncomment for Dakota: self remoteServer ifNotNil: [self remoteServer processDamageList: worldDamageRects]." handsToDraw _ self selectHandsToDrawForDamage: worldDamageRects. handDamageRects _ handsToDraw collect: [:h | h savePatchFrom: self canvas]. allDamage _ worldDamageRects, handDamageRects. handsToDraw reverseDo: [:h | h fullDrawOn: self canvas]. "draw hands onto world canvas" false ifTrue: [ "*make this true to flash damaged areas for testing*" self flashRects: allDamage color: Color black]. "quickly copy altered rects of canvas to Display:" deferredUpdateMode ifTrue: [allDamage do: [:r | Display forceToScreen: (r "translateBy: self viewBox origin")]] ifFalse: [self canvas showAt: self viewBox origin invalidRects: allDamage]. handsToDraw do: [:h | h restoreSavedPatchOn: self canvas]. "restore world canvas under hands" Display deferUpdates: false; forceDisplayUpdate. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 5/25/2000 18:00'! displayWorldAsTwoTone "Display the world in living black-and-white. (This is typically done to save space.)" | f | f _ ColorForm extent: self viewBox extent depth: 1. f colors: (Array with: color dominantColor with: Color black). self canvas: (f getCanvas). "force the entire canvas to be redrawn" self fullRepaintNeeded. self drawInvalidAreasOn: self canvas. "redraw on offscreen canvas" self canvas showAt: self viewBox origin. "copy redrawn areas to Display" Display forceDisplayUpdate. self canvas: nil. "forget my canvas to save space" ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 11/24/2002 10:49'! displayWorldNonIncrementally "Display the morph world non-incrementally. Used for testing." (self canvas == nil or: [(self canvas extent ~= self viewBox extent) or: [self canvas form depth ~= Display depth]]) ifTrue: [ "allocate a new offscreen canvas the size of the window" self canvas: (FormCanvas extent: self viewBox extent)]. self canvas fillColor: color. submorphs reverseDo: [:m | m fullDrawOn: self canvas]. self hands reverseDo: [:h | h fullDrawOn: self canvas]. self canvas form displayOn: Display at: self viewBox origin. self fullRepaintNeeded. "don't collect damage" Display forceDisplayUpdate. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! displayWorldSafely "Update this world's display and keep track of errors during draw methods." | oldHandler errCtx errMorph | oldHandler _ Processor activeProcess errorHandler. [self displayWorld] ifError:[:err :rcvr| "Handle a drawing error" errCtx _ thisContext. [errCtx _ errCtx sender. "Search the sender chain to find the morph causing the problem" [errCtx notNil and:[(errCtx receiver isKindOf: Morph) not]] whileTrue:[errCtx _ errCtx sender]. "If we're at the root of the context chain then we have a fatal drawing problem" errCtx == nil ifTrue:[^self handleFatalDrawingError: err]. errMorph _ errCtx receiver. "If the morph causing the problem has already the #drawError flag set, then search for the next morph above in the caller chain." errMorph hasProperty: #errorOnDraw] whileTrue. errMorph setProperty: #errorOnDraw toValue: true. "Install the old error handler, so we can re-raise the error" Processor activeProcess errorHandler: oldHandler. rcvr error: err. ].! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 5/25/2000 18:03'! doDeferredUpdating "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature." DisableDeferredUpdates ifNil: [DisableDeferredUpdates _ false]. DisableDeferredUpdates ifTrue: [^ false]. (Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported" self == World ifTrue: [ "this world fills the entire Display" ((self canvas == nil) or: [self canvas form ~~ Display]) ifTrue: [ self canvas: (Display getCanvas). self viewBox: Display boundingBox]] ifFalse: [ "this world is inside an MVC window" ((self canvas == nil) or: [(self canvas form ~~ Display) or: [(self canvas origin ~= self viewBox origin)]]) ifTrue: [ self canvas: ((Display getCanvas) copyOffset: self viewBox origin clipRect: self viewBox)]]. ^ true ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! doOneCycle self interCyclePause: MinCycleLapse. self doOneCycleNow.! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! doOneSubCycle "Like doOneCycle, but preserves activeHand." | currentHand | currentHand _ self activeHand. self interCyclePause: MinCycleLapse. self doOneCycleNow. self activeHand: currentHand! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:11'! exit Project current exit. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 5/29/2003 18:02'! flashRects: rectangleList color: aColor "For testing. Flashes the given list of rectangles on the Display so you can watch incremental redisplay at work." "Details: Uses two reverses so that the display is restored to its original state. This is necessary when in deferred update mode." | blt screenRect | blt _ (BitBlt toForm: Display) sourceForm: nil; sourceOrigin: 0@0; clipRect: self viewBox; combinationRule: Form reverse. rectangleList do: [:r | screenRect _ r "translateBy: self viewBox origin". blt destRect: screenRect; copyBits. Display forceToScreen: screenRect; forceDisplayUpdate. (Delay forMilliseconds: 15) wait. blt destRect: screenRect; copyBits. Display forceToScreen: screenRect; forceDisplayUpdate]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 8/10/1999 09:30'! fullRepaintNeeded self damageRecorder doFullRepaint. SystemWindow windowsIn: self satisfying: [:w | w makeMeVisible. false]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:11'! goBack Project returnToPreviousProject. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! haloMorphOrNil | m | ^ (m _ self haloMorphs) size > 0 ifTrue: [m first] ifFalse: [nil]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! haloMorphs ^ submorphs select: [:m | m isKindOf: HaloMorph]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/27/1999 10:46'! handleFatalDrawingError: errMsg "Handle a fatal drawing error." Smalltalk isMorphic ifFalse:[^self error: errMsg]. "Can still handle it from MVC" Display deferUpdates: false. "Just in case" self primitiveError: errMsg. "Hm... we should jump into a 'safe' worldState here, but how do we find it?!!"! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! handlesMouseDown: evt self isWorldMorph ifTrue: [^ true] ifFalse: [^ super handlesMouseDown: evt] ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/4/2002 07:36'! initForProject: aWorldState worldState _ aWorldState. color _ (Color r:0.937 g: 0.937 b: 0.937). self addHand: HandMorph new. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/5/2002 06:38'! install submorphs do: [:ss | ss owner == nil ifTrue: [ss privateOwner: self]]. "Transcript that was in outPointers and then got deleted." self viewBox: Display boundingBox. self handsDo: [:h | h initForEvents]. SystemWindow noteTopWindowIn: self. self displayWorldSafely. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 4/27/2000 21:04'! interCyclePause: milliSecs "delay enough that the next interaction cycle won't happen too soon after the original; thus, if all the system is doing is polling for interaction, the overall CPU usage of Squeak will be low" | currentTime wait | currentTime _ Time millisecondClockValue. self lastCycleTime ifNotNil: [ wait _ self lastCycleTime + milliSecs - currentTime. wait > 0 ifTrue: [ wait < milliSecs "big waits happen after a snapshot" ifTrue: [DisplayScreen checkForNewScreenSize. (Delay forMilliseconds: wait) wait ]. ]. ]. self lastCycleTime: currentTime! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 11/27/1999 10:20'! jumpToProject Project jumpToProject. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 8/11/2003 21:59'! mouseDown: evt "Handle a mouse down event." self isWorldMorph ifFalse: [^ super mouseDown: evt]. evt hand newKeyboardFocus: nil. evt hand invokeMetaMenu: evt. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! nextPage "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful" self beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! open "Open a view on this WorldMorph." MorphWorldView openOn: self.! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! openWithTitle: aString cautionOnClose: aBoolean "Open a view on this WorldMorph with the given title." MorphWorldView openOn: self label: aString cautionOnClose: aBoolean! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/4/2002 07:23'! paintArea "What rectangle should the user be allowed to create a new painting in?? An area beside the paintBox. Allow playArea to override with its own bounds!! " | paintBoxBounds | paintBoxBounds _ self paintBox bounds. self firstHand targetOffset x < paintBoxBounds center x ifTrue: [^ bounds topLeft corner: paintBoxBounds left@bounds bottom] "paint on left side" ifFalse: [^ paintBoxBounds right@bounds top corner: bounds bottomRight]. "paint on right side" ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! paintAreaFor: aSketchMorph "Answer the area to comprise the onion-skinned canvas for painting/repainting aSketchMorph" | itsOwner | ((itsOwner _ aSketchMorph owner) ~~ nil and: [itsOwner isPlayfieldLike]) ifTrue: [^ itsOwner bounds]. "handles every plausible situation" ^ self paintArea! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/4/2002 08:36'! paintBox "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph, or if it has been deleted from this world, create a new one." | newPaintBox refPoint | self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]]. refPoint _ self topRight. newPaintBox _ PaintBoxMorph new. newPaintBox position: (refPoint - (newPaintBox width @ 0)). self addMorph: newPaintBox. ^ newPaintBox ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 12:01'! paintBoxOrNil "Return the painting controls widget (PaintBoxMorph) to be used for painting in this world. If there is not already a PaintBox morph return nil" self allMorphsDo: [:m | (m isKindOf: PaintBoxMorph) ifTrue: [^ m]]. ^ nil ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 9/27/2003 21:44'! patchAt: patchRect without: stopMorph andNothingAbove: stopThere "Return a complete rendering of this patch of the display screen without drawing stopMorph and, if stopThere is true, without drawing any morph above it." | c morphsToDraw i | c _ FormCanvas extent: patchRect extent depth: Display depth. c _ c copyOrigin: patchRect topLeft negated clipRect: (0@0 extent: patchRect extent). (self bounds containsRect: patchRect) ifFalse: [ "fill areas of patchRect outside my bounds with black" c form fillColor: Color black]. (self bounds intersects: patchRect) ifFalse: [^ c form]. "entirely out of bounds" "draw all morphs intersecting the given patch, stopping at the given morph" c fillRectangle: self bounds color: color. "draw world color" morphsToDraw _ submorphs reversed asOrderedCollection. (i _ morphsToDraw indexOf: stopMorph) > 0 ifTrue: [ stopThere ifTrue: [morphsToDraw _ morphsToDraw copyFrom: 1 to: i - 1] "stop at stopMorph" ifFalse: [morphsToDraw removeIndex: i]]. "skip stopMorph" morphsToDraw do: [:m | m fullDrawOn: c]. ^ c form ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! previousPage "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful" self beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! removeHand: aHandMorph "Remove the given hand from the list of hands for this world." (self hands includes: aHandMorph) ifTrue: [ aHandMorph dropMorphsEvent: MorphicEvent new. self hands: (self hands copyWithout: aHandMorph). self invalidRect: aHandMorph fullBounds. self activeHand == aHandMorph ifTrue: [self activeHand: nil]]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 10/14/2002 07:48'! restoreDisplay self == World ifTrue: [ "otherwise, we're a morphic window in MVC and the restoreDisplay was, unusually, issued from that world's menu rather than from the MVC screen menu" DisplayScreen startUp. self extent: Display extent. self viewBox: Display boundingBox]. self fullRepaintNeeded. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! selectHandsToDrawForDamage: damageList "Select the set of hands that must be redrawn because either (a) the hand itself has changed or (b) the hand intersects some damage rectangle." | result hBnds | result _ OrderedCollection new. self handsDo: [:h | h needsToBeDrawn ifTrue: [ h hasChanged ifTrue: [result add: h] ifFalse: [ hBnds _ h fullBounds. (damageList detect: [:r | r intersects: hBnds] ifNone: [nil]) ifNotNil: [result add: h]]]]. ^ result ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'sw 9/2/1999 13:09'! sketchEditorOrNil "Return a SketchEditorMorph found in the world, if any, else nil" ^ self findA: SketchEditorMorph ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'jm 7/17/2003 23:02'! sleep "Minimize space. Typically called when exiting a project." self canvas ifNil: [^ self]. "already cleaned up" Cursor normal show. "restore the normal cursor" (turtleTrailsForm notNil and: [self confirm: 'May I clear the pen trails?']) ifTrue: [self clearTurtleTrails]. self canvas: nil. "free my canvas to save space" self allMorphsDo: [:m | m releaseCachedState]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! standardSystemController ^ ScheduledControllers controllerSatisfying: [:c | (c view subViews size > 0) and: [c view firstSubView model == self]]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'di 7/15/1999 09:51'! startSteppingSubmorphsOf: aMorph "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world." aMorph allMorphsDo: [:m | m wantsSteps ifTrue: [m arrangeToStartSteppingIn: self]] ! ! !PasteUpMorph methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! adjustWakeupTimes "Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)" | earliestTime t now m oldWakeupTime | "find earliest wakeup time" earliestTime _ SmallInteger maxVal. self stepList do: [:entry | t _ entry at: 2. t < earliestTime ifTrue: [earliestTime _ t]]. "recompute all wakeup times, using earliestTime as the origin" now _ Time millisecondClockValue. self stepList do: [:entry | m _ entry at: 1. oldWakeupTime _ entry at: 2. entry at: 2 put: now + ((oldWakeupTime - earliestTime) min: m stepTime)]. self lastStepTime: now. ! ! !PasteUpMorph methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! adjustWakeupTimesIfNecessary "Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)." | now | now _ Time millisecondClockValue. ((now < self lastStepTime) or: [(now - self lastStepTime) > 5000]) ifTrue: [self adjustWakeupTimes]. "clock slipped" ! ! !PasteUpMorph methodsFor: 'project' stamp: 'tk 9/3/1999 12:07'! project "Find the project that owns me. Not efficient to call this." ^ Project ofWorld: self! ! !PasteUpMorph methodsFor: 'interaction loop' stamp: 'jm 8/7/2003 11:28'! cycleWhileWaitingMSecs: waitMSecs doInput: doInputFlag doSteps: doStepFlag "Perform the interactive loop repeatedly for the given number of milliseconds." | startT now | startT _ Time millisecondClockValue. [((now _ Time millisecondClockValue) < startT) or: [(now - startT) < waitMSecs]] whileTrue: [ doInputFlag ifTrue: [ "process user input events" self handsDo: [:h | self activeHand: h. h processEvents. self activeHand: nil]]. doStepFlag ifTrue: [self runStepMethods]. self displayWorldSafely]. ! ! !PasteUpMorph methodsFor: 'interaction loop' stamp: 'TIS 6/18/2003 17:20'! doOneCycleNoInput "Do one cycle of the display and step loop without user input." self runStepMethods. self displayWorldSafely. ! ! !PasteUpMorph methodsFor: 'interaction loop' stamp: 'jm 10/4/2002 18:21'! doOneCycleNow "Do one cycle of the interactive loop. This method is called repeatedly when the world is running." "process user input events" self handsDo: [:h | self activeHand: h. h processEvents. self activeHand: nil]. self runStepMethods. self displayWorldSafely. ! ! !PasteUpMorph methodsFor: 'WiW support' stamp: 'RAA 11/27/1999 15:41'! restartWorldCycleWithEvent: evt "RAA 27 Nov 99 - redispatch that click picked up from our inner world" evt ifNotNil: [ self primaryHand handleEvent: (evt setHand: self primaryHand). ]. Project current spawnNewProcessAndTerminateOld: true ! ! !PasteUpMorph methodsFor: 'remote connections' stamp: 'jm 11/24/2002 19:13'! remoteServer ^ worldState remoteServer ! ! !PasteUpMorph methodsFor: 'remote connections' stamp: 'jm 11/24/2002 19:18'! remoteServer: aNebraskaServerOrNil worldState remoteServer: aNebraskaServerOrNil. ! ! !PasteUpMorph methodsFor: 'private' stamp: 'jm 10/13/2002 18:22'! boundingBoxOfSubmorphs "Answer a rectangle that just encloses all of my non-hidden submorphs." | r | r _ bounds origin extent: self minimumExtent. "so won't end up with something empty" submorphs do: [:m | m isHidden ifFalse: [r _ r quickMerge: m fullBounds]]. ^ r ! ! !PasteUpMorph methodsFor: 'private' stamp: 'ar 3/14/2000 23:20'! privateFullMoveBy: delta "Private. Overridden to prevent drawing turtle trails when a playfield is moved" self setProperty: #turtleTrailsDelta toValue: delta. super privateFullMoveBy: delta. self removeProperty: #turtleTrailsDelta. ! ! !PasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! !PasteUpMorph class methodsFor: 'as yet unclassified' stamp: 'jm 10/4/2002 09:25'! newWorldForProject: projectOrNil "Return a new pasteUpMorph configured as a world." ^ self new initForProject: WorldState new ! ! !PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! MinCycleLapse: milliseconds "set the minimum amount of time that may transpire between two calls to doOneCycle" MinCycleLapse _ milliseconds ifNotNil: [ milliseconds rounded ].! ! !PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! disableDeferredUpdates: aBoolean "If the argument is true, disable deferred screen updating." "Details: When deferred updating is used, Morphic performs double-buffered screen updates by telling the VM to de-couple the Display from the hardware display buffer, drawing directly into the Display, and then forcing the changed regions of the Display to be copied to the screen. This saves both time (an extra BitBlt is avoided) and space (an extra display buffer is avoided). However, on platforms on which the Display points directly to the hardware screen buffer, deferred updating can't be used (you'd see ugly flashing as the layers of the drawing were assembled). In this case, the drawing is composited into an offscreen FormCanvas and then copied to the hardware display buffer." DisableDeferredUpdates _ aBoolean. ! ! !PasteUpMorph class methodsFor: 'project' stamp: 'di 7/15/1999 09:51'! initialize "WorldMorph initialize" self MinCycleLapse: 20. "allows 50 frames per second..."! ! !PasteUpMorph class methodsFor: 'project' stamp: 'bf 5/23/2000 12:12'! startUp Smalltalk isMorphic ifTrue: [World restoreDisplay]! ! !Pen methodsFor: 'operations' stamp: 'di 6/21/1998 09:37'! fill: drawBlock color: color | region tileForm tilePen shape saveColor recorder | drawBlock value: (recorder _ self as: PenPointRecorder). region _ Rectangle encompassing: recorder points. tileForm _ Form extent: region extent+6. tilePen _ Pen newOnForm: tileForm. tilePen location: location-(region origin-3) direction: direction penDown: penDown. drawBlock value: tilePen. "Draw the shape in B/W" saveColor _ halftoneForm. drawBlock value: self. halftoneForm _ saveColor. shape _ (tileForm findShapeAroundSeedBlock: [:f | f borderWidth: 1]) reverse. shape copy: shape boundingBox from: tileForm to: 0@0 rule: Form erase. destForm fillShape: shape fillColor: color at: region origin-3! ! !Pen methodsFor: 'operations' stamp: 'jm 5/29/2003 18:03'! print: str withFont: font "Print the given string in the given font at the current heading" | lineStart form charStart rowStart scale wasDown bb pix | scale _ sourceForm width. wasDown _ penDown. lineStart _ location. str do: [:char | char = Character cr ifTrue: [self place: lineStart; up; turn: 90; go: font height*scale; turn: -90; down] ifFalse: [form _ font characterFormAt: char. charStart _ location. wasDown ifTrue: [ self up; turn: -90; go: font descent*scale; turn: 90; down. 0 to: form height-1 do: [:y | rowStart _ location. bb _ BitBlt bitPeekerFromForm: form. pix _ RunArray newFrom: ((0 to: form width-1) collect: [:x | bb pixelAt: x@y]). pix runs with: pix values do: [:run :value | value = 0 ifTrue: [self up; go: run*scale; down] ifFalse: [self go: run*scale]]. self place: rowStart; up; turn: 90; go: scale; turn: -90; down]. ]. self place: charStart; up; go: form width*scale; down]. ]. wasDown ifFalse: [self up] " Display restoreAfter: [Pen new squareNib: 2; color: Color red; turn: 45; print: 'The owl and the pussycat went to sea in a beautiful pea green boat.' withFont: TextStyle defaultFont] "! ! !Pen methodsFor: 'geometric designs' stamp: 'di 6/11/1998 22:01'! dragon: n "Display restoreAfter: [Display fillWhite. Pen new dragon: 10]." "Display restoreAfter: [Display fillWhite. 1 to: 4 do: [:i | Pen new color: i; turn: 90*i; dragon: 10]]" "Draw a dragon curve of order n in the center of the screen." n = 0 ifTrue: [self go: 5] ifFalse: [n > 0 ifTrue: [self dragon: n - 1; turn: 90; dragon: 1 - n] ifFalse: [self dragon: -1 - n; turn: -90; dragon: 1 + n]] ! ! !Pen methodsFor: 'geometric designs' stamp: 'di 6/14/1998 13:42'! filberts: n side: s "Display restoreAfter: [Pen new filberts: 4 side: 5]" "Two Hilbert curve fragments form a Hilbert tile. Draw four interlocking tiles of order n and sides length s." | n2 | Display fillWhite. n2 _ 1 bitShift: n - 1. self up; go: 0 - n2 * s; down. 1 to: 4 do: [:i | self fill: [:p | p hilbert: n side: s. p go: s. p hilbert: n side: s. p go: s. p up. p go: n2 - 1 * s. p turn: -90. p go: n2 * s. p turn: 180. p down] color: (Color perform: (#(yellow red green blue) at: i))]! ! !Pen methodsFor: 'private' stamp: 'di 6/11/1998 16:09'! location: aPoint direction: aFloat penDown: aBoolean location _ aPoint. direction _ aFloat. penDown _ aBoolean! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 5/29/2003 18:02'! feltTip: width cellSize: cellSize "Warning: This example potentially uses a large amount of memory--it creates a Form with cellSize squared bits for every Display pixel." "In this example, all drawing is done into a large, monochrome Form and then scaled down onto the Display using smoothing. The larger the cell size, the more possible shades of gray can be generated, and the smoother the resulting line appears. A cell size of 8 yields 64 possible grays, while a cell size of 16 gives 256 levels, which is about the maximum number of grays that the human visual system can distinguish. The width parameter determines the maximum line thickness. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." "Pen feltTip: 2.7 cellSize: 8" | tabletScale bitForm pen warp p srcR dstR nibSize startP r | tabletScale _ self tabletScaleFactor. bitForm _ Form extent: Display extent * cellSize depth: 1. pen _ Pen newOnForm: bitForm. pen color: Color black. warp _ (WarpBlt toForm: Display) sourceForm: bitForm; colorMap: (bitForm colormapIfNeededForDepth: Display depth); cellSize: cellSize; combinationRule: Form over. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ p _ (Sensor tabletPoint * cellSize * tabletScale) rounded. nibSize _ (Sensor tabletPressure * (cellSize * width)) rounded. nibSize > 0 ifTrue: [ pen squareNib: nibSize. startP _ pen location. pen goto: p. r _ startP rect: pen location. dstR _ (r origin // cellSize) corner: ((r corner + nibSize + (cellSize - 1)) // cellSize). srcR _ (dstR origin * cellSize) corner: (dstR corner * cellSize). warp copyQuad: srcR innerCorners toRect: dstR] ifFalse: [ pen place: p]]]. ! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:20'! inkBrush "Similar to simplePressurePen, but this example uses the average of the recent pen pressure values. The effect is that of a Japanese ink brush that comes up gradually off the paper as the brush is lifted, causing end (and beginning) of each stroke to taper. Requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." "Pen inkBrush" | tabletScale historyMSecs pressureHistory pen now currentPressure sum averagePressure p | tabletScale _ self tabletScaleFactor. historyMSecs _ 120. pressureHistory _ OrderedCollection new. pen _ Pen newOnForm: Display. pen color: Color black. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ "compute the average pressure over last historyMSecs milliseconds" now _ Time millisecondClockValue. currentPressure _ (20.0 * Sensor tabletPressure) rounded. pressureHistory addLast: (Array with: now with: currentPressure). [pressureHistory size > 0 and: [(pressureHistory first first + historyMSecs) < now]] whileTrue: [pressureHistory removeFirst]. "prune old entries" sum _ pressureHistory inject: 0 into: [:t :e | t + e last]. averagePressure _ sum // pressureHistory size. p _ (Sensor tabletPoint * tabletScale) rounded. averagePressure > 0 ifTrue: [ pen roundNib: averagePressure. pen goto: p] ifFalse: [ pen place: p]]]. ! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:13'! simplePressurePen "An example of using a pressure sensitive pen to control the thickness of the pen. This requires the optional tablet support primitives which may not be supported on all platforms. Works best in full screen mode. Shift-mouse to exit." "Pen simplePressurePen" | tabletScale pen pressure p | tabletScale _ self tabletScaleFactor. pen _ Pen newOnForm: Display. pen color: Color black. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ p _ (Sensor tabletPoint * tabletScale) rounded. pressure _ (15.0 * Sensor tabletPressure) rounded. pressure > 0 ifTrue: [ pen roundNib: pressure. pen goto: p] ifFalse: [ pen place: p]]]. ! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:12'! tabletScaleFactor "Answer a Point that scales tablet coordinates to Display coordinates, where the full extent of the tablet maps to the extent of the entire Display." | tabletExtent | tabletExtent _ Sensor tabletExtent. ^ (Display width asFloat / tabletExtent x) @ (Display height asFloat / tabletExtent y) ! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/12/1999 12:51'! testMouseTracking "A very simple example of drawing using the mouse. Compare the tracking speed of this example with that of testTabletTracking. Mouse down to draw a stroke, shift-mouse to exit." "Pen testMouseTracking" | pen p | pen _ Pen newOnForm: Display. pen roundNib: 8. pen color: Color black. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ p _ Sensor cursorPoint. Sensor anyButtonPressed ifTrue: [pen goto: p] ifFalse: [ pen color: Color random. pen place: p]]]. ! ! !Pen class methodsFor: 'tablet drawing examples' stamp: 'jm 4/13/1999 11:21'! testTabletTracking "A very simple example of drawing using the pen of a digitizing tablet such as a Wacom ArtZ tablet. This requires the optional tablet support primitives which may not be supported on all platforms. Compare the tracking speed of this example with that of testMouseTracking. On a Macintosh, the tablet primitives provide roughly 120 samples/second versus only 60 mouse samples/second, and the difference is noticable. Works best in full screen mode. Mouse down to draw a stroke, shift-mouse to exit." "Pen testTabletTracking" | tabletScale pen p | tabletScale _ self tabletScaleFactor. pen _ Pen newOnForm: Display. pen roundNib: 8. pen color: Color black. Display fillColor: Color white. Display restoreAfter: [ [Sensor shiftPressed and: [Sensor anyButtonPressed]] whileFalse: [ p _ (Sensor tabletPoint * tabletScale) rounded. Sensor tabletPressure > 0 ifTrue: [pen goto: p] ifFalse: [ pen color: Color random. pen place: p]]]. ! ! This class is a special kind of Pen that instead of actually drawing lines records the destination points for those lines. These points can later be accessed through my accessing method #points. This can be useful when determining the boundaries of a drawing session. Example: | pen | pen _ PenPointRecorder new. pen up; goto: 100@100; down; goto: 120@120. Transcript cr; show: 'Bounding box for drawing: '; show: (Rectangle encompassing: pen points) Implementation note: Shouldn't we override #drawFrom:to:withFirstPoint: instead, and what about #drawLoopX:Y:? Aren't we missing those calls?! !PenPointRecorder methodsFor: 'accessing' stamp: 'di 6/21/1998 09:35'! points ^ points! ! !PenPointRecorder methodsFor: 'line drawing' stamp: 'sma 2/26/2000 19:03'! drawFrom: p1 to: p2. "Overridden to skip drawing but track bounds of the region traversed." points ifNil: [points _ OrderedCollection with: p1]. points addLast: p2! ! I represent one key of a PianoKeyboardMorph. I respond to mouse down and drag events by telling my target (the keyboard) to play a note given by my midiKey. ! !PianoKeyMorph methodsFor: 'initialization' stamp: 'jm 10/9/2002 08:44'! initialize super initialize. borderWidth _ 1. midiKey _ 60. target _ nil. ! ! !PianoKeyMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 08:47'! midiKey ^ midiKey ! ! !PianoKeyMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 09:48'! midiKey: anInteger "Set my midiKey, which determines the pitch of this note. Middle-C is 60." midiKey _ anInteger. self setKeyColor. ! ! !PianoKeyMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 09:42'! setKeyColor "Set my key color based on my midiKey." | isBlackKey | isBlackKey _ #(1 3 6 8 10) includes: (midiKey \\ 12). isBlackKey ifTrue: [self color: BlackKeyColor] ifFalse: [self color: WhiteKeyColor] ! ! !PianoKeyMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 08:50'! target: anObjectOrNil "Set my target to the given object. Non-nil targets are sent the messages turnOnNote: and turnOffNote." target _ anObjectOrNil. ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:33'! handlesMouseDown: evt ^ true ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:12'! handlesMouseOverDragging: evt ^ true ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:51'! mouseDown: evt self color: KeyDownColor. target ifNotNil: [target turnOnNote: midiKey]. ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:33'! mouseEnterDragging: evt evt hand hasSubmorphs ifTrue: [^ self]. "do nothing if dragging a morph" self mouseDown: evt. ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:33'! mouseLeaveDragging: evt self mouseUp: evt. ! ! !PianoKeyMorph methodsFor: 'event handling' stamp: 'jm 10/9/2002 08:46'! mouseUp: evt self setKeyColor. target ifNotNil: [target turnOffNote]. ! ! !PianoKeyMorph class methodsFor: 'class initialization' stamp: 'jm 10/26/2002 10:46'! initialize BlackKeyColor _ Color black. WhiteKeyColor _ Color gray: 0.95. KeyDownColor _ Color yellow. ! ! I am a collection of PianoKeyMorphs arranged in a piano keyboard. I can play with Squeak internal sounds or via MIDI. I can transpose up or down by any number of half-steps and I can make myself larger or smaller. ! !PianoKeyboardMorph methodsFor: 'initialization' stamp: 'jm 10/26/2002 10:56'! buildKeyboard: nOctaves baseOctave: baseOctave keyWidth: whiteW "Build keyboard for the given number of octaves starting with the given octave." | whiteH blackW blackH octaveStart octavePt nWhite nBlack noteR key xOffset | self removeAllMorphs. self extent: 5@5. "adjusted later" whiteH _ (3.3 * whiteW) rounded. blackW _ (0.57 * whiteW) rounded. blackW even ifTrue: [blackW _ blackW - 1]. blackH _ (0.6 * whiteH) rounded. 0 to: nOctaves do: [:i | octaveStart _ 12 * (baseOctave + i). octavePt _ self innerBounds topLeft + (((7 * whiteW * i) - 1) @ -1). i < nOctaves ifTrue: [nWhite _ 7. nBlack _ 5] ifFalse: [nWhite _ 1. nBlack _ 0]. "only one 'C' key in top octave" 1 to: nWhite do: [:j | noteR _ (octavePt + (((j - 1) * whiteW) @ 0)) extent: (whiteW + 1) @ whiteH. key _ PianoKeyMorph newBounds: noteR. key target: self; midiKey: octaveStart + (#(0 2 4 5 7 9 11) at: j). self addMorph: key]. 1 to: nBlack do: [:j | xOffset _ (whiteW * (#(1 2 4 5 6) at: j)) - (blackW // 2). noteR _ (octavePt + (xOffset @ 0)) extent: blackW @ blackH. key _ PianoKeyMorph newBounds: noteR. key target: self; midiKey: octaveStart + (#(1 3 6 8 10) at: j). self addMorph: key]]. self extent: (self fullBounds extent + borderWidth - 1). ! ! !PianoKeyboardMorph methodsFor: 'initialization' stamp: 'jm 10/26/2002 10:59'! initialize super initialize. soundPrototype _ FMSound bassoon1. midiTranspose _ 0. self buildKeyboard: 6 baseOctave: 2 keyWidth: 10. ! ! !PianoKeyboardMorph methodsFor: 'accessing' stamp: 'jm 10/9/2002 09:52'! soundPrototype: aSound soundPrototype _ aSound. ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/26/2002 11:03'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'transpose' action: #setTranspose. aCustomMenu add: 'bigger keyboard' action: #makeKeysLarger. aCustomMenu add: 'smaller keyboard' action: #makeKeysSmaller. midiPort ifNil: [ SimpleMIDIPort midiIsSupported ifTrue: [ aCustomMenu add: 'play via MIDI' action: #openMIDIPort]] ifNotNil: [ aCustomMenu add: 'play via built in synth' action: #closeMIDIPort. aCustomMenu add: 'set midi instrument' action: #setMidiInstrument. aCustomMenu add: 'new MIDI controller' action: #makeMIDIController:]. ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/26/2002 11:06'! makeKeysLarger self buildKeyboard: 6 baseOctave: 2 keyWidth: ((submorphs last width) * 1.25) rounded. ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/26/2002 11:06'! makeKeysSmaller self buildKeyboard: 6 baseOctave: 2 keyWidth: ((submorphs last width) / 1.25) rounded. ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/9/2002 10:09'! makeMIDIController: evt self world activeHand attachMorph: (MIDIControllerMorph new midiPort: midiPort). ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/23/2002 22:25'! setMidiInstrument "Send a MIDI command to change my instrument to the one specified by the user." | response instNum | response _ FillInTheBlank request: 'Instrument Number (1 to 128)?' initialAnswer: '1'. response size = 0 ifTrue: [^ self]. instNum _ response asNumber asInteger. ((instNum < 1) or: [instNum > 128]) ifTrue: [^ self]. midiPort midiCmd: 16rC0 channel: 1 byte: instNum - 1. ! ! !PianoKeyboardMorph methodsFor: 'menus' stamp: 'jm 10/23/2002 22:31'! setTranspose "Send a MIDI command to change my instrument to the one specified by the user." | response | response _ FillInTheBlank request: 'Transpose half-steps?' initialAnswer: midiTranspose printString. response size = 0 ifTrue: [^ self]. midiTranspose _ response asNumber asInteger. ! ! !PianoKeyboardMorph methodsFor: 'private' stamp: 'jm 10/9/2002 10:04'! closeMIDIPort midiPort _ nil. ! ! !PianoKeyboardMorph methodsFor: 'private' stamp: 'jm 10/9/2002 10:03'! openMIDIPort | portNum | portNum _ SimpleMIDIPort outputPortNumFromUser. portNum ifNil: [^ self]. midiPort _ SimpleMIDIPort openOnPortNumber: portNum. ! ! !PianoKeyboardMorph methodsFor: 'private' stamp: 'jm 10/9/2002 10:02'! turnOffNote soundPlaying ifNil: [^ self]. "no note playing" midiPort ifNil: [soundPlaying stopGracefully] ifNotNil: [ soundPlaying isInteger ifTrue: [ midiPort midiCmd: 16r90 channel: 1 byte: soundPlaying byte: 0]]. soundPlaying _ nil. ! ! !PianoKeyboardMorph methodsFor: 'private' stamp: 'jm 10/26/2002 11:09'! turnOnNote: midiKey | transposedKey pitch | transposedKey _ midiKey + midiTranspose. midiPort ifNil: [ soundPlaying ifNotNil: [soundPlaying stopGracefully]. pitch _ AbstractSound pitchForMIDIKey: transposedKey. soundPlaying _ soundPrototype soundForPitch: pitch dur: 100.0 loudness: 0.3. SoundPlayer resumePlaying: soundPlaying quickStart: true] ifNotNil: [ soundPlaying ifNotNil: [self turnOffNote]. midiPort midiCmd: 16r90 channel: 1 byte: transposedKey byte: 127. soundPlaying _ transposedKey]. ! ! !PianoKeyboardMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:05'! includeInNewMorphMenu ^ true ! ! A PianoRollNoteMorph is drawn as a simple mroph, but it carries the necessary state to locate its source sound event via its owner (a PianorRollScoreMorph) and the score therein. Simple editing of pitch and time placement is provided here.! !PianoRollNoteMorph methodsFor: 'initialization' stamp: 'di 6/17/1999 10:46'! trackIndex: ti indexInTrack: i trackIndex _ ti. indexInTrack _ i. selected _ false! ! !PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:17'! indexInTrack ^ indexInTrack! ! !PianoRollNoteMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:16'! trackIndex ^ trackIndex! ! !PianoRollNoteMorph methodsFor: 'drawing' stamp: 'di 6/17/1999 10:56'! drawOn: aCanvas selected ifTrue: [aCanvas frameAndFillRectangle: self fullBounds fillColor: color borderWidth: 1 borderColor: Color black] ifFalse: [aCanvas fillRectangle: self bounds color: color]. ! ! !PianoRollNoteMorph methodsFor: 'geometry' stamp: 'di 6/17/1999 10:55'! fullBounds selected ifTrue: [^ bounds expandBy: 1] ifFalse: [^ bounds]! ! !PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/15/1999 14:55'! handlesMouseDown: evt ^ owner scorePlayer isPlaying not! ! !PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 10:26'! mouseDown: evt hitLoc _ evt cursorPoint. editMode _ nil. owner submorphsDo: [:m | (m isKindOf: PianoRollNoteMorph) ifTrue: [m deselect]]. selected _ true. self changed. owner selection: (Array with: trackIndex with: indexInTrack with: indexInTrack). self playSound! ! !PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/20/1999 12:37'! mouseMove: evt | delta offsetEvt | editMode == nil ifTrue: ["First movement determines edit mode" ((delta _ evt cursorPoint - hitLoc) dist: 0@0) <= 2 ifTrue: [^ self "No significant movement yet."]. delta x abs > delta y abs ifTrue: [delta x > 0 "Horizontal drag" ifTrue: [editMode _ #selectNotes] ifFalse: [self playSound: nil. offsetEvt _ evt copy setCursorPoint: evt cursorPoint + (20@0). self invokeNoteMenu: offsetEvt]] ifFalse: [editMode _ #editPitch "Vertical drag"]]. editMode == #editPitch ifTrue: [self editPitch: evt]. editMode == #selectNotes ifTrue: [self selectNotes: evt]. ! ! !PianoRollNoteMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 08:29'! mouseUp: evt self playSound: nil! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/17/1999 11:48'! noteInScore ^ (owner score tracks at: trackIndex) at: indexInTrack ! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/17/1999 11:48'! noteOfDuration: duration | note | note _ self noteInScore. ^ (owner scorePlayer instrumentForTrack: trackIndex) soundForMidiKey: note midiKey dur: duration loudness: (note velocity asFloat / 127.0) ! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:19'! playSound "This STARTS a single long sound. It must be stopped by playing another or nil." ^ self playSound: (self soundOfDuration: 999.0)! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:13'! playSound: aSoundOrNil SoundPlaying ifNotNil: [SoundPlaying stopGracefully]. SoundPlaying _ aSoundOrNil. SoundPlaying ifNotNil: [SoundPlaying play].! ! !PianoRollNoteMorph methodsFor: 'note playing' stamp: 'di 6/19/1999 08:03'! soundOfDuration: duration | sound | sound _ MixedSound new. sound add: (self noteOfDuration: duration) pan: (owner scorePlayer panForTrack: trackIndex) volume: owner scorePlayer overallVolume * (owner scorePlayer volumeForTrack: trackIndex). ^ sound ! ! !PianoRollNoteMorph methodsFor: 'menu' stamp: 'di 6/20/1999 13:22'! invokeNoteMenu: evt "Invoke the note's edit menu." | menu | menu _ MenuMorph new defaultTarget: self. menu addList: #(('grid to next quarter' gridToNextQuarter) ('grid to prev quarter' gridToPrevQuarter)). evt hand invokeMenu: menu event: evt. ! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:16'! deselect selected ifFalse: [^ self]. self changed. selected _ false. ! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:16'! select selected ifTrue: [^ self]. selected _ true. self changed! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/17/1999 12:30'! selectFrom: selection (trackIndex = (selection at: 1) and: [indexInTrack >= (selection at: 2) and: [indexInTrack <= (selection at: 3)]]) ifTrue: [selected ifFalse: [self select]] ifFalse: [selected ifTrue: [self deselect]]! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/19/1999 10:24'! selectNotes: evt | lastMorph oldEnd saveOwner | saveOwner _ owner. (owner autoScrollForX: evt cursorPoint x) ifTrue: ["If scroll talkes place I will be deleted and my x-pos will become invalid." owner _ saveOwner. bounds _ bounds withLeft: (owner xForTime: self noteInScore time)]. oldEnd _ owner selection last. (owner notesInRect: (evt cursorPoint x @ owner top corner: owner bottomRight)) do: [:m | m trackIndex = trackIndex ifTrue: [m deselect]]. self select. lastMorph _ self. (owner notesInRect: (self left @ owner top corner: evt cursorPoint x @ owner bottom)) do: [:m | m trackIndex = trackIndex ifTrue: [m select. lastMorph _ m]]. owner selection: (Array with: trackIndex with: indexInTrack with: lastMorph indexInTrack). lastMorph indexInTrack ~= oldEnd ifTrue: ["Play last note as selection grows or shrinks" owner ifNotNil: [lastMorph playSound]] ! ! !PianoRollNoteMorph methodsFor: 'selecting' stamp: 'di 6/20/1999 11:44'! selected ^ selected! ! !PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/19/1999 08:14'! editPitch: evt | mk note | mk _ owner midiKeyForY: evt cursorPoint y. note _ (owner score tracks at: trackIndex) at: indexInTrack. note midiKey = mk ifTrue: [^ self]. note midiKey: mk. self playSound: (self soundOfDuration: 999.0). self position: self position x @ ((owner yForMidiKey: mk) - 1) ! ! !PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'! gridToNextQuarter owner score gridTrack: trackIndex toQuarter: 1 at: indexInTrack. owner rebuildFromScore! ! !PianoRollNoteMorph methodsFor: 'editing' stamp: 'di 6/17/1999 16:08'! gridToPrevQuarter owner score gridTrack: trackIndex toQuarter: -1 at: indexInTrack. owner rebuildFromScore! ! A PianoRollScoreMorph displays a score such as a MIDIScore, and will scroll through it tracking the porgress of a ScorePlayerMorph (from which it is usually spawned). timeScale is in pixels per score tick. Currently the ambient track (for synchronizing thumbnails, eg) is treated specially here and in the score. This should be cleaned up by adding a trackType or something like it in the score.! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'di 6/20/1999 16:20'! initialize super initialize. borderWidth _ 1. color _ Color white. self extent: 400@300. showMeasureLines _ true. showBeatLines _ false. self timeSignature: 4 over: 4. ! ! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'di 6/20/1999 00:53'! on: aScorePlayer scorePlayer _ aScorePlayer. score _ aScorePlayer score. colorForTrack _ Color wheel: score tracks size. leftEdgeTime _ 0. timeScale _ 0.1. indexInTrack _ Array new: score tracks size withAll: 1. lastUpdateTick _ -1. self updateLowestNote ! ! !PianoRollScoreMorph methodsFor: 'initialization' stamp: 'di 6/20/1999 12:25'! updateLowestNote "find the actual lowest note in the score" | n | lowestNote _ 128 - (self innerBounds height // 3). score tracks do: [:track | 1 to: track size do: [:i | n _ track at: i. (n isNoteEvent and: [n midiKey < lowestNote]) ifTrue: [lowestNote _ n midiKey - 4]]]. ! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'! beatsPerMeasure: n ^ self timeSignature: n over: notePerBeat! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 16:25'! notePerBeat: n ^ self timeSignature: beatsPerMeasure over: n! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 15:46'! score ^ score! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/15/1999 14:52'! scorePlayer ^ scorePlayer! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 01:00'! selection "Returns an array of 3 elements: trackIndex indexInTrack of first note indexInTrack of last note" | trackIndex track | selection ifNil: "If no selection, return last event of 1st non-muted track (or nil)" [trackIndex _ (1 to: score tracks size) detect: [:i | (scorePlayer mutedForTrack: i) not] ifNone: [^ nil]. track _ score tracks at: trackIndex. ^ Array with: trackIndex with: track size with: track size]. (scorePlayer mutedForTrack: selection first) ifTrue: [selection _ nil. ^ self selection]. ^ selection! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/17/1999 11:38'! selection: anArray selection _ anArray! ! !PianoRollScoreMorph methodsFor: 'accessing' stamp: 'di 6/20/1999 20:48'! timeSignature: num over: denom beatsPerMeasure _ num. notePerBeat _ denom. "a number like 2, 4, 8" self changed! ! !PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 16:35'! drawMeasureLinesOn: aCanvas | ticksPerMeas x measureLineColor inner | showBeatLines ifNil: [showBeatLines _ false]. showMeasureLines ifNil: [showMeasureLines _ true]. notePerBeat ifNil: [self timeSignature: 4 over: 4]. showBeatLines ifTrue: [measureLineColor _ Color gray: 0.8. ticksPerMeas _ score ticksPerQuarterNote. inner _ self innerBounds. (leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas) to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas) by: ticksPerMeas do: [:tickTime | x _ self xForTime: tickTime. aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height) color: measureLineColor]]. showMeasureLines ifTrue: [measureLineColor _ Color gray: 0.7. ticksPerMeas _ beatsPerMeasure*score ticksPerQuarterNote*4//notePerBeat. inner _ self innerBounds. (leftEdgeTime + ticksPerMeas truncateTo: ticksPerMeas) to: ((self timeForX: self right - borderWidth) truncateTo: ticksPerMeas) by: ticksPerMeas do: [:tickTime | x _ self xForTime: tickTime. aCanvas fillRectangle: (x @ inner top extent: 1 @ inner height) color: measureLineColor]]. ! ! !PianoRollScoreMorph methodsFor: 'drawing' stamp: 'jm 5/30/1999 17:56'! drawOn: aCanvas super drawOn: aCanvas. self drawStaffOn: aCanvas. ! ! !PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 12:24'! drawStaffOn: aCanvas | blackKeyColor l r topEdge y | self drawMeasureLinesOn: aCanvas. blackKeyColor _ Color gray: 0.5. l _ self left + borderWidth. r _ self right - borderWidth. topEdge _ self top + borderWidth + 3. lowestNote to: 127 do: [:k | y _ self yForMidiKey: k. y <= topEdge ifTrue: [^ self]. "over the top!!" (self isBlackKey: k) ifTrue: [ aCanvas fillRectangle: (l@y corner: r@(y + 1)) color: blackKeyColor]]. ! ! !PianoRollScoreMorph methodsFor: 'drawing' stamp: 'jm 6/1/1998 07:52'! isBlackKey: midiKey "Answer true if the given MIDI key corresponds to a black key on the piano keyboard." | note | note _ midiKey \\ 12. note = 1 ifTrue: [^ true]. note = 3 ifTrue: [^ true]. note = 6 ifTrue: [^ true]. note = 8 ifTrue: [^ true]. note = 10 ifTrue: [^ true]. ^ false ! ! !PianoRollScoreMorph methodsFor: 'drawing' stamp: 'di 6/20/1999 12:23'! rebuildFromScore "Rebuild my submorphs from the score. This method should be invoked after changing the time scale, the color or visibility of a track, the extent of this morph, etc." score ifNil: [^ self]. self addNotes. ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 5/30/1999 17:28'! contractTime timeScale _ timeScale / 1.5. self rebuildFromScore. ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 5/30/1999 17:29'! expandTime timeScale _ timeScale * 1.5. self rebuildFromScore. ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/20/1999 15:25'! extent: aPoint "Force rebuild when re-sized." super extent: aPoint. score ifNotNil: [self updateLowestNote]. self rebuildFromScore. ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 9/11/1998 09:33'! fullBounds "Overridden to clip submorph hit detection to my bounds." fullBounds ifNil: [fullBounds _ bounds]. ^ bounds ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 9/11/1998 09:20'! layoutChanged "Override this to avoid propagating 'layoutChanged' when just adding/removing note objects." fullBounds = bounds ifTrue: [^ self]. super layoutChanged. ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 6/15/1999 14:48'! midiKeyForY: y ^ lowestNote - ((y - (bounds bottom - borderWidth - 4)) // 3) ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:35'! timeForX: aNumber ^ ((aNumber - bounds left - borderWidth) asFloat / timeScale + leftEdgeTime) asInteger! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'di 8/3/1998 21:29'! xForTime: aNumber ^ ((aNumber - leftEdgeTime) asFloat * timeScale) asInteger + bounds left + borderWidth ! ! !PianoRollScoreMorph methodsFor: 'geometry' stamp: 'jm 7/10/1998 14:35'! yForMidiKey: midiKey ^ (bounds bottom - borderWidth - 4) - (3 * (midiKey - lowestNote)) ! ! !PianoRollScoreMorph methodsFor: 'submorphs-add/remove' stamp: 'jm 10/30/2002 18:32'! addNotes | visibleMorphs rightEdge topEdge track trackColor i done n nLeft nTop nRight | visibleMorphs _ OrderedCollection new: 500. rightEdge _ self right - borderWidth. topEdge _ self top + borderWidth + 1. 1 to: score tracks size do: [:trackIndex | track _ score tracks at: trackIndex. trackColor _ colorForTrack at: trackIndex. i _ indexInTrack at: trackIndex. done _ i > track size or: [scorePlayer mutedForTrack: trackIndex]. [done | (i > track size)] whileFalse: [ n _ track at: i. (n isNoteEvent and: [n midiKey >= lowestNote]) ifTrue: [ nLeft _ self xForTime: n time. nLeft > rightEdge ifTrue: [done _ true] ifFalse: [ nTop _ (self yForMidiKey: n midiKey) - 1. nTop > topEdge ifTrue: [ nRight _ nLeft + (n duration * timeScale) truncated - 1. visibleMorphs add: ((PianoRollNoteMorph newBounds: (nLeft@nTop corner: nRight@(nTop + 3)) color: trackColor) trackIndex: trackIndex indexInTrack: i)]]]. i _ i + 1]. (selection notNil and: [trackIndex = selection first and: [i >= selection second and: [(indexInTrack at: trackIndex) <= selection third]]]) ifTrue: [visibleMorphs do: [:vm | (vm isKindOf: PianoRollNoteMorph) ifTrue: [vm selectFrom: selection]] ]. ]. "Add the cursor morph in front of all notes." cursor ifNil: [ "create the cursor if needed; this is for legacy PianoRollScoreMorphs..." cursor _ Morph newBounds: (self topLeft extent: 1@1) "height and position are set later" color: Color red]. visibleMorphs addFirst: cursor. self changed. self removeAllMorphs. self addAllMorphs: visibleMorphs. ! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/17/1999 12:40'! handlesMouseDown: evt ^ true! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 09:02'! mouseDown: evt | noteMorphs chordRect sound | (self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 2@30)) isEmpty ifTrue: ["If not near a note, then put up score edit menu" ^ self invokeScoreMenu: evt]. "Clicked near (but not on) a note, so play all notes at the cursor time" noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height). chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1. soundsPlayingMorph _ Morph newBounds: chordRect color: Color green. self addMorphBack: soundsPlayingMorph. soundsPlaying _ IdentityDictionary new. noteMorphs do: [:m | sound _ m soundOfDuration: 999.0. soundsPlaying at: m put: sound. sound play]. ! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/19/1999 09:02'! mouseMove: evt | noteMorphs chordRect sound | soundsPlaying ifNil: [^ self]. self autoScrollForX: evt cursorPoint x. "Play all notes at the cursor time" noteMorphs _ self notesInRect: ((evt cursorPoint extent: 1@0) expandBy: 0@self height). chordRect _ (self innerBounds withLeft: evt cursorPoint x) withWidth: 1. soundsPlayingMorph delete. soundsPlayingMorph _ Morph newBounds: chordRect color: Color green. self addMorphBack: soundsPlayingMorph. noteMorphs do: [:m | "Add any new sounds" (soundsPlaying includesKey: m) ifFalse: [sound _ m soundOfDuration: 999.0. soundsPlaying at: m put: sound. sound play]]. soundsPlaying keys do: [:m | "Remove any sounds no longer in selection." (noteMorphs includes: m) ifFalse: [(soundsPlaying at: m) stopGracefully. soundsPlaying removeKey: m]]. ! ! !PianoRollScoreMorph methodsFor: 'event handling' stamp: 'di 6/18/1999 08:37'! mouseUp: evt soundsPlayingMorph ifNotNil: [soundsPlayingMorph delete]. soundsPlaying ifNotNil: [soundsPlaying do: [:s | s stopGracefully]]. soundsPlayingMorph _ soundsPlaying _ nil ! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'jm 2/4/2003 13:34'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'expand time' action: #expandTime. aCustomMenu add: 'contract time' action: #contractTime. (self valueOfProperty: #dragNDropEnabled) == true ifTrue: [aCustomMenu add: 'close drag and drop' action: #toggleDragNDrop] ifFalse: [aCustomMenu add: 'open drag and drop' action: #toggleDragNDrop]. ! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/18/1999 15:55'! addKeyboard (KeyboardMorphForInput new pianoRoll: self) openInWorld! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/18/1999 16:04'! beatLinesOnOff showBeatLines _ showBeatLines not. self changed! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/20/1999 23:34'! invokeScoreMenu: evt "Invoke the score's edit menu." | menu subMenu | menu _ MenuMorph new defaultTarget: self. menu addList: #(('cut' cutSelection) ('copy' copySelection) ('paste' insertSelection) ('paste...' insertTransposed)). menu addLine. menu addList: #(('legato' selectionBeLegato) ('staccato' selectionBeStaccato) ('normal' selectionBeNormal)). menu addLine. menu addList: #(('expand time' expandTime) ('contract time' contractTime)). menu addLine. subMenu _ MenuMorph new defaultTarget: self. (2 to: 12) do: [:i | subMenu add: i printString selector: #beatsPerMeasure: argument: i]. menu add: 'time ', beatsPerMeasure printString subMenu: subMenu. subMenu _ MenuMorph new defaultTarget: self. #(2 4 8) do: [:i | subMenu add: i printString selector: #notePerBeat: argument: i]. menu add: 'sig ', notePerBeat printString subMenu: subMenu. menu addLine. showMeasureLines ifTrue: [menu add: 'hide measure lines' action: #measureLinesOnOff] ifFalse: [menu add: 'show measure lines' action: #measureLinesOnOff]. showBeatLines ifTrue: [menu add: 'hide beat lines' action: #beatLinesOnOff] ifFalse: [menu add: 'show beat lines' action: #beatLinesOnOff]. menu addLine. menu add: 'add keyboard' action: #addKeyboard. evt hand invokeMenu: menu event: evt. ! ! !PianoRollScoreMorph methodsFor: 'menu' stamp: 'di 6/17/1999 22:10'! measureLinesOnOff showMeasureLines _ showMeasureLines not. self changed! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 23:16'! appendEvent: noteEvent fullDuration: fullDuration | sel x | score appendEvent: noteEvent fullDuration: fullDuration at: (sel _ self selection). noteEvent midiKey = -1 ifFalse: "Unless it is a rest..." ["Advance the selection to the note just entered" selection _ Array with: sel first with: sel third + 1 with: sel third + 1]. "This is all horribly inefficient..." scorePlayer updateDuration. (x _ self xForTime: noteEvent endTime) > (self right - 30) ifTrue: [self autoScrollForX: x + (30 + self width // 4)]. self updateLowestNote. self rebuildFromScore! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/17/1999 12:58'! copySelection selection == nil ifTrue: [^ self]. NotePasteBuffer _ (score tracks at: selection first) copyFrom: selection second to: selection third! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 00:25'! cutSelection selection == nil ifTrue: [^ self]. self copySelection. self deleteSelection! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'jm 10/11/2002 06:30'! deleteSelection | selMorphs priorEvent x | (selection == nil or: [selection second = 0]) ifTrue: [^ self]. score cutSelection: selection. selection second > 1 ifTrue: [selection at: 2 put: selection second - 1. selection at: 3 put: selection second. priorEvent _ (score tracks at: selection first) at: selection second. (x _ self xForTime: priorEvent time) < (self left + 30) ifTrue: [self autoScrollForX: x - (30 + self width // 4)]] ifFalse: [selection _ nil]. scorePlayer updateDuration. self rebuildFromScore. selMorphs _ self submorphs select: [:m | (m isKindOf: PianoRollNoteMorph) and: [m selected]]. selMorphs isEmpty ifFalse: [(selMorphs last noteOfDuration: 0.3) play] ! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/21/1999 10:49'! insertSelection self selection == nil ifTrue: [^ self]. score insertEvents: NotePasteBuffer at: self selection. scorePlayer updateDuration. self rebuildFromScore ! ! !PianoRollScoreMorph methodsFor: 'editing' stamp: 'di 6/20/1999 23:37'! insertTransposed | delta transposedNotes | (delta _ (SelectionMenu selections: ((12 to: -12 by: -1) collect: [:i | i printString])) startUpWithCaption: 'offset...') ifNil: [^ self]. transposedNotes _ NotePasteBuffer collect: [:note | note copy midiKey: note midiKey + delta]. selection == nil ifTrue: [^ self]. score insertEvents: transposedNotes at: self selection. scorePlayer updateDuration. self rebuildFromScore! ! !PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/19/1999 10:56'! autoScrollForX: x "Scroll by the amount x lies outside of my innerBounds. Return true if this happens." | d ticks | ((d _ x - self innerBounds right) > 0 or: [(d _ x - self innerBounds left) < 0]) ifTrue: [ticks _ (self timeForX: self bounds center x + d+1) min: score durationInTicks max: 0. self moveCursorToTime: ticks. scorePlayer ticksSinceStart: ticks. ^ true]. ^ false ! ! !PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/19/1999 09:30'! goToTime: scoreTime | track trackSize index newLeftEdgeTime | newLeftEdgeTime _ scoreTime asInteger. newLeftEdgeTime < leftEdgeTime ifTrue: [indexInTrack _ Array new: score tracks size+1 withAll: 1]. leftEdgeTime _ newLeftEdgeTime. 1 to: score tracks size do: [:trackIndex | track _ score tracks at: trackIndex. index _ indexInTrack at: trackIndex. trackSize _ track size. [(index < trackSize) and: [(track at: index) endTime < leftEdgeTime]] whileTrue: [index _ index + 1]. indexInTrack at: trackIndex put: index]. self addNotes. ! ! !PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'di 6/19/1999 09:29'! moveCursorToTime: scoreTime | cursorOffset desiredCursorHeight | scorePlayer isPlaying ifTrue: [cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger. (cursorOffset < 0 or: [cursorOffset > (self width-20)]) ifTrue: [self goToTime: scoreTime - (20/timeScale). cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger]] ifFalse: [self goToTime: scoreTime - (self width//2 / timeScale). cursorOffset _ ((scoreTime - leftEdgeTime) asFloat * timeScale) asInteger]. cursor position: (self left + borderWidth + cursorOffset)@(self top + borderWidth). desiredCursorHeight _ self height. cursor height ~= desiredCursorHeight ifTrue: [cursor extent: 1@desiredCursorHeight]. ! ! !PianoRollScoreMorph methodsFor: 'scrolling' stamp: 'jm 10/11/2002 06:31'! notesInRect: timeSlice ^ self submorphs select: [:m | (timeSlice intersects: m bounds) and: [m isKindOf: PianoRollNoteMorph]] ! ! !PianoRollScoreMorph methodsFor: 'stepping' stamp: 'jm 5/30/1999 18:01'! step | t | score ifNil: [^ self]. lastMutedState ~= scorePlayer mutedState ifTrue: [ self rebuildFromScore. lastMutedState _ scorePlayer mutedState copy]. t _ scorePlayer ticksSinceStart. t = lastUpdateTick ifFalse: [ self moveCursorToTime: t. lastUpdateTick _ t]. ! ! !PianoRollScoreMorph methodsFor: 'stepping' stamp: 'jm 6/1/1998 09:07'! stepTime ^ 0 ! ! !PianoRollScoreMorph methodsFor: 'as yet unclassified' stamp: 'ar 5/29/1999 05:03'! drawSubmorphsOn: aCanvas aCanvas clipBy: self innerBounds during:[:clippedCanvas| super drawSubmorphsOn: clippedCanvas].! ! !PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! bend ^ bend ! ! !PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! bend: midiPitchBend bend _ midiPitchBend. ! ! !PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! bend: midiPitchBend channel: midiChannel bend _ midiPitchBend. channel _ midiChannel. ! ! !PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel ^ channel ! ! !PitchBendEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel: midiChannel channel _ midiChannel. ! ! !PitchBendEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:45'! isPitchBend ^ true ! ! !PitchBendEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! outputOnMidiPort: aMidiPort "Output this event to the given MIDI port." aMidiPort midiCmd: 16rE0 channel: channel byte: (bend bitAnd: 16r7F) byte: (bend bitShift: -7). ! ! !PitchBendEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 09:42'! printOn: aStream aStream nextPut: $(. time printOn: aStream. aStream nextPutAll: ': bend '. bend printOn: aStream. aStream nextPut: $). ! ! !PluckedSound methodsFor: 'initialization' stamp: 'jm 7/6/1998 17:09'! setPitch: pitchNameOrNumber dur: d loudness: vol | p sz | super setPitch: pitchNameOrNumber dur: d loudness: vol. p _ self nameOrNumberToPitch: pitchNameOrNumber. initialCount _ (d * self samplingRate asFloat) asInteger. ring _ SoundBuffer newMonoSampleCount: (((2.0 * self samplingRate) / p) asInteger max: 2). sz _ ring monoSampleCount. scaledIndexLimit _ (sz + 1) * ScaleFactor. scaledIndexIncr _ (p * sz * ScaleFactor) // (2.0 * self samplingRate). self reset. ! ! !PluckedSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'! duration "Answer the duration of this sound in seconds." ^ initialCount asFloat / self samplingRate ! ! !PluckedSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:40'! duration: seconds super duration: seconds. count _ initialCount _ (seconds * self samplingRate) rounded. ! ! !PluckedSound methodsFor: 'sound generation' stamp: 'jm 9/8/1998 16:18'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol "The Karplus-Strong plucked string algorithm: start with a buffer full of random noise and repeatedly play the contents of that buffer while averaging adjacent samples. High harmonics damp out more quickly, transfering their energy to lower ones. The length of the buffer corresponds to the length of the string." "(PluckedSound pitch: 220.0 dur: 6.0 loudness: 0.8) play" | lastIndex scaledThisIndex scaledNextIndex average sample i s | <primitive: 181> self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. self var: #ring declareC: 'short int *ring'. lastIndex _ (startIndex + n) - 1. scaledThisIndex _ scaledNextIndex _ scaledIndex. startIndex to: lastIndex do: [:sliceIndex | scaledNextIndex _ scaledThisIndex + scaledIndexIncr. scaledNextIndex >= scaledIndexLimit ifTrue: [scaledNextIndex _ ScaleFactor + (scaledNextIndex - scaledIndexLimit)]. average _ ((ring at: scaledThisIndex // ScaleFactor) + (ring at: scaledNextIndex // ScaleFactor)) // 2. ring at: scaledThisIndex // ScaleFactor put: average. sample _ (average * scaledVol) // ScaleFactor. "scale by volume" scaledThisIndex _ scaledNextIndex. 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]. 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]]]. scaledIndex _ scaledNextIndex. count _ count - n. ! ! !PluckedSound methodsFor: 'sound generation' stamp: 'jm 9/9/1998 21:58'! stopAfterMSecs: mSecs "Terminate this sound this note after the given number of milliseconds." count _ (mSecs * self samplingRate) // 1000. ! ! !PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:49'! controlInitialize "Provide feedback indicating that button has been entered with the mouse down. If triggerOnMouseDown is true, then do the button action on mouse down--and don't bother with the feedback since the action happens immediately." sensor anyButtonPressed ifFalse: [^ self]. view triggerOnMouseDown ifTrue: [sensor yellowButtonPressed ifTrue: [self yellowButtonActivity] ifFalse: [view performAction]] ifFalse: [view toggleMouseOverFeedback. shownAsComplemented _ true]! ! !PluggableButtonController methodsFor: 'basic control sequence' stamp: 'acg 3/13/2000 08:44'! controlTerminate "Reverse the feedback displayed by controlInitialize, if any. Perform the button action if necessary." view ifNotNil: [view triggerOnMouseDown ifFalse: [shownAsComplemented ifTrue: [view toggleMouseOverFeedback]. self viewHasCursor ifTrue: [view performAction]]]! ! !PluggableButtonController methodsFor: 'control defaults' stamp: 'sma 5/28/2000 16:29'! controlActivity shownAsComplemented ifNil: [^ self]. shownAsComplemented = self viewHasCursor ifFalse: [view ifNotNil: [view toggleMouseOverFeedback]. shownAsComplemented _ shownAsComplemented not]! ! !PluggableButtonController methodsFor: 'control defaults' stamp: 'acg 3/13/2000 08:26'! isControlActive ^ sensor anyButtonPressed! ! !PluggableButtonController methodsFor: 'button activity' stamp: 'di 9/7/1999 08:44'! yellowButtonActivity "Invoke the model's menu. This is option-click, NOT the normal button press." | menu | menu _ view getMenu: false. menu == nil ifTrue: [sensor waitNoButton] ifFalse: [self terminateAndInitializeAround: [menu invokeOn: model]]. ! ! !PluggableButtonMorph methodsFor: 'accessing'! action: aSymbol "Set actionSelector to be the action defined by aSymbol." actionSelector _ aSymbol. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'sw 10/25/1999 14:36'! offColor ^ offColor ! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'di 6/26/1998 09:40'! getMenu: shiftPressed "Answer the menu for this button, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector == nil ifTrue: [^ nil]. menu _ MenuMorph new defaultTarget: model. getMenuSelector numArgs = 1 ifTrue: [^ model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^ model perform: getMenuSelector with: menu with: shiftPressed]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol' ! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'sma 6/5/2000 13:31'! invokeMenu: evt "Invoke my menu in response to the given event." | menu | menu _ self getMenu: evt shiftPressed. menu ifNotNil: [menu popUpEvent: evt]! ! !PluggableButtonMorph methodsFor: 'private' stamp: 'tk 10/30/1999 08:31'! performAction "Inform the model that this button has been pressed. Sent by the controller when this button is pressed." askBeforeChanging ifTrue: [model okToChange ifFalse: [^ self]]. actionSelector ifNotNil: [model perform: actionSelector]. ! ! !PluggableButtonMorph class methodsFor: 'instance creation'! on: anObject ^ self on: anObject getState: #isOn action: #switch ! ! !PluggableButtonView methodsFor: 'accessing' stamp: 'jrm 6/1/1998 21:53'! action: aSymbol "Set actionSelector to be the action defined by aSymbol." actionSelector _ aSymbol ! ! !PluggableButtonView methodsFor: 'accessing' stamp: 'di 5/10/1999 17:51'! label: aStringOrDisplayObject "Label this button with the given String or DisplayObject." ((aStringOrDisplayObject isKindOf: Paragraph) or: [aStringOrDisplayObject isKindOf: Form]) ifTrue: [label _ aStringOrDisplayObject] ifFalse: [label _ aStringOrDisplayObject asParagraph]. self centerLabel. ! ! !PluggableButtonView methodsFor: 'displaying' stamp: 'acg 2/23/2000 00:18'! displayView "Displays this switch and its label, if any." self clearInside. label ifNotNil: [ (label isKindOf: Paragraph) ifTrue: [ label foregroundColor: self foregroundColor backgroundColor: self backgroundColor]. label displayOn: Display at: label boundingBox topLeft clippingBox: self insetDisplayBox]. complemented _ false.! ! !PluggableButtonView methodsFor: 'displaying' stamp: 'jm 5/26/2003 01:34'! toggleMouseOverFeedback "Complement the label (or a portion of the displayBox if no label is defined) to show that the mouse is over this button. This feedback can be removed by a second call to this method." Display reverse: self insetDisplayBox. Display reverse: (self insetDisplayBox insetBy: 2). ! ! !PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:16'! centerAlignLabelWith: aPoint "Align the center of the label with aPoint." | alignPt | alignPt _ label boundingBox center. (label isKindOf: Paragraph) ifTrue: [alignPt _ alignPt + (0@(label textStyle leading))]. label align: alignPt with: aPoint ! ! !PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:10'! centerLabel "If there is a label, align its center with the center of the insetDisplayBox" label ifNotNil: [self centerAlignLabelWith: self insetDisplayBox center]. ! ! !PluggableButtonView methodsFor: 'private' stamp: 'di 6/26/1998 11:04'! getMenu: shiftKeyDown "Answer the menu for this view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector == nil ifTrue: [^ nil]. menu _ CustomMenu new. getMenuSelector numArgs = 1 ifTrue: [^ model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol' ! ! !PluggableButtonView methodsFor: 'private' stamp: 'acg 2/23/2000 00:09'! insetDisplayBox "Answer the receiver's inset display box. The inset display box is the intersection of the receiver's window, tranformed to display coordinates, and the inset display box of the superView, inset by the border width. The inset display box represents the region of the display screen in which the inside of the receiver (all except the border) is displayed. If the receiver is totally clipped by the display screen and its superView, the resulting Rectangle will be invalid." insetDisplayBox ifNil: [insetDisplayBox _ self computeInsetDisplayBox. self centerLabel]. ^insetDisplayBox! ! !PluggableButtonView class methodsFor: 'instance creation' stamp: 'jm 8/14/1998 16:19'! on: anObject ^ self on: anObject getState: #isOn action: #switch ! ! Class PluggableDictionary allows the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the dictionary. See the class comment of PluggableSet for an example. Instance variables: hashBlock <BlockContext> A one argument block used for hashing the elements. equalBlock <BlockContext> A two argument block used for comparing the elements. ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! equalBlock: aBlock "Set a new equality block. The block must accept two arguments and return true if the argumets are considered to be equal, false otherwise" equalBlock _ aBlock.! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! hashBlock "Return the block used for hashing the elements in the receiver." ^hashBlock! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:46'! hashBlock: aBlock "Set a new hash block. The block must accept one argument and must return the hash value of the given argument." hashBlock _ aBlock.! ! !PluggableDictionary methodsFor: 'accessing' stamp: 'ar 11/20/1998 16:24'! keys "Answer a Set containing the receiver's keys." | aSet | aSet _ PluggableSet new: self size. aSet equalBlock: self equalBlock fixTemps. aSet hashBlock: self hashBlock fixTemps. self keysDo: [:key | aSet add: key]. ^ aSet! ! !PluggableDictionary methodsFor: 'copying' stamp: 'ar 11/12/1998 18:48'! copy ^super copy postCopyBlocks! ! !PluggableDictionary methodsFor: 'copying' stamp: 'ar 11/12/1998 18:48'! postCopyBlocks hashBlock _ hashBlock copy. equalBlock _ equalBlock copy. "Fix temps in case we're referring to outside stuff" hashBlock fixTemps. equalBlock fixTemps.! ! !PluggableDictionary methodsFor: 'private' stamp: 'ar 11/12/1998 18:45'! init: n super init: n. hashBlock _ [:element| element hash]. equalBlock _ [:element1 :element2| element1 = element2].! ! !PluggableDictionary methodsFor: 'private' stamp: 'ar 11/20/1998 16:08'! 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 _ ((hashBlock value: anObject) \\ 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: [ equalBlock value: element key value: anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [ equalBlock value: element key value: anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'di 6/12/2000 22:13'! integerDictionary "A stopgap, until we get the pluggable init code." ^ Dictionary new: 500! ! I am a model for a modal dialog akin to "Standard File Services" on various modern GUI operating systems. My protocol includes some methods to maintain upward compatibility with StandardFileMenu, which I hope to replace. Sample doIts: "StandardFileDialog getFolder"-- ask user to select folder, answer corresponding FileDirectory "StandardFileDialog getFile" -- ask user to select file, answer corresponding FileStream "StandardFileDialog putFile" -- ask user to create new file, answer FileStream In addition to the instance variables inhereted from FileList, of which I am a subclass, I am pluggable via the following instance variables: prompt <String> Display a prompt between the buttons. resultBlock <BlockContext> Passed a file directory and a file name, answer the result to be answered by the dialog. canAcceptBlock <BlockContext> Answer whether the accept button should be "active" fileFilterBlock <BlockContext> Passed a file directory entry, answer whether the entry should be added to the list. The list can be further filtered (but not expanded) by the user through the pattern. validateBlock <BlockContent> Passed a file directory entry, a file name and a collection of newly created files, answer whether the dialog selection is valid. validateBlock is checked after the user has pressed accept, for example to ask if the user really meant to delete a file. newFiles <OrderedCollection> newFiles is an OrderedCollection of fileNames of files added by the user to the current directory since the user last entered same! !PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/12/2000 14:52'! initialize prompt _ 'Select File'. directory _ FileDirectory default. newFiles _ OrderedCollection new. fileFilterBlock _ PluggableFileList allFilesAndFoldersFileFilter. canAcceptBlock _ PluggableFileList fileNameSelectedAcceptBlock. resultBlock _ PluggableFileList pathNameResultBlock. validateBlock _ PluggableFileList checkExistingFileValidateBlock. ! ! !PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/9/2000 01:28'! open ^self openLabel: directory pathName! ! !PluggableFileList methodsFor: 'initialize-release' stamp: 'di 8/16/2000 16:33'! openAsMorphLabel: aString inWorld: aWorld "Open a view of an instance of me." "PluggableFileList new openAsMorphLabel: 'foo' inWorld: World" | windowMorph volListMorph templateMorph fileListMorph leftButtonMorph middleButtonMorph rightButtonMorph | self directory: directory. windowMorph _ (SystemWindow labelled: aString) model: self. volListMorph _ PluggableListMorph on: self list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:. volListMorph autoDeselect: false. windowMorph addMorph: volListMorph frame: (0@0 corner: 0.4@0.5625). templateMorph _ PluggableTextMorph on: self text: #pattern accept: #pattern:. templateMorph askBeforeDiscardingEdits: false. windowMorph addMorph: templateMorph frame: (0@0.5625 corner: 0.4@0.75). fileListMorph _ PluggableListMorph on: self list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. windowMorph addMorph: fileListMorph frame: (0.4@0 corner: 1.0@0.75). leftButtonMorph _ PluggableButtonMorph on: self getState: #leftButtonState action: #leftButtonPressed. leftButtonMorph label: 'Cancel'; onColor: Color red offColor: Color red; feedbackColor: Color orange; borderWidth: 3. middleButtonMorph _ PluggableButtonMorph on: self getState: nil action: nil. middleButtonMorph label: prompt; onColor: Color lightYellow offColor: Color lightYellow; feedbackColor: Color lightYellow; borderWidth: 1. rightButtonMorph _ PluggableButtonMorph on: self getState: #rightButtonState action: #rightButtonPressed. rightButtonMorph label: 'Accept'; onColor: Color green offColor: Color lightYellow; feedbackColor: Color black; borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]). "self canAccept ifFalse: [rightButtonMorph controller: NoController new]." windowMorph addMorph: leftButtonMorph frame: (0@0.75 corner: 0.25@1.0); addMorph: middleButtonMorph frame: (0.25@0.75 corner: 0.75@1.0); addMorph: rightButtonMorph frame: (0.75@0.75 corner: 1.0@1.0). self changed: #getSelectionSel. windowMorph openInWorld ! ! !PluggableFileList methodsFor: 'initialize-release' stamp: 'acg 2/19/2000 01:10'! openLabel: aString "Open a view of an instance of me." "StandardFileDialog new open" | topView volListView templateView fileListView fileStringView leftButtonView middleButtonView rightButtonView | self directory: directory. topView _ (PluggableFileListView new) model: self. volListView _ PluggableListView on: self list: #volumeList selected: #volumeListIndex changeSelected: #volumeListIndex: menu: #volumeMenu:. volListView autoDeselect: false. volListView window: (0@0 extent: 80@45). topView addSubView: volListView. templateView _ PluggableTextView on: self text: #pattern accept: #pattern:. templateView askBeforeDiscardingEdits: false. templateView window: (0@0 extent: 80@15). topView addSubView: templateView below: volListView. fileListView _ PluggableListView on: self list: #fileList selected: #fileListIndex changeSelected: #fileListIndex: menu: #fileListMenu:. fileListView window: (0@0 extent: 120@60). topView addSubView: fileListView toRightOf: volListView. fileListView controller terminateDuringSelect: true. "Pane to left may change under scrollbar" "fileStringView _ PluggableTextView on: self text: #fileString accept: #fileString:. fileStringView askBeforeDiscardingEdits: false. fileStringView window: (0@0 extent: 200@15). topView addSubView: fileStringView below: templateView." fileStringView _ templateView. leftButtonView _ PluggableButtonView on: self getState: nil action: #leftButtonPressed. leftButtonView label: 'Cancel'; backgroundColor: Color red; borderWidth: 3; window: (0@0 extent: 50@15). middleButtonView _ PluggableButtonView on: self getState: nil action: nil. middleButtonView label: prompt; window: (0@0 extent: 100@15); borderWidth: 1; controller: NoController new. rightButtonView _ PluggableButtonView on: self getState: nil action: #rightButtonPressed. rightButtonView label: 'Accept'; backgroundColor: (self canAccept ifTrue: [Color green] ifFalse: [Color lightYellow]); borderWidth: (self canAccept ifTrue: [3] ifFalse: [1]); window: (0@0 extent: 50@15). self canAccept ifFalse: [rightButtonView controller: NoController new]. topView acceptButtonView: rightButtonView. topView addSubView: leftButtonView below: fileStringView; addSubView: middleButtonView toRightOf: leftButtonView; addSubView: rightButtonView toRightOf: middleButtonView. self changed: #getSelectionSel. topView doModalDialog. ^self result ! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:33'! beAccepted ^accepted _ true! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 09:10'! canAccept ^canAcceptBlock value: directory value: fileName! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:52'! canAcceptBlock: aBlock ^canAcceptBlock _ aBlock! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 07:33'! fileFilterBlock: aBlock ^fileFilterBlock _ aBlock! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'! fileListIndex self changed: #fileString. ^super fileListIndex! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/18/2000 21:21'! fileVolumeIndex self changed: #fileString. ^super fileVolumeIndex! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:28'! prompt: aString prompt _ aString! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/9/2000 00:31'! resultBlock: aBlock ^resultBlock _ aBlock! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/13/2000 15:28'! validate ^validateBlock value: directory value: fileName value: newFiles! ! !PluggableFileList methodsFor: 'accessing' stamp: 'acg 2/10/2000 08:02'! validateBlock: aBlock ^validateBlock _ aBlock! ! !PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 01:05'! leftButtonPressed accepted _ false. self changed: #close. ! ! !PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:40'! leftButtonState ^true! ! !PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/9/2000 00:38'! result accepted ifFalse: [^nil]. ^resultBlock value: directory value: fileName! ! !PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/10/2000 07:58'! rightButtonPressed (canAcceptBlock value: directory value: fileName) ifFalse: [^nil]. (validateBlock value: directory value: fileName value: newFiles) ifFalse: [^nil]. accepted _ true. self changed: #close! ! !PluggableFileList methodsFor: 'accepting/cancelling' stamp: 'acg 2/14/2000 22:43'! rightButtonState ^self canAccept! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/10/2000 07:47'! addNew: aString byEvaluating: aBlock "A parameterization of earlier versions of #addNewDirectory and #addNewFile. Fixes the bug in each that pushing the cancel button in the FillInTheBlank dialog gave a walkback." | response newName index ending | self okToChange ifFalse: [^ self]. (response _ FillInTheBlank request: 'New ',aString,' Name?' initialAnswer: aString,'Name') isEmpty ifTrue: [^ self]. newName _ response asFileName. Cursor wait showWhile: [ aBlock value: newName]. self updateFileList. index _ list indexOf: newName. index = 0 ifTrue: [ending _ ') ',newName. index _ list findFirst: [:line | line endsWith: ending]]. self fileListIndex: index. newFiles add: newName ! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:57'! fileSelectedMenu: aMenu | firstItems secondItems thirdItems n1 n2 n3 | firstItems _ self itemsForFileEnding: self fileNameSuffix asLowercase. secondItems _ self itemsForAnyFile. thirdItems _ self itemsForNoFile. n1 _ firstItems first size. n2 _ n1 + secondItems first size. n3 _ n2 + thirdItems first size. ^ aMenu labels: firstItems first , secondItems first , thirdItems first lines: firstItems second , (Array with: n1 with: n2) , (thirdItems second collect: [:n | n + n2]) , (Array with: n3) selections: firstItems third , secondItems third , thirdItems third! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:49'! itemsForFileEnding: suffix | labels lines selectors | labels _ OrderedCollection new. lines _ OrderedCollection new. selectors _ OrderedCollection new. ^ Array with: labels with: lines with: selectors! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'acg 2/9/2000 07:50'! itemsForNoFile ^ #( ('sort by name' 'sort by size' 'sort by date' 'add new file' 'add new directory') (3) (sortByName sortBySize sortByDate addNewFile addNewDirectory) )! ! !PluggableFileList methodsFor: 'file list menu' stamp: 'jm 5/23/2003 13:23'! listForPattern: pat "Make the list be those file names which match the pattern." | entries sizePad newList allFiles sortBlock | entries _ directory entries select: fileFilterBlock. sizePad _ (entries inject: 0 into: [:mx :entry | mx max: (entry at: 5)]) asStringWithCommas size - 1. "create block to decide what order to display the entries" sortBlock _ [ :x :y | (x isDirectory = y isDirectory) ifTrue: [ "sort by user-specified criterion" sortMode = #name ifTrue: [(x name compare: y name) <= 2] ifFalse: [ sortMode = #date ifTrue: [ x modificationTime = y modificationTime ifTrue: [ (x name compare: y name) <= 2 ] ifFalse: [ x modificationTime > y modificationTime ] ] ifFalse: [ "size" x fileSize = y fileSize ifTrue: [ (x name compare: y name) <= 2 ] ifFalse: [ x fileSize > y fileSize ] ] ] ] ifFalse: [ "directories always precede files" x isDirectory ] ]. newList _ (SortedCollection new: 30) sortBlock: sortBlock. allFiles _ pat = '*'. entries do: [:entry | "<dirflag><name><creationTime><modificationTime><fileSize>" (allFiles or: [entry isDirectory or: [pat match: entry first]]) ifTrue: [newList add: entry]]. newList _ newList collect: [:e | self fileNameFormattedFrom: e sizePad: sizePad]. newFiles _ OrderedCollection new. ^ newList asArray ! ! !PluggableFileList methodsFor: 'file string' stamp: 'acg 2/18/2000 21:23'! fileString fileName ifNil: [^directory pathName]. ^directory fullNameFor: fileName! ! !PluggableFileList methodsFor: 'file string' stamp: 'acg 2/19/2000 01:02'! fileString: aString "| textName index ending | textName _ aString asString. (FileDirectory default fileExists: textName) ifTrue: [self directory: (FileDirectory forFileName: textName). index _ list indexOf: (FileDirectory localNameFor: textName). index = 0 ifTrue: [ending _ ') ', (FileDirectory localNameFor: textName). index _ list findFirst: [:line | line endsWith: ending]]. self fileListIndex: index]. (FileDirectory default directoryExists: textName) ifTrue: [self directory: (FileDirectory on: textName)]." self changed: #fileString. self changed: #contents. ^true! ! !PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'sma 4/30/2000 10:05'! startUpWithCaption: captionOrNil "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." ^ self startUpWithCaption: captionOrNil at: (Smalltalk isMorphic ifTrue: [World cursorPoint] ifFalse: [Sensor cursorPoint])! ! !PluggableFileList methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:35'! startUpWithCaption: aString at: location self prompt: aString. ^self open! ! !PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'! getFilePathNameDialog ^(self new) validateBlock: PluggableFileList alwaysValidateBlock; yourself! ! !PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'! getFilePathNameDialogWithExistenceCheck ^(self new) prompt: 'Select New File:'; validateBlock: PluggableFileList checkExistingFileValidateBlock; yourself! ! !PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/12/2000 14:52'! getFolderDialog ^(self new) prompt: 'Select a Folder'; fileFilterBlock: PluggableFileList allFoldersFileFilter; canAcceptBlock: PluggableFileList alwaysAcceptBlock; resultBlock: PluggableFileList directoryResultBlock; validateBlock: PluggableFileList alwaysValidateBlock; yourself! ! !PluggableFileList class methodsFor: 'instance creation' stamp: 'acg 2/9/2000 00:34'! open ^self new open! ! !PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:24'! getFile | result | result _ self getFilePathName. ^result ifNotNil: [FileStream oldFileNamed: result]! ! !PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:31'! getFilePathName ^self getFilePathNameDialog open! ! !PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'! getFilePathNameWithExistenceCheck ^self getFilePathNameDialogWithExistenceCheck open! ! !PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/9/2000 01:16'! getFolder ^self getFolderDialog open! ! !PluggableFileList class methodsFor: 'standard dialog operations' stamp: 'acg 2/10/2000 08:29'! putFile | result | result _ self getFilePathNameWithExistenceCheck. ^result ifNotNil: [FileDirectory deleteFilePath: result. FileStream newFileNamed: result]! ! !PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:19'! directoryResultBlock ^[:theDirectory :theFileName | theDirectory]! ! !PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'! fileNameResultBlock ^[:theDirectory :theFileName | theFileName]! ! !PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/10/2000 08:07'! pathNameResultBlock ^[:theDirectory :theFileName | theFileName ifNil: [theDirectory pathName] ifNotNil: [theDirectory fullNameFor: theFileName]]. ! ! !PluggableFileList class methodsFor: 'resultBlocks' stamp: 'acg 2/12/2000 15:08'! sfmResultBlock ^[:theDirectory :theFileName | StandardFileMenuResult directory: theDirectory name: theFileName]! ! !PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:18'! alwaysAcceptBlock ^[:theDirectory :theFileName | true]! ! !PluggableFileList class methodsFor: 'canAcceptBlocks' stamp: 'acg 2/10/2000 08:10'! fileNameSelectedAcceptBlock ^[:theDirectory :theFileName | theFileName isNil not]! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 08:27'! alwaysValidateBlock ^[:theDirectory :theFileName :theNewFiles | true].! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'! checkExistingFileValidateBlock ^[:theDirectory :theFileName :theNewFiles | (theNewFiles includes: theFileName) or: [(PluggableFileList okToOverwrite: theFileName)]].! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/12/2000 14:52'! existingFileValidateBlock ^[:theDirectory :theFileName :theNewFiles | (theNewFiles includes: theFileName) or: [(PluggableFileList okToOverwrite: theFileName)]].! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 08:05'! okToOpen: aFileNameString without: aSuffixString "Answer whether user confirms that it is ok to overwrite the file named in aString" ^ 1 = ((PopUpMenu labels: 'overwrite that file select another file') startUpWithCaption: aFileNameString, ' already exists.') ! ! !PluggableFileList class methodsFor: 'validateBlocks' stamp: 'acg 2/10/2000 07:55'! okToOverwrite: aString "Answer whether user confirms that it is ok to overwrite the file named in aString" ^ 1 = ((PopUpMenu labels: 'overwrite that file select another file') startUpWithCaption: aString, ' already exists.') ! ! !PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:16'! allFilesAndFoldersFileFilter ^[:each | true]! ! !PluggableFileList class methodsFor: 'fileFilterBlocks' stamp: 'acg 2/10/2000 08:17'! allFoldersFileFilter ^[:each | each isDirectory]! ! !PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:10'! newFileMenu: aDirectory "For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult" ^(self getFilePathNameDialogWithExistenceCheck) resultBlock: self sfmResultBlock; yourself! ! !PluggableFileList class methodsFor: 'StandardFileMenu' stamp: 'acg 2/12/2000 15:11'! oldFileMenu: aDirectory "For compatibility with StandardFileMenu for now, answer a StandardFileMenuResult" ^(self getFilePathNameDialog) resultBlock: self sfmResultBlock; yourself! ! I provide aview for PluggableFileList! !PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:57'! acceptButtonView: aView ^acceptButtonView _ aView! ! !PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/18/2000 20:52'! label: aString super label: aString. self noLabel! ! !PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 08:55'! update: aSymbol (aSymbol = #volumeListIndex or: [aSymbol = #fileListIndex]) ifTrue: [self updateAcceptButton]. ^super update: aSymbol! ! !PluggableFileListView methodsFor: 'as yet unclassified' stamp: 'acg 2/9/2000 09:40'! updateAcceptButton self model canAccept ifTrue: [acceptButtonView backgroundColor: Color green; borderWidth: 3; controller: acceptButtonView defaultController] ifFalse: [acceptButtonView backgroundColor: Color lightYellow; borderWidth: 1; controller: NoController new]. acceptButtonView display.! ! !PluggableListController methodsFor: 'initialization' stamp: 'di 5/25/1998 10:15'! initialize super initialize. self terminateDuringSelect: false! ! !PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:20'! changeModelSelection: anInteger "Let the view handle this." terminateDuringSelect ifTrue: [self controlTerminate]. view changeModelSelection: anInteger. terminateDuringSelect ifTrue: [self controlInitialize].! ! !PluggableListController methodsFor: 'private' stamp: 'sma 3/11/2000 15:38'! processKeyboard sensor keyboardPressed ifTrue: [view handleKeystroke: sensor keyboard] ifFalse: [super processKeyboard]! ! !PluggableListController methodsFor: 'private' stamp: 'di 5/25/1998 10:14'! terminateDuringSelect: trueOrFalse terminateDuringSelect _ trueOrFalse! ! !PluggableListControllerOfMany methodsFor: 'control defaults' stamp: 'tk 4/8/98 11:08'! redButtonActivity | selection firstHit turningOn lastSelection pt scrollFlag | model okToChange ifFalse: [^ self]. "Don't change selection if model refuses to unlock" firstHit _ true. scrollFlag _ false. lastSelection _ 0. [sensor redButtonPressed] whileTrue: [selection _ view findSelection: (pt _ sensor cursorPoint). selection == nil ifTrue: "Maybe out of box - check for auto-scroll" [pt y < view insetDisplayBox top ifTrue: [self scrollView: view list lineGrid. scrollFlag _ true. selection _ view firstShown]. pt y > view insetDisplayBox bottom ifTrue: [self scrollView: view list lineGrid negated. scrollFlag _ true. selection _ view lastShown]]. (selection == nil or: [selection = lastSelection]) ifFalse: [firstHit ifTrue: [firstHit _ false. turningOn _ (model listSelectionAt: selection) not]. view selection: selection. (model listSelectionAt: selection) == turningOn ifFalse: [view displaySelectionBox. model listSelectionAt: selection put: turningOn]. lastSelection _ selection]]. selection notNil ifTrue: ["Normal protocol delivers change, so unchange first (ugh)" model listSelectionAt: selection put: (model listSelectionAt: selection) not. self changeModelSelection: selection]. scrollFlag ifTrue: [self moveMarker]! ! When a PluggableListMorph is in focus, type in a letter (or several letters quickly) to go to the next item that begins with that letter. Arrow and navigation keys are also supported (up, down, home, etc.). ! !PluggableListMorph methodsFor: 'initialization' stamp: 'jm 10/12/2002 05:53'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel self color: Color white. self model: anObject. getListSelector _ getListSel. getIndexSelector _ getSelectionSel. setIndexSelector _ setSelectionSel. getMenuSelector _ getMenuSel. keystrokeActionSelector _ keyActionSel. autoDeselect _ true. self borderWidth: 1. self list: self getList. self selectionIndex: self getCurrentSelectionIndex. lastKeystrokeTime _ 0. lastKeystrokes _ ''. ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'jm 10/12/2002 05:56'! autoDeselect: aBoolean "Enable/disable autoDeselect." autoDeselect _ aBoolean. ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'jm 10/11/2002 19:32'! doubleClickSelector: aSelectorOrNil aSelectorOrNil ifNil: [doubleClickSelector _ nil] ifNotNil: [doubleClickSelector _ aSelectorOrNil asSymbol]. ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'jm 9/20/1998 17:28'! font ^ font ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'jm 9/20/1998 19:48'! font: aFontOrNil font _ aFontOrNil. self list: self getList. "update display" ! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'jm 10/12/2002 06:33'! list: listOfStrings | morphList h loc index | scroller removeAllMorphs. list _ listOfStrings ifNil: [Array new]. list isEmpty ifTrue: [self setScrollDeltas. ^ self selectedMorph: nil]. "NOTE: we will want a quick StringMorph init message, possibly even combined with event install and positioning" font ifNil: [font _ Preferences standardListFont]. morphList _ list collect: [:item | item isText ifTrue: [StringMorph contents: item font: font emphasis: (item emphasisAt: 1)] ifFalse: [StringMorph contents: item font: font]]. "Lay items out vertically and install them in the scroller" h _ morphList first height "self listItemHeight". loc _ 0@0. morphList do: [:m | m bounds: (loc extent: 9999@h). loc _ loc + (0@h)]. scroller addAllMorphs: morphList. index _ self getCurrentSelectionIndex. self selectedMorph: ((index = 0 or: [index > morphList size]) ifTrue: [nil] ifFalse: [morphList at: index]). self setScrollDeltas. scrollBar setValue: 0.0.! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'di 5/22/1998 00:32'! listItemHeight "This should be cleaned up. The list should get spaced by this parameter." ^ 12! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'ar 11/15/1998 23:45'! drawOn: aCanvas super drawOn: aCanvas. selectedMorph ifNotNil: [aCanvas fillRectangle: (((scroller transformFrom: self) localBoundsToGlobal: selectedMorph bounds) intersect: scroller bounds) color: color darker]! ! !PluggableListMorph methodsFor: 'drawing'! highlightSelection selectedMorph ifNotNil: [selectedMorph color: Color red]! ! !PluggableListMorph methodsFor: 'drawing'! unhighlightSelection selectedMorph ifNotNil: [selectedMorph color: Color black]! ! !PluggableListMorph methodsFor: 'events-mouse' stamp: 'jm 10/12/2002 05:49'! handlesMouseDown: evt ^ true ! ! !PluggableListMorph methodsFor: 'events-mouse' stamp: 'jm 10/12/2002 06:29'! mouseDown: evt | adjustedPoint hitItem | adjustedPoint _ (evt transformedBy: (scroller transformFrom: self)) cursorPoint. hitItem _ scroller submorphs detect: [:m | m containsPoint: adjustedPoint] ifNone: [^ self beep]. self mouseDown: evt onItem: hitItem. ! ! !PluggableListMorph methodsFor: 'events-mouse' stamp: 'di 6/26/1998 13:33'! mouseDown: event onItem: aMorph event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed]. model okToChange ifFalse: [^ self]. "No change if model is locked" ((autoDeselect == nil or: [autoDeselect]) and: [aMorph == selectedMorph]) ifTrue: [self setSelectedMorph: nil] ifFalse: [self setSelectedMorph: aMorph]. ! ! !PluggableListMorph methodsFor: 'events-mouse' stamp: 'jm 11/25/2002 10:46'! mouseMove: evt "Allow dragging of the selection." | adjustedPoint hitItem | evt yellowButtonPressed ifTrue: [^ self]. adjustedPoint _ (evt transformedBy: (scroller transformFrom: self)) cursorPoint. hitItem _ scroller submorphs detect: [:m | m containsPoint: adjustedPoint] ifNone: [^ self]. selectedMorph = hitItem ifFalse: [self mouseDown: evt onItem: hitItem]. ! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'JLM 10/8/1999 03:49'! basicKeyPressed: aChar | oldSelection nextSelection max milliSeconds nextSelectionList nextSelectionText | nextSelection _ oldSelection _ self getCurrentSelectionIndex. max _ self maximumSelection. milliSeconds _ Time millisecondClockValue. milliSeconds - lastKeystrokeTime > 300 ifTrue: ["just use the one current character for selecting" lastKeystrokes _ '']. lastKeystrokes _ lastKeystrokes , aChar asLowercase asString. lastKeystrokeTime _ milliSeconds. nextSelectionList _ OrderedCollection newFrom: (list copyFrom: oldSelection + 1 to: max). nextSelectionList addAll: (list copyFrom: 1 to: oldSelection). "Get rid of blanks and style used in some lists" nextSelectionText _ nextSelectionList detect: [:a | a asString withBlanksTrimmed asLowercase beginsWith: lastKeystrokes] ifNone: [^ self flash"match not found"]. model okToChange ifFalse: [^ self]. nextSelection _ list findFirst: [:a | a == nextSelectionText]. "No change if model is locked" oldSelection == nextSelection ifTrue: [^ self flash]. ^ self changeModelSelection: nextSelection! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'jm 10/12/2002 06:05'! keyStroke: event "Process the given keystroke event. Three categories of keystokes: a. special keys (ascii values < 32; includes control keys) b. modifier keys (keystroke with a modifier key such as cmd, alt, or option) c. basic (plain, ordinary keystrokes)" | char ascii | char _ event keyCharacter. ascii _ char asciiValue. ascii < 32 ifTrue: [^ self specialKeyPressed: ascii]. event anyModifierKeyPressed ifTrue: [^ self modifierKeyPressed: char]. self basicKeyPressed: char. ! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'jm 10/12/2002 06:09'! modifierKeyPressed: aChar "Ask the model to process a modifier key." | args | model ifNil: [^ self]. keystrokeActionSelector ifNil: [^ self]. args _ keystrokeActionSelector numArgs. args = 1 ifTrue: [^ model perform: keystrokeActionSelector with: aChar]. args = 2 ifTrue: [ ^ model perform: keystrokeActionSelector with: aChar with: self]. ^ self error: 'keystrokeActionSelector must be a 1- or 2-keyword symbol' ! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'jm 10/12/2002 06:43'! mouseEnter: evt "Grab keyboard focus when the mouse is over me." super mouseEnter: evt. evt hand newKeyboardFocus: self. ! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'JLM 10/8/1999 03:50'! specialKeyPressed: asciiValue | oldSelection nextSelection max howManyItemsShowing | nextSelection _ oldSelection _ self getCurrentSelectionIndex. max _ self maximumSelection. asciiValue == 31 ifTrue: [" down arrow" nextSelection _ oldSelection + 1. nextSelection > max ifTrue: [nextSelection _ 1]]. asciiValue == 30 ifTrue: [" up arrow" nextSelection _ oldSelection - 1. nextSelection < 1 ifTrue: [nextSelection _ max]]. asciiValue == 1 ifTrue: [" home" nextSelection _ 1]. asciiValue == 4 ifTrue: [" end" nextSelection _ max]. howManyItemsShowing _ self numSelectionsInView. asciiValue == 11 ifTrue: [" page up" nextSelection _ 1 max: oldSelection - howManyItemsShowing]. asciiValue == 12 ifTrue: [" page down" nextSelection _ oldSelection + howManyItemsShowing min: max]. model okToChange ifFalse: [^ self]. "No change if model is locked" oldSelection == nextSelection ifTrue: [^ self flash]. ^ self changeModelSelection: nextSelection! ! !PluggableListMorph methodsFor: 'events-keyboard' stamp: 'jm 10/12/2002 06:12'! wantsKeyboardFocusFor: aMorph "Don't allow editing of my submorphs." ^ false ! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'! getListSelector ^ getListSelector! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:21'! maximumSelection ^ list size! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'! minimumSelection ^ 1! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:32'! numSelectionsInView ^ self height // self listItemHeight! ! !PluggableListMorph methodsFor: 'selection'! selectedMorph: aMorph self unhighlightSelection. selectedMorph _ aMorph. selection _ aMorph ifNil: [nil] ifNotNil: [aMorph contents]. self highlightSelection! ! !PluggableListMorph methodsFor: 'selection'! selection ^ selection! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 11:03'! selection: item "Called from outside to request setting a new selection. Assumes scroller submorphs is exactly our list. Note: won't work right if list includes repeated items" self selectionIndex: (scroller submorphs findFirst: [:m | m contents = item])! ! !PluggableListMorph methodsFor: 'selection' stamp: 'dew 2/19/1999 18:47'! selectionIndex: index "Called internally to select the index-th item." | theMorph range | (index isNil or: [index > scroller submorphs size]) ifTrue: [^ self]. (theMorph _ index = 0 ifTrue: [nil] ifFalse: [scroller submorphs at: index]) ifNotNil: [((theMorph bounds top - scroller offset y) >= 0 and: [(theMorph bounds bottom - scroller offset y) <= bounds height]) ifFalse: ["Scroll into view -- should be elsewhere" range _ self leftoverScrollRange. scrollBar value: (range > 0 ifTrue: [((index-1 * theMorph height) / self leftoverScrollRange) truncateTo: scrollBar scrollDelta] ifFalse: [0]). scroller offset: -3 @ (range * scrollBar value)]]. self selectedMorph: theMorph! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/6/1998 21:20'! setSelectedMorph: aMorph self changeModelSelection: (scroller submorphs indexOf: aMorph)! ! !PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'! changeModelSelection: anInteger "Change the model's selected item index to be anInteger." setIndexSelector ifNotNil: [model perform: setIndexSelector with: anInteger].! ! !PluggableListMorph methodsFor: 'model access' stamp: 'di 5/6/1998 21:18'! getCurrentSelectionIndex "Answer the index of the current selection." getIndexSelector == nil ifTrue: [^ 0]. ^ model perform: getIndexSelector! ! !PluggableListMorph methodsFor: 'model access' stamp: 'jlm 10/4/1999 23:45'! getList "Answer the list to be displayed." | lst | getListSelector == nil ifTrue: [^ #()]. lst _ model perform: getListSelector. lst == nil ifTrue: [^ #()]. ^ lst! ! !PluggableListMorph methodsFor: 'updating' stamp: 'di 5/6/1998 21:21'! update: aSymbol "Refer to the comment in View|update:." aSymbol == getListSelector ifTrue: [self list: self getList. ^ self]. aSymbol == getIndexSelector ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self]. ! ! !PluggableListMorph methodsFor: 'updating'! verifyContents | newList existingSelection anIndex | "Called periodically, or at least on window reactivation to react to possible structural changes. Update contents if necessary." newList _ self getList. ((list == newList) "fastest" or: [list = newList]) ifTrue: [^ self]. self flash. "list has changed beneath us; could get annoying, but hell" existingSelection _ selection. self list: newList. (anIndex _ newList indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifNil: [self changeModelSelection: 0] ! ! !PluggableListMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:09'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled." ^ scroller firstSubmorph height ! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: nil keystroke: #arrowKey:from: "default"! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/22/1998 00:17'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: #arrowKey:from: "default" ! ! !PluggableListMorph class methodsFor: 'instance creation' stamp: 'di 5/6/1998 21:45'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel "Create a 'pluggable' list view on the given model parameterized by the given message selectors. See ListView>>aboutPluggability comment." ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel ! ! !PluggableListMorph class methodsFor: 'example' stamp: 'jm 10/12/2002 05:33'! example "PluggableListMorph example" | model listMorph | model _ PluggableTest new initialize. model musicType: 1. listMorph _ PluggableListMorph on: model list: #artistList selected: #artist changeSelected: #artist: menu: nil keystroke: #artistKeystroke:. listMorph openInWorld. ! ! !PluggableListMorphByItem methodsFor: 'as yet unclassified' stamp: 'jm 8/20/1998 09:44'! changeModelSelection: anInteger "Change the model's selected item to be the one at the given index." | item | setIndexSelector ifNotNil: [ item _ (anInteger = 0 ifTrue: [nil] ifFalse: [itemList at: anInteger]). model perform: setIndexSelector with: item]. self update: getIndexSelector. ! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'ar 11/15/1998 23:45'! drawOn: aCanvas | onMorph | super drawOn: aCanvas. 1 to: list size do: "NOTE: should be optimized to only visible morphs" [:index | (model listSelectionAt: index) ifTrue: [onMorph _ scroller submorphs at: index. aCanvas fillRectangle: (((scroller transformFrom: self) localBoundsToGlobal: onMorph bounds) intersect: scroller bounds) color: color darker]]! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'jm 10/12/2002 06:57'! list: listOfStrings scroller removeAllMorphs. list _ listOfStrings ifNil: [Array new]. list isEmpty ifTrue: [^ self selectedMorph: nil]. super list: listOfStrings. ! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 1/15/1999 01:03'! mouseDown: event onItem: aMorph | index oldIndex oldVal | event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed]. model okToChange ifFalse: [^ self]. "No change if model is locked" index _ scroller submorphs indexOf: aMorph. index = 0 ifTrue: [^ self "minimize chance of selecting with a pane border drag"]. "Set meaning for subsequent dragging of selection" dragOnOrOff _ (model listSelectionAt: index) not. oldIndex _ self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [oldVal _ model listSelectionAt: oldIndex]. "Set or clear new primary selection (listIndex)" dragOnOrOff ifTrue: [self setSelectedMorph: aMorph] ifFalse: [self setSelectedMorph: nil]. "Need to restore the old one, due to how model works, and set new one." oldIndex ~= 0 ifTrue: [model listSelectionAt: oldIndex put: oldVal]. model listSelectionAt: index put: dragOnOrOff. aMorph changed! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 1/15/1999 00:49'! mouseEnterDragging: event onItem: aMorph | index oldIndex oldVal | dragOnOrOff ifNil: [^ self "spurious drag did not start with mouseDown"]. event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed]. model okToChange ifFalse: [^ self]. "No change if model is locked" oldIndex _ self getCurrentSelectionIndex. oldIndex ~= 0 ifTrue: [oldVal _ model listSelectionAt: oldIndex]. index _ scroller submorphs indexOf: aMorph. dragOnOrOff ifTrue: [self setSelectedMorph: aMorph]. oldIndex ~= 0 ifTrue: [model listSelectionAt: oldIndex put: oldVal]. "Extend the selection with the current state of dragOnOrOff" model listSelectionAt: index put: dragOnOrOff. aMorph changed! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 14:47'! mouseUp: event onItem: aMorph dragOnOrOff _ nil. "So improperly started drags will have not effect"! ! !PluggableListMorphOfMany methodsFor: 'as yet unclassified' stamp: 'di 11/10/1998 14:44'! update: aSymbol aSymbol == #allSelections ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self changed]. ^ super update: aSymbol! ! !PluggableListView methodsFor: 'initialization' stamp: 'jm 10/12/2002 05:56'! autoDeselect: aBoolean "Enable/disable autoDeselect." autoDeselect _ aBoolean. ! ! !PluggableListView methodsFor: 'initialization' stamp: 'jm 9/20/1998 19:48'! font: aFontOrNil super font: aFontOrNil. self list: self getList. "update display" ! ! !PluggableListView methodsFor: 'initialization' stamp: 'sw 12/9/1999 18:06'! list: arrayOfStrings "Set the receivers items to be the given list of strings The instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list." ((items == arrayOfStrings) "fastest" or: [items = arrayOfStrings]) ifTrue: [^ self]. items _ arrayOfStrings. isEmpty _ arrayOfStrings isEmpty. "add top and bottom delimiters" list _ ListParagraph withArray: (Array streamContents: [:s | s nextPut: topDelimiter. arrayOfStrings do: [:item | item == nil ifFalse: [s nextPut: item]]. s nextPut: bottomDelimiter]) style: self assuredTextStyle. selection _ self getCurrentSelectionIndex. self positionList.! ! !PluggableListView methodsFor: 'initialization' stamp: 'sw 8/18/1998 12:04'! menuTitleSelector: getMenuTitleSel getMenuTitleSelector _ getMenuTitleSel! ! !PluggableListView methodsFor: 'model access' stamp: 'sw 8/18/1998 12:07'! getMenu: shiftKeyDown "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu aMenu | getMenuSelector == nil ifTrue: [^ nil]. menu _ CustomMenu new. getMenuSelector numArgs = 1 ifTrue: [aMenu _ model perform: getMenuSelector with: menu. getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)]. ^ aMenu]. getMenuSelector numArgs = 2 ifTrue: [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyDown. getMenuTitleSelector ifNotNil: [aMenu title: (model perform: getMenuTitleSelector)]. ^ aMenu]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !PluggableListView methodsFor: 'model access' stamp: 'sw 10/9/1998 08:24'! setSelectionSelectorIs: aSelector ^ aSelector == setSelectionSelector! ! !PluggableListView methodsFor: 'updating' stamp: 'di 5/25/1998 10:24'! update: aSymbol "Refer to the comment in View|update:." aSymbol == getListSelector ifTrue: [self list: self getList. self displayView. self displaySelectionBox. ^self]. aSymbol == getSelectionSelector ifTrue: [^ self moveSelectionBox: self getCurrentSelectionIndex]. ! ! !PluggableListView methodsFor: 'updating' stamp: 'sw 10/31/1999 00:04'! verifyContents | newItems existingSelection anIndex | "Called on window reactivation to react to possible structural changes. Update contents if necessary." newItems _ self getList. ((items == newItems) "fastest" or: [items = newItems]) ifTrue: [^ self]. self flash. "list has changed beneath us; could get annoying, but hell" existingSelection _ list stringAtLineNumber: (selection + 1). "account for cursed ------ row" self list: newItems. (newItems size > 0 and: [newItems first isKindOf: Symbol]) ifTrue: [existingSelection _ existingSelection asSymbol]. (anIndex _ newItems indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self update: getSelectionSelector. self topView displayEmphasized] ifNil: [self changeModelSelection: 0] ! ! !PluggableListViewByItem methodsFor: 'as yet unclassified' stamp: 'sw 12/9/1999 18:07'! list: arrayOfStrings "Set the receivers items to be the given list of strings." "Note: the instance variable 'items' holds the original list. The instance variable 'list' is a paragraph constructed from this list." itemList _ arrayOfStrings. isEmpty _ arrayOfStrings isEmpty. "add top and bottom delimiters" list _ ListParagraph withArray: (Array streamContents: [:s | s nextPut: topDelimiter. arrayOfStrings do: [:item | item == nil ifFalse: [s nextPut: item]]. s nextPut: bottomDelimiter]) style: self assuredTextStyle. selection _ self getCurrentSelectionIndex. self positionList.! ! A variant of PluggableListMorph designed specially for efficient handling of the --all-- feature in message-list panes. In order to be able *quickly* to check whether there has been an external change to the list, we cache the raw list for identity comparison (the actual list is a combination of the --all-- element and the the actual list).! !PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/18/1999 11:59'! getList "Differs from the generic in that here we obtain and cache the raw list, then cons it together with the special '-- all --' item to produce the list to be used in the browser. This special handling is done in order to avoid excessive and unnecessary reformulation of the list in the step method" getRawListSelector == nil ifTrue: ["should not happen!!" priorRawList _ nil. ^ #()]. model classListIndex = 0 ifTrue: [^ priorRawList _ Array new]. priorRawList _ model perform: getRawListSelector. ^ (Array with: ClassOrganizer allCategory), priorRawList! ! !PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/12/2002 05:54'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel self model: anObject. getListSelector _ getListSel. getIndexSelector _ getSelectionSel. setIndexSelector _ setSelectionSel. getMenuSelector _ getMenuSel. keystrokeActionSelector _ keyActionSel. autoDeselect _ true. self borderWidth: 1. getRawListSelector _ getRawSel. self list: self getList. self selectionIndex: self getCurrentSelectionIndex. lastKeystrokeTime _ 0. lastKeystrokes _ ''.! ! !PluggableMessageCategoryListMorph methodsFor: 'as yet unclassified' stamp: 'sw 10/30/1999 23:02'! verifyContents | newList existingSelection anIndex newRawList | (model editSelection == #editComment) ifTrue: [^ self]. model classListIndex = 0 ifTrue: [^ self]. newRawList _ model perform: getRawListSelector. newRawList == priorRawList ifTrue: [^ self]. "The usual case; very fast" priorRawList _ newRawList. newList _ (Array with: ClassOrganizer allCategory), priorRawList. list = newList ifTrue: [^ self]. self flash. "could get annoying, but hell" existingSelection _ selection. self list: newList. (anIndex _ newList indexOf: existingSelection ifAbsent: [nil]) ifNotNil: [model noteSelectionIndex: anIndex for: getListSelector. self selectionIndex: anIndex] ifNil: [self changeModelSelection: 0]! ! !PluggableMessageCategoryListMorph class methodsFor: 'as yet unclassified' stamp: 'sw 10/16/1999 22:39'! on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel. ^ self new on: anObject list: getListSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel getRawListSelector: getRawSel! ! PluggableSets allow the redefinition of hashing and equality by clients. This is in particular useful if the clients know about specific properties of the objects stored in the set which in turn can heavily improve the performance of sets and dictionaries. Instance variables: hashBlock <BlockContext> A one argument block used for hashing the elements. equalBlock <BlockContext> A two argument block used for comparing the elements. Example: Adding 1000 integer points in the range (0@0) to: (100@100) to a set. | rnd set max pt | set _ Set new: 1000. rnd _ Random new. max _ 100. Time millisecondsToRun:[ 1 to: 1000 do:[:i| pt _ (rnd next * max) truncated @ (rnd next * max) truncated. set add: pt. ]. ]. The above is way slow since the default hashing function of points leads to an awful lot of collisions in the set. And now the same, with a somewhat different hash function: | rnd set max pt | set _ PluggableSet new: 1000. set hashBlock:[:item| (item x bitShift: 16) + item y]. rnd _ Random new. max _ 100. Time millisecondsToRun:[ 1 to: 1000 do:[:i| pt _ (rnd next * max) truncated @ (rnd next * max) truncated. set add: pt. ]. ]. ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/27/1998 23:55'! equalBlock: aBlock "Set a new equality block. The block must accept two arguments and return true if the argumets are considered equal, false otherwise" equalBlock _ aBlock.! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 18:43'! hashBlock "Return the block used for hashing the elements in the receiver." ^hashBlock! ! !PluggableSet methodsFor: 'accessing' stamp: 'ar 11/12/1998 19:02'! hashBlock: aBlock "Set a new hash block. The block must accept one argument and return the hash value of the given argument." hashBlock _ aBlock.! ! !PluggableSet methodsFor: 'copying' stamp: 'ar 11/12/1998 18:47'! copy ^super copy postCopyBlocks! ! !PluggableSet methodsFor: 'copying' stamp: 'ar 11/12/1998 18:48'! postCopyBlocks hashBlock _ hashBlock copy. equalBlock _ equalBlock copy. "Fix temps in case we're referring to outside stuff" hashBlock fixTemps. equalBlock fixTemps.! ! !PluggableSet methodsFor: 'private' stamp: 'ar 11/12/1998 18:45'! init: n super init: n. hashBlock _ [:element| element hash]. equalBlock _ [:element1 :element2| element1 = element2]! ! !PluggableSet methodsFor: 'private' stamp: 'ar 11/12/1998 18:40'! 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 _ ((hashBlock value: anObject) \\ 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: [ equalBlock value: element value: anObject]) ifTrue: [^ index ]]. "Search from 1 to where we started." 1 to: start-1 do: [:index | ((element _ array at: index) == nil or: [ equalBlock value: element value: anObject]) ifTrue: [^ index ]]. ^ 0 "No match AND no empty slot"! ! !PluggableSet class methodsFor: 'as yet unclassified' stamp: 'di 6/12/2000 22:14'! integerSet "A stopgap, until we get the pluggable init code." ^ Set new: 500! ! !PluggableTest methodsFor: 'music type pane' stamp: 'jm 10/12/2002 05:37'! musicTypeListTitle ^ 'Choose a command' ! ! !PluggableTest methodsFor: 'menu commands' stamp: 'jm 10/12/2002 05:36'! perform: sel orSendTo: otherObject "Handle the given action myself, if I can, or let otherObject handle it." (self respondsTo: sel) ifTrue: [self perform: sel] ifFalse: [otherObject perform: sel]. ! ! !PluggableTest class methodsFor: 'example' stamp: 'jm 10/12/2002 05:34'! example "PluggableTest example" | model listView1 topView listView2 | model _ self new initialize. listView1 _ PluggableListView on: model list: #musicTypeList selected: #musicType changeSelected: #musicType: menu: #musicTypeMenu: keystroke: #musicTypeKeystroke:. listView1 menuTitleSelector: #musicTypeListTitle. listView2 _ PluggableListView on: model list: #artistList selected: #artist changeSelected: #artist: menu: nil keystroke: #artistKeystroke:. topView _ StandardSystemView new label: 'Pluggable Test'; minimumSize: 300@200; borderWidth: 1; addSubView: listView1; addSubView: listView2 toRightOf: listView1. topView borderWidth: 1. topView controller open.! ! !PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:46'! appendEntry "Append the text in the model's writeStream to the editable text. " self deselect. paragraph text size > model characterLimit ifTrue: ["Knock off first half of text" self selectInvisiblyFrom: 1 to: paragraph text size // 2. self replaceSelectionWith: Text new]. self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size. self replaceSelectionWith: model contents asText. self selectInvisiblyFrom: paragraph text size + 1 to: paragraph text size! ! !PluggableTextController methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:39'! bsText self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! ! !PluggableTextController methodsFor: 'transcript' stamp: 'di 6/3/1998 20:42'! doOccluded: actionBlock | paneRect rectSet bottomStrip | paneRect _ paragraph clippingRectangle. paragraph withClippingRectangle: (paneRect withHeight: 0) do: [actionBlock value. self scrollIn: paneRect]. view topView isCollapsed ifTrue: [^ self]. rectSet _ self visibleAreas. bottomStrip _ paneRect withTop: paragraph compositionRectangle bottom + 1. rectSet do: [:rect | (bottomStrip intersects: rect) ifTrue: ["The subsequent displayOn should clear this strip but it doesnt" Display fill: (bottomStrip intersect: rect) fillColor: paragraph backgroundColor]. paragraph withClippingRectangle: rect do: [paragraph displayOn: Display]]! ! !PluggableTextController methodsFor: 'as yet unclassified' stamp: 'sw 10/29/1999 21:08'! accept view hasUnacceptedEdits ifFalse: [^ view flash]. view hasEditingConflicts ifTrue: [(self confirm: 'Caution!! This method has been changed elsewhere since you started editing it here. Accept anyway?') ifFalse: [^ self flash]]. (view setText: paragraph text from: self) ifTrue: [initialText _ paragraph text copy. view ifNotNil: [view hasUnacceptedEdits: false]] . ! ! !PluggableTextController methodsFor: 'as yet unclassified' stamp: 'sbw 10/12/1999 16:46'! selectForTopFrom: start to: stop "Deselect, then select the specified characters inclusive. Be sure the selection is in view." (start = startBlock stringIndex and: [stop + 1 = stopBlock stringIndex]) ifFalse: [view superView ifNotNil: [self deselect]. self selectInvisiblyFrom: start to: stop]. view superView ifNotNil: [self selectAndScrollToTop]! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'di 9/11/1998 15:46'! acceptOnCR: trueOrFalse textMorph acceptOnCR: trueOrFalse! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'dew 2/21/1999 03:07'! extent: newExtent super extent: (newExtent max: 36@16). textMorph ifNotNil: [textMorph extent: (self innerBounds width-6)@self height]. self setScrollDeltas! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'bolot 11/2/1999 03:18'! font: aFont textMorph beAllFont: aFont! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'jm 11/24/2002 10:25'! initialize super initialize. color _ Color white. hasUnacceptedEdits _ false. hasEditingConflicts _ false. askBeforeDiscardingEdits _ true! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'di 1/29/2000 14:34'! getText "Retrieve the current model text" | newText | getTextSelector == nil ifTrue: [^ Text new]. newText _ model perform: getTextSelector. newText ifNil: [^Text new]. ^ newText shallowCopy! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'di 6/22/1998 01:32'! selectionInterval: sel selectionInterval _ sel! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'jm 11/14/2003 10:17'! setSelection: sel | editor | selectionInterval _ sel. (editor _ textMorph editor) ifNotNil: [editor selectFrom: sel first to: sel last]. self scrollSelectionIntoView ifFalse: [scroller changed].! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'ls 7/20/1998 22:50'! setText: aText scrollBar setValue: 0.0. textMorph ifNil: [textMorph _ TextMorphForEditView new contents: aText wrappedTo: self innerBounds width-6. textMorph setEditView: self. scroller addMorph: textMorph] ifNotNil: [textMorph newContents: aText]. self hasUnacceptedEdits: false. self setScrollDeltas.! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 10/14/1999 07:42'! accept "Inform the model of text to be accepted, and return true if OK." | textToAccept ok | self canDiscardEdits ifTrue: [^ self flash]. self hasEditingConflicts ifTrue: [(self confirm: 'Caution!! This method has been changed elsewhere since you started editing it here. Accept anyway?') ifFalse: [^ self flash]]. textToAccept _ textMorph asText. ok _ (setTextSelector == nil) or: [setTextSelector numArgs = 2 ifTrue: [model perform: setTextSelector with: textToAccept with: self] ifFalse: [model perform: setTextSelector with: textToAccept]]. ok ifTrue: [self setText: self getText. self hasUnacceptedEdits: false]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 9/27/1999 11:57'! chooseAlignment self handleEdit: [textMorph editor changeAlignment]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'! fileItIn self handleEdit: [textMorph editor fileItIn]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:02'! implementorsOfIt self handleEdit: [textMorph editor implementorsOfIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! methodNamesContainingIt self handleEdit: [textMorph editor methodNamesContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! methodSourceContainingIt self handleEdit: [textMorph editor methodSourceContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 16:01'! methodStringsContainingit self handleEdit: [textMorph editor methodStringsContainingit]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 4/26/2000 22:22'! pasteRecent "Paste an item chosen from RecentClippings." | clipping | (clipping _ ParagraphEditor chooseRecentClipping) ifNil: [^ self]. ParagraphEditor clipboardTextPut: clipping. ^ self handleEdit: [textMorph editor paste]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sw 11/7/1999 00:01'! prettyPrint self handleEdit: [textMorph editor prettyPrint]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'RAA 6/13/2000 10:55'! printIt | result oldEditor | textMorph editor selectFrom: selectionInterval first to: selectionInterval last; model: model. "For, eg, evaluateSelection" textMorph handleEdit: [result _ (oldEditor _ textMorph editor) evaluateSelection]. ((result isKindOf: FakeClassPool) or: [result == #failedDoit]) ifTrue: [^self flash]. selectionInterval _ oldEditor selectionInterval. textMorph installEditorToReplace: oldEditor. textMorph handleEdit: [oldEditor afterSelectionInsertAndSelect: result printString]. selectionInterval _ oldEditor selectionInterval. textMorph editor selectFrom: selectionInterval first to: selectionInterval last. self scrollSelectionIntoView. ! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:59'! referencesToIt self handleEdit: [textMorph editor referencesToIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'dew 3/7/2000 21:15'! saveContentsInFile self handleEdit: [textMorph editor saveContentsInFile]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sma 6/5/2000 13:33'! scrollBarMenuButtonPressed: event | menu | (menu _ self getMenu: event shiftPressed) ifNotNil: ["Set up to use perform:orSendTo: for model/view dispatch" menu setInvokingView: self. menu popUpEvent: event]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'di 11/2/1998 15:31'! sendersOfIt self handleEdit: [textMorph editor sendersOfIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'sma 6/5/2000 13:33'! yellowButtonActivity "Called when the shifted-menu's 'more' item is chosen" | menu | (menu _ self getMenu: false) ifNotNil: ["Set up to use perform:orSendTo: for model/view dispatch" menu setInvokingView: self. menu popUpEvent: self currentEvent]! ! !PluggableTextMorph methodsFor: 'updating' stamp: 'dew 6/11/2000 02:21'! update: aSymbol aSymbol ifNil: [^ self]. aSymbol == #flash ifTrue: [^ self flash]. aSymbol == getTextSelector ifTrue: [self setText: self getText. ^ self setSelection: self getSelection]. aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection]. (aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue: [self handleEdit: [textMorph editor setSearch: model autoSelectString; againOrSame: true]]. aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false]. aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [^ self promptForCancel]. ^ self]. aSymbol == #appendEntry ifTrue: [self handleEdit: [self appendEntry]. ^ self refreshWorld]. aSymbol == #clearText ifTrue: [self handleEdit: [self changeText: Text new]. ^ self refreshWorld]. aSymbol == #bs ifTrue: [self handleEdit: [self bsText]. ^ self refreshWorld]. aSymbol == #codeChangedElsewhere ifTrue: [self hasEditingConflicts: true. ^ self changed]! ! !PluggableTextMorph methodsFor: 'drawing' stamp: 'sw 10/10/1999 23:26'! drawOn: aCanvas "Include a thin red inset border for unaccepted edits, or, if the unaccepted edits are known to conflict with a change made somewhere else to the same method (typically), put a thick red frame" super drawOn: aCanvas. self hasEditingConflicts ifTrue: [aCanvas frameRectangle: self innerBounds width: 3 color: Color red] ifFalse: [self hasUnacceptedEdits ifTrue: [aCanvas frameRectangle: self innerBounds width: 1 color: Color red]]! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'! hasEditingConflicts "Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited" ^ hasEditingConflicts == true! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 22:55'! hasEditingConflicts: aBoolean hasEditingConflicts _ aBoolean! ! !PluggableTextMorph methodsFor: 'unaccepted edits' stamp: 'sw 10/10/1999 23:06'! hasUnacceptedEdits: aBoolean "Set the hasUnacceptedEdits flag to the given value. " aBoolean == hasUnacceptedEdits ifFalse: [hasUnacceptedEdits _ aBoolean. self changed]. aBoolean ifFalse: [hasEditingConflicts _ false]! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'di 6/22/1998 15:15'! correctFrom: start to: stop with: aString ^ self handleEdit: [textMorph editor correctFrom: start to: stop with: aString]! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'di 11/2/1998 15:57'! handleEdit: editBlock | result | textMorph editor selectFrom: selectionInterval first to: selectionInterval last; model: model. "For, eg, evaluateSelection" textMorph handleEdit: [result _ editBlock value]. "Update selection after edit" self scrollSelectionIntoView. ^ result! ! !PluggableTextMorph methodsFor: 'editor access' stamp: 'ar 11/15/1998 23:45'! scrollSelectionIntoView: event "Scroll my text into view if necessary and return true, else return false" | selRects delta selRect rectToTest transform cpHere | selectionInterval _ textMorph editor selectionInterval. selRects _ textMorph paragraph selectionRects. selRects isEmpty ifTrue: [^ false]. rectToTest _ selRects first merge: selRects last. transform _ scroller transformFrom: self. (event notNil and: [event anyButtonPressed]) ifTrue: "Check for autoscroll" [cpHere _ transform localPointToGlobal: event cursorPoint. cpHere y <= self top ifTrue: [rectToTest _ selRects first topLeft extent: 2@2] ifFalse: [cpHere y >= self bottom ifTrue: [rectToTest _ selRects last bottomRight extent: 2@2] ifFalse: [^ false]]]. selRect _ transform localBoundsToGlobal: rectToTest. selRect height > bounds height ifTrue: [^ false]. "Would not fit, even if we tried to scroll" (delta _ selRect amountToTranslateWithin: self bounds) y ~= 0 ifTrue: ["Scroll end of selection into view if necessary" self scrollBy: 0@delta y. ^ true]. ^ false! ! !PluggableTextMorph methodsFor: 'transcript' stamp: 'sma 3/15/2000 21:40'! bsText self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! ! !PluggableTextMorph methodsFor: 'pane events' stamp: 'tk 4/5/1999 03:12'! mouseEnter: event super mouseEnter: event. selectionInterval ifNotNil: [textMorph handleEdit: [textMorph editor selectInterval: selectionInterval. textMorph editor setEmphasisHere]]. event hand newKeyboardFocus: textMorph! ! !PluggableTextMorph methodsFor: 'pane events' stamp: 'jm 8/20/1998 08:39'! mouseLeave: event textMorph ifNotNil: [selectionInterval _ textMorph editor selectionInterval]. super mouseLeave: event. event hand newKeyboardFocus: nil. ! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'kfr 6/8/2000 22:38'! resetExtent "Reset the extent while maintaining the current selection. Needed when resizing while the editor is active (when inside the pane)." | tempSelection | textMorph notNil ifTrue: ["the current selection gets munged by resetting the extent, so store it" tempSelection _ self selectionInterval. "don't reset it if it's not active" tempSelection = (Interval from: 1 to: 0) ifTrue: [retractableScrollBar ifTrue:[ ^ self]]. self extent: self extent. self setSelection: tempSelection]! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled." ^ scroller firstSubmorph defaultLineHeight ! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'sr 4/25/2000 07:21'! getTextSelector ^getTextSelector! ! !PluggableTextView methodsFor: 'initialization' stamp: 'sw 10/29/1999 21:02'! initialize super initialize. hasEditingConflicts _ false! ! !PluggableTextView methodsFor: 'model access' stamp: 'di 6/26/1998 11:06'! getMenu: shiftKeyDown "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu | getMenuSelector == nil ifTrue: [^ nil]. menu _ CustomMenu new. getMenuSelector numArgs = 1 ifTrue: [^ model perform: getMenuSelector with: menu]. getMenuSelector numArgs = 2 ifTrue: [^ model perform: getMenuSelector with: menu with: shiftKeyDown]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !PluggableTextView methodsFor: 'model access' stamp: 'sw 1/16/1999 14:31'! getSelection "Answer the model's selection interval." getSelectionSelector == nil ifTrue: [^ 1 to: 0]. "null selection" ^ getSelectionSelector ifNotNil: [model perform: getSelectionSelector] ! ! !PluggableTextView methodsFor: 'model access' stamp: 'jm 8/20/1998 11:55'! model: aLockedModel "Refer to the comment in View|model:." self model: aLockedModel controller: controller. self editString: self getText. ! ! !PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:03'! hasEditingConflicts "Return true if a conflicting edit to the same code (typically) is known to have occurred after the current contents started getting edited" ^ hasEditingConflicts == true! ! !PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'! hasEditingConflicts: aBoolean hasEditingConflicts _ aBoolean! ! !PluggableTextView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:04'! hasUnacceptedEdits: aBoolean super hasUnacceptedEdits: aBoolean. aBoolean ifFalse: [hasEditingConflicts _ false]! ! !PluggableTextView methodsFor: 'updating' stamp: 'sma 3/15/2000 21:39'! update: aSymbol "Refer to the comment in View|update:. Do nothing if the given symbol does not match any action. " aSymbol == #wantToChange ifTrue: [self canDiscardEdits ifFalse: [self promptForCancel]. ^ self]. aSymbol == #flash ifTrue: [^ controller flash]. aSymbol == getTextSelector ifTrue: [^ self updateDisplayContents]. aSymbol == getSelectionSelector ifTrue: [^ self setSelection: self getSelection]. aSymbol == #clearUserEdits ifTrue: [^ self hasUnacceptedEdits: false]. (aSymbol == #autoSelect and: [getSelectionSelector ~~ nil]) ifTrue: [^ controller setSearch: model autoSelectString; againOrSame: true]. aSymbol == #appendEntry ifTrue: [^ controller doOccluded: [controller appendEntry]]. aSymbol == #clearText ifTrue: [^ controller doOccluded: [controller changeText: Text new]]. aSymbol == #bs ifTrue: [^ controller doOccluded: [controller bsText]]. aSymbol == #codeChangedElsewhere ifTrue: [^ self hasEditingConflicts: true] ! ! I represent an x-y pair of numbers usually designating a location on the screen.! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! * arg "Answer a Point that is the product of the receiver and arg." arg isPoint ifTrue: [^ (x * arg x) @ (y * arg y)]. ^ arg adaptToPoint: self andSend: #*! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:01'! + arg "Answer a Point that is the sum of the receiver and arg." arg isPoint ifTrue: [^ (x + arg x) @ (y + arg y)]. ^ arg adaptToPoint: self andSend: #+! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! - arg "Answer a Point that is the difference of the receiver and arg." arg isPoint ifTrue: [^ (x - arg x) @ (y - arg y)]. ^ arg adaptToPoint: self andSend: #-! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! / arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x / arg x) @ (y / arg y)]. ^ arg adaptToPoint: self andSend: #/! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! // arg "Answer a Point that is the quotient of the receiver and arg." arg isPoint ifTrue: [^ (x // arg x) @ (y // arg y)]. ^ arg adaptToPoint: self andSend: #//! ! !Point methodsFor: 'arithmetic' stamp: 'di 11/6/1998 14:02'! \\ arg "Answer a Point that is the mod of the receiver and arg." arg isPoint ifTrue: [^ (x \\ arg x) @ (y \\ arg y)]. ^ arg adaptToPoint: self andSend: #\\! ! !Point methodsFor: 'converting' stamp: 'di 11/9/1998 12:44'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with an Integer, convert it to a Point." ^ rcvr@rcvr perform: selector with: self! ! !Point methodsFor: 'converting' stamp: 'jm 6/29/2003 22:29'! asPoint "Answer the receiver itself." ^ self ! ! !Point methodsFor: 'converting' stamp: 'jm 6/29/2003 22:31'! commaString "Answer a string of the form (x, y) instead of the usual Smalltalk x@y." ^ '(', self x asString, ', ', self y asString, ')' ! ! !Point methodsFor: 'converting' stamp: 'di 11/6/1998 07:45'! isPoint ^ true! ! !Point methodsFor: 'geometry' stamp: 'laza 1/6/2000 10:30'! sideOf: otherPoint "Returns #left, #right or #center if the otherPoint lies to the left, right or on the line given by the vector from 0@0 to self" | side | side _ (self crossProduct: otherPoint) sign. ^ {#right. #center. #left} at: side + 2 ! ! !Point methodsFor: 'geometry' stamp: 'ar 4/6/2000 18:37'! to: end1 intersects: start2 to: end2 "Returns true if the linesegment from start1 (=self) to end1 intersects with the segment from start2 to end2, otherwise false." | start1 sideStart sideEnd | start1 _ self. (((start1 = start2 or: [end1 = end2]) or: [start1 = end2]) or: [start2 = end1]) ifTrue: [^ true]. sideStart _ start1 to: end1 sideOf: start2. sideEnd _ start1 to: end1 sideOf: end2. sideStart = sideEnd ifTrue: [^ false]. sideStart _ start2 to: end2 sideOf: start1. sideEnd _ start2 to: end2 sideOf: end1. sideStart = sideEnd ifTrue: [^ false]. ^ true! ! !Point methodsFor: 'geometry' stamp: 'laza 1/5/2000 11:50'! to: end sideOf: otherPoint "Returns #left, #right, #center if the otherPoint lies to the left, right or on the line given by the vector from self to end" ^ end - self sideOf: otherPoint - self! ! !Point methodsFor: 'point functions' stamp: 'ar 10/30/1998 03:05'! crossProduct: aPoint "Answer a number that is the cross product of the receiver and the argument, aPoint." ^ (x * aPoint y) - (y * aPoint x)! ! !Point methodsFor: 'point functions' stamp: 'di 9/11/1998 16:22'! dotProduct: aPoint "Answer a number that is the dot product of the receiver and the argument, aPoint. That is, the two points are multipled and the coordinates of the result summed." ^ (x * aPoint x) + (y * aPoint y)! ! !Point methodsFor: 'private' stamp: 'di 5/16/2000 22:05'! setR: rho degrees: theta | radians | radians _ theta asFloat degreesToRadians. x _ rho asFloat * radians cos. y _ rho asFloat * radians sin.! ! !Point methodsFor: 'private' stamp: 'sw 3/21/2000 13:24'! setX: xValue setY: yValue x _ xValue. y _ yValue! ! !Point methodsFor: 'truncation and round off' stamp: 'jm 6/3/1998 12:21'! rounded "Answer a Point that is the receiver's x and y rounded. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x rounded @ y rounded ! ! !Point methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'! truncated "Answer a Point whose x and y coordinates are integers. Answer the receiver if its coordinates are already integral." (x isInteger and: [y isInteger]) ifTrue: [^ self]. ^ x truncated @ y truncated ! ! I can search for reasons why a certain object isn't garbage collected. I'm a quick port of a VisualWorks program written by Hans-Martin Mosner. Call me as shown below. I'll search for a path from a global variable to the given object, presenting it in a small morphic UI. Examples: PointerFinder on: self currentHand PointerFinder on: StandardSystemView someInstance Now, let's see why this image contains more HandMorphs as expected... HandMorph allInstancesDo: [:e | PointerFinder on: e]! !PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 18:58'! buildList | list obj parent object key | list := OrderedCollection new. obj := goal. [list addFirst: obj. obj := parents at: obj ifAbsent: []. obj == nil] whileFalse. list removeFirst. parent := Smalltalk. objectList := OrderedCollection new. pointerList := OrderedCollection new. [list isEmpty] whileFalse: [object := list removeFirst. key := nil. (parent isKindOf: Dictionary) ifTrue: [list size >= 2 ifTrue: [key := parent keyAtValue: list second ifAbsent: []. key == nil ifFalse: [object := list removeFirst; removeFirst. pointerList add: key printString , ' -> ' , object class name]]]. key == nil ifTrue: [parent class == object ifTrue: [key := 'CLASS']. key == nil ifTrue: [1 to: parent class instSize do: [:i | key == nil ifTrue: [(parent instVarAt: i) == object ifTrue: [key := parent class allInstVarNames at: i]]]]. key == nil ifTrue: [1 to: parent basicSize do: [:i | key == nil ifTrue: [(parent basicAt: i) == object ifTrue: [key := i printString]]]]. key == nil ifTrue: [(parent isMorph and: [object isKindOf: Array]) ifTrue: [key := 'submorphs?']]. key == nil ifTrue: [key := '???']. pointerList add: key , ': ' , object class name]. objectList add: object. parent := object]! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 23:08'! follow: anObject from: parentObject anObject == goal ifTrue: [parents at: anObject put: parentObject. ^ true]. anObject isLiteral ifTrue: [^ false]. anObject class isPointers ifFalse: [^ false]. anObject class isWeak ifTrue: [^ false]. (parents includesKey: anObject) ifTrue: [^ false]. parents at: anObject put: parentObject. toDoNext add: anObject. ^ false! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 10:01'! followObject: anObject (self follow: anObject class from: anObject) ifTrue: [^ true]. 1 to: anObject class instSize do: [:i | (self follow: (anObject instVarAt: i) from: anObject) ifTrue: [^ true]]. 1 to: anObject basicSize do: [:i | (self follow: (anObject basicAt: i) from: anObject) ifTrue: [^ true]]. ^ false! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 09:52'! goal: anObject goal _ anObject! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'! initialize parents _ IdentityDictionary new: 20000. parents at: Smalltalk put: nil. parents at: Processor put: nil. parents at: self put: nil. toDo _ OrderedCollection new: 5000. toDo add: Smalltalk. toDoNext _ OrderedCollection new: 5000! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:19'! isLiteral "Horrible hack to omit other Pointer Finders from scanning." ^ true! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/7/2000 00:17'! search Smalltalk garbageCollect. self initialize. Cursor wait showWhile: [ [[toDo isEmpty or: [self followObject: toDo removeFirst]] whileFalse. toDo isEmpty and: [toDoNext isEmpty not]] whileTrue: [toDo _ toDoNext. toDoNext _ OrderedCollection new: 5000]]. self buildList! ! !PointerFinder methodsFor: 'application' stamp: 'sma 6/6/2000 19:10'! update ('done: ' , parents size asString , ' todo: ' , toDo size asString , ' ') displayAt: 0@0! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:23'! arrowKey: key from: aController key = $i ifTrue: [^ self inspectObject]. ^ super arrowKey: key from: aController! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:48'! initialExtent ^ 300 @ 300! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:26'! inspectObject pointerListIndex = 0 ifTrue: [^ self beep]. (objectList at: pointerListIndex) inspect! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:09'! menu: aMenu shifted: shifted ^ MenuMorph new defaultTarget: self; add: 'Inspect (i)' action: #inspectObject; balloonTextForLastItem: 'Live long and prosper!!'; addLine; add: 'Search again' action: #searchAgain; balloonTextForLastItem: 'Search again\for the same object' withCRs; yourself! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:52'! open | window list | window _ (SystemWindow labelled: 'Pointer Finder') model: self. list _ PluggableListMorph on: self list: #pointerList selected: #pointerListIndex changeSelected: #pointerListIndex: menu: #menu:shifted:. list doubleClickSelector: #inspectObject. window addMorph: list frame: (0@0 extent: 1@1). list color: Color lightMagenta. window openInWorld! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:15'! perform: selector orSendTo: otherTarget selector == #inspectObject ifTrue: [^ self inspectObject]. selector == #searchAgain ifTrue: [^ self searchAgain]. ^ super perform: selector orSendTo: otherTarget! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:49'! pointerList ^ pointerList asArray! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:27'! pointerListIndex ^ pointerListIndex ifNil: [0]! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/6/2000 23:51'! pointerListIndex: anInteger pointerListIndex _ anInteger. self changed: #pointerListIndex! ! !PointerFinder methodsFor: 'morphic ui' stamp: 'sma 6/7/2000 00:16'! searchAgain self pointerListIndex: 0. self search. self changed: #pointerList! ! !PointerFinder class methodsFor: 'instance creation' stamp: 'sma 6/6/2000 23:52'! on: anObject ^ self new goal: anObject; search; open! ! I represent an arbitrary polygonal figure with a border and straight sides. My shape can be edited by showing my handles. When I am set to be an 'open' polygon, I be used to draw multi-segment lines with optional arrowheads on one or both ends. I have two fill modes: 'fast' and 'proper'. Fast mode sometimes does the wrong thing with concave figures but is fast. Polygons and curves use a 1-bit shape form to make display reasonably fast. This could be further optimized by going to a 2-bit form and including the border. It would also be simple to compute an inner rectangle, as with ellipses. ! !PolygonMorph methodsFor: 'initialization' stamp: 'jm 10/9/2002 05:54'! initialize super initialize. color _ Color orange. vertices _ Array with: 20@20 with: 40@30 with: 20@40. borderWidth _ 2. borderColor _ Color magenta. closed _ true. quickFill _ true. arrows _ #none. self computeBounds. ! ! !PolygonMorph methodsFor: 'access' stamp: 'di 2/10/1999 21:13'! borderColor: aColor (borderColor isColor and: [borderColor isTranslucentColor]) == (aColor isColor and: [aColor isTranslucentColor]) ifTrue: [super borderColor: aColor] ifFalse: ["Need to recompute fillForm and borderForm if translucency of border changes." super borderColor: aColor. self releaseCachedState]! ! !PolygonMorph methodsFor: 'access' stamp: 'di 2/10/1999 16:32'! makeClosed closed _ true. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'access' stamp: 'di 2/10/1999 16:34'! makeOpen closed _ false. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'access' stamp: 'di 6/21/1998 12:23'! quickFill: trueOrFalse quickFill _ trueOrFalse. filledForm _ nil. self changed! ! !PolygonMorph methodsFor: 'geometry' stamp: 'di 12/17/1998 12:32'! containsPoint: aPoint (super containsPoint: aPoint) ifFalse: [^ false]. closed & color isTransparent not ifTrue: [^ (self filledForm pixelValueAt: aPoint - bounds topLeft + 1) > 0]. self lineSegmentsDo: [:p1 :p2 | (aPoint onLineFrom: p1 to: p2 within: (2 max: borderWidth+1//2) asFloat) ifTrue: [^ true]]. self arrowForms do: [:f | (f pixelValueAt: aPoint - f offset) > 0 ifTrue: [^ true]]. ^ false! ! !PolygonMorph methodsFor: 'geometry' stamp: 'jm 5/29/2003 18:51'! inset: amt "Only works if I am made of rectangles (every segment of me is horizontal or vertical). Inset each vertex by amt. Uses containsPoint." | delta four cnt offset | delta _ amt asPoint. four _ {delta. -1@1 * delta. -1@-1 * delta. 1@-1 * delta}. self setVertices: (vertices collect: [:vv | cnt _ 0. offset _ (four collect: [:del | (self containsPoint: del+vv) ifTrue: [cnt _ cnt + 1. del] ifFalse: [0@0]]) sum. cnt = 2 ifTrue: [offset _ offset // 2]. vv + offset]).! ! !PolygonMorph methodsFor: 'geometry' stamp: 'jm 10/9/2002 07:31'! isRectangular ^ false ! ! !PolygonMorph methodsFor: 'drawing' stamp: 'jm 7/17/2003 22:53'! drawBorderOn: aCanvas "Display my border on the canvas." | lineColor bevel topLeftColor bottomRightColor bigClipRect brush p1i p2i | (borderColor == nil or: [borderColor isColor and: [borderColor isTransparent]]) ifTrue: [^ self]. lineColor _ borderColor. bevel _ false. "Border colors for bevelled effects depend on CW ordering of vertices" borderColor == #raised ifTrue: [topLeftColor _ color lighter. bottomRightColor _ color darker. bevel _ true]. borderColor == #inset ifTrue: [topLeftColor _ owner colorForInsets darker. bottomRightColor _ owner colorForInsets lighter. bevel _ true]. bigClipRect _ aCanvas clipRect expandBy: self borderWidth + 1 // 2. brush _ nil. self lineSegmentsDo: [:p1 :p2 | p1i _ p1 truncated. p2i _ p2 truncated. (closed or: ["bigClipRect intersects: (p1i rect: p2i) optimized:" ((p1i min: p2i) max: bigClipRect origin) <= ((p1i max: p2i) min: bigClipRect corner)]) ifTrue: [bevel ifTrue: [(p1i quadrantOf: p2i) > 2 ifTrue: [lineColor _ topLeftColor] ifFalse: [lineColor _ bottomRightColor]]. (borderWidth > 3 and: [borderColor isColor]) ifTrue: [brush == nil ifTrue: [brush _ (ColorForm dotOfSize: borderWidth) colors: (Array with: Color transparent with: borderColor)]. aCanvas line: p1i to: p2i brushForm: brush] ifFalse: [aCanvas line: p1i to: p2i width: borderWidth color: lineColor]]]. ! ! !PolygonMorph methodsFor: 'drawing' stamp: 'jm 10/3/2002 18:45'! drawOn: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. closed & color isTransparent not ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft color: borderColor] ifFalse: [self drawBorderOn: aCanvas]. self arrowForms do: [:f | aCanvas stencil: f at: f offset color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])] ! ! !PolygonMorph methodsFor: 'drawing'! drawOnFormCanvas: aCanvas "Display the receiver, a spline curve, approximated by straight line segments." | | vertices size < 1 ifTrue: [self error: 'a polygon must have at least one point']. closed & color isTransparent not ifTrue: [aCanvas stencil: self filledForm at: bounds topLeft - 1 color: color]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [aCanvas stencil: self borderForm at: bounds topLeft color: borderColor] ifFalse: [self drawBorderOn: aCanvas]. self arrowForms do: [:f | aCanvas stencil: f at: f offset color: (borderColor isColor ifTrue: [borderColor] ifFalse: [color])]! ! !PolygonMorph methodsFor: 'editing' stamp: 'di 10/9/1998 14:35'! dropVertex: evt fromHandle: handle vertIndex: ix | p | p _ vertices at: ix. (((vertices atWrap: ix-1) dist: p) < 3 or: [((vertices atWrap: ix+1) dist: p) < 3]) ifTrue: ["Drag a vertex onto its neighbor means delete" self setVertices: (vertices copyReplaceFrom: ix to: ix with: Array new)]. self addHandles! ! !PolygonMorph methodsFor: 'editing' stamp: 'jm 6/3/1998 14:29'! newVertex: evt fromHandle: handle afterVert: ix "Insert a new vertex and fix everything up!! Install the drag-handle of the new vertex as recipient of further mouse events." | pt | pt _ evt cursorPoint. self setVertices: (vertices copyReplaceFrom: ix + 1 to: ix with: (Array with: pt)). evt hand newMouseFocus: (handles at: ((ix + 1) * 2) - 1). ! ! !PolygonMorph methodsFor: 'menu' stamp: 'jm 10/9/2002 05:56'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. handles ifNil: [aCustomMenu add: 'show handles' action: #addHandles] ifNotNil: [aCustomMenu add: 'hide handles' action: #removeHandles]. closed ifTrue: [ aCustomMenu add: 'open polygon' action: #makeOpen. quickFill ifTrue: [aCustomMenu add: 'proper fill' selector: #quickFill: argument: false] ifFalse: [aCustomMenu add: 'quick fill' selector: #quickFill: argument: true]] ifFalse: [ aCustomMenu add: 'close polygon' action: #makeClosed. arrows == #none ifFalse: [aCustomMenu add: '---' action: #makeNoArrows]. arrows == #forward ifFalse: [aCustomMenu add: '-->' action: #makeForwardArrow]. arrows == #back ifFalse: [aCustomMenu add: '<--' action: #makeBackArrow]. arrows == #both ifFalse: [aCustomMenu add: '<-->' action: #makeBothArrows]]. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'jm 10/11/2002 13:43'! addHandles | handle newVert | self removeHandles. handles _ OrderedCollection new. vertices withIndexDo: [:vertPt :vertIndex | "vertex handle" handle _ MouseHandleMorph newBounds: (Rectangle center: vertPt extent: 8@8) color: Color yellow. handle target: self argument: vertIndex; mouseMoveSelector: #dragVertex:fromHandle:vertIndex:; mouseUpSelector: #dropVertex:fromHandle:vertIndex:. handles addLast: handle. "handle to create a new vertex" (closed or: [vertIndex < vertices size]) ifTrue: [ newVert _ MouseHandleMorph newBounds: (Rectangle center: (vertPt + (vertices atWrap: vertIndex+1) // 2) extent: 8@8) color: Color green. newVert target: self argument: vertIndex; mouseDownSelector: #newVertex:fromHandle:afterVert:. handles addLast: newVert]]. self addAllMorphs: handles. self changed. ! ! !PolygonMorph methodsFor: 'private' stamp: 'di 12/17/1998 12:31'! arrowForms "ArrowForms are computed only upon demand" arrowForms ifNotNil: [^ arrowForms]. arrowForms _ Array new. (closed or: [arrows == #none or: [vertices size < 2]]) ifTrue: [^ arrowForms]. (arrows == #forward or: [arrows == #both]) ifTrue: [arrowForms _ arrowForms copyWith: (self computeArrowFormAt: vertices last from: self nextToLastPoint)]. (arrows == #back or: [arrows == #both]) ifTrue: [arrowForms _ arrowForms copyWith: (self computeArrowFormAt: vertices first from: self nextToFirstPoint)]. ^ arrowForms! ! !PolygonMorph methodsFor: 'private' stamp: 'jm 11/24/2002 10:49'! borderForm "A form must be created for drawing the border whenever the borderColor is translucent." | borderCanvas | borderForm ifNotNil: [^ borderForm]. borderCanvas _ (FormCanvas extent: bounds extent depth: 1) shadowColor: Color black. borderCanvas translateBy: bounds topLeft negated during:[:tempCanvas| self drawBorderOn: tempCanvas]. borderForm _ borderCanvas form. self arrowForms do: [:f | "Eliminate overlap between line and arrowheads if transparent." borderForm copy: f boundingBox from: f to: f offset - self position rule: Form erase]. ^ borderForm! ! !PolygonMorph methodsFor: 'private' stamp: 'jm 7/17/2003 22:53'! computeArrowFormAt: endPoint from: priorPoint "Compute a triangle oriented along the line from priorPoint to endPoint. Then draw those lines in a form and return that form, with appropriate offset" | d v p1 pts box arrowForm bb origin angle | d _ borderWidth max: 1. v _ endPoint - priorPoint. angle _ v theta radiansToDegrees. pts _ Array with: (endPoint + (borderWidth//2) + (Point r: d*5 degrees: angle)) with: (endPoint + (borderWidth//2) + (Point r: d*4 degrees: angle + 135.0)) with: (endPoint + (borderWidth//2) + (Point r: d*4 degrees: angle - 135.0)). box _ ((pts first rect: pts last) encompass: (pts at: 2)) expandBy: 1. arrowForm _ Form extent: box extent truncated. bb _ (BitBlt toForm: arrowForm) sourceForm: nil; fillColor: Color black; combinationRule: Form over; width: 1; height: 1. origin _ box topLeft. p1 _ pts last - origin. pts do: [:p | bb drawFrom: p1 to: p-origin. p1 _ p-origin]. arrowForm convexShapeFill: Color black. ^ arrowForm offset: box topLeft! ! !PolygonMorph methodsFor: 'private' stamp: 'di 12/17/1998 13:09'! computeBounds self changed. self releaseCachedState. bounds _ self curveBounds. self arrowForms do: [:f | bounds _ bounds merge: (f offset extent: f extent)]. handles ifNotNil: [self updateHandles]. self layoutChanged. self changed! ! !PolygonMorph methodsFor: 'private' stamp: 'di 6/21/1998 15:24'! curveBounds ^ (Rectangle encompassing: vertices) expandBy: borderWidth+1//2! ! !PolygonMorph methodsFor: 'private' stamp: 'jm 7/17/2003 22:53'! filledForm "Note: The filled form is actually 2 pixels bigger than bounds, and the point corresponding to this morphs' position is at 1@1 in the form. This is due to the details of the fillig routines, at least one of which requires an extra 1-pixel margin around the outside. Computation of the filled form is done only on demand." | bb origin | closed ifFalse: [^ filledForm _ nil]. filledForm ifNotNil: [^ filledForm]. filledForm _ Form extent: bounds extent+2. "Draw the border..." bb _ (BitBlt toForm: filledForm) sourceForm: nil; fillColor: Color black; combinationRule: Form over; width: 1; height: 1. origin _ bounds topLeft truncated-1. self lineSegmentsDo: [:p1 :p2 | bb drawFrom: p1 truncated-origin to: p2 truncated-origin]. "Fill it in..." quickFill ifTrue: [filledForm convexShapeFill: Color black] ifFalse: [filledForm _ filledForm anyShapeFill]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: ["If border is stored as a form, then erase any overlap now." filledForm copy: self borderForm boundingBox from: self borderForm to: 1@1 rule: Form erase]. ^ filledForm! ! !PolygonMorph methodsFor: 'private' stamp: 'ar 6/18/1999 09:35'! getVertices ^vertices! ! !PolygonMorph methodsFor: 'private' stamp: 'di 12/17/1998 12:33'! privateMoveBy: delta super privateMoveBy: delta. vertices _ vertices collect: [:p | p + delta]. self arrowForms do: [:f | f offset: f offset + delta]! ! !PolygonMorph methodsFor: 'private' stamp: 'ar 11/8/1999 17:14'! releaseCachedState super releaseCachedState. filledForm _ nil. arrowForms _ nil. borderForm _ nil! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:01'! includeInNewMorphMenu ^ true ! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'di 6/21/1998 10:24'! shapeFromPen: penBlock color: c borderWidth: bw borderColor: bc "World addMorph: (PolygonMorph shapeFromPen: [:p | p hilbert: 4 side: 5. p go: 5. p hilbert: 4 side: 5. p go: 5.] color: Color red borderWidth: 1 borderColor: Color black)" | pen | penBlock value: (pen _ PenPointRecorder new). ^ (self vertices: pen points color: c borderWidth: bw borderColor: bc) quickFill: false! ! I provide a pop-up menu of options. ! !PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/13/2002 17:39'! initialize super initialize. self contents: 'PopUpChoice of Colors'. target _ Color. actionSelector _ nil. arguments _ Array empty. getItemsSelector _ #colorNames. getItemsArgs _ Array empty. ! ! !PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'ee 7/2/2003 15:08'! mouseDown: evt | items menu selectedItem | (target == nil or: [getItemsSelector == nil]) ifTrue: [^ self]. items _ target perform: getItemsSelector withArguments: getItemsArgs. menu _ CustomMenu new. items do: [:item | menu add: item action: item]. selectedItem _ menu startUp. selectedItem ifNil: [^ self]. self contentsClipped: ''. "Client can override this if necess" actionSelector ifNotNil: [ target perform: actionSelector withArguments: (arguments copyWith: selectedItem)]. ! ! !PopUpChoiceMorph methodsFor: 'as yet unclassified' stamp: 'ee 7/2/2003 14:35'! preemptsMouseDown: evt ^ true.! ! I represent a list of items. My instances are presented on the display screen in a rectangular area. The user points to an item, pressing a mouse button; the item is highlighted. When the button is released, the highlighted item indicates the selection.! !PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:44'! center "Answer the point at the center of the receiver's rectangular area." ^ frame center! ! !PopUpMenu methodsFor: 'accessing' stamp: 'di 4/20/1999 14:33'! frameHeight "Designed to avoid the entire frame computation (includes MVC form), since the menu may well end up being displayed in Morphic anyway." | nItems | frame ifNotNil: [^ frame height]. nItems _ 1 + (labelString occurrencesOf: Character cr). ^ (nItems * MenuStyle lineGrid) + 4 "border width"! ! !PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'! labelString ^ labelString! ! !PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 14:55'! lineArray ^ lineArray! ! !PopUpMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 12:32'! nItems ^ (labelString occurrencesOf: Character cr) + 1! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 13:04'! controlActivity "Do whatever a menu must do - now with keyboard support." | didNotMove downPos | didNotMove _ true. Sensor anyButtonPressed ifFalse: [didNotMove _ false. Sensor waitButtonOrKeyboard]. Sensor keyboardPressed ifFalse: [self manageMarker]. (didNotMove and: [selection = 0]) ifTrue: [downPos _ Sensor cursorPoint. [didNotMove and: [Sensor anyButtonPressed]] whileTrue: [(downPos dist: Sensor cursorPoint) < 2 ifFalse: [didNotMove _ false]]. didNotMove ifTrue: [Sensor waitButtonOrKeyboard]]. [Sensor keyboardPressed] whileTrue: [self readKeyboard ifTrue: [^ self]. Sensor waitButtonOrKeyboard]. [Sensor anyButtonPressed] whileTrue: [self manageMarker]! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 6/1/2000 10:55'! readKeyboard "Keyboard support for menus. ESC will abort the menu, Space or CR will select an item. Cursor up and cursor down will change the selection. Any other key will either select an item whose label starts with that character or select the next matching label. Answer true if the menu should be closed and false otherwise." | ch labels occurences | ch _ Sensor keyboard asciiValue. (ch = 13 or: [ch = 32]) ifTrue: [^ true]. ch = 27 ifTrue: [self setSelection: 0. ^ true]. ch = 30 ifTrue: [self setSelection: (selection <= 1 ifTrue: [self nItems] ifFalse: [selection - 1])]. ch = 31 ifTrue: [self setSelection: selection \\ self nItems + 1]. ch _ ch asCharacter asLowercase. labels _ labelString findTokens: Character cr asString. occurences _ 0. 1 + selection to: selection + labels size do: [:index | | i | i _ index - 1 \\ labels size + 1. (labels at: i) withBlanksTrimmed first asLowercase = ch ifTrue: [(occurences _ occurences + 1) = 1 ifTrue: [self setSelection: i]]]. ^ occurences = 1! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 4/30/2000 10:04'! startUpCenteredWithCaption: captionOrNil "Differs from startUpWithCaption: by appearing with cursor in the menu, and thus ready to act on mouseUp, without requiring user tweak to confirm" | cursorPoint | cursorPoint _ Smalltalk isMorphic ifTrue: [World cursorPoint] ifFalse: [Sensor cursorPoint]. ^ self startUpWithCaption: captionOrNil at: cursorPoint - (20@0)! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'JDD 8/8/1999 13:05'! startUpSegmented: segmentHeight withCaption: captionOrNil at: location "This menu is too big to fit comfortably on the screen. Break it up into smaller chunks, and manage the relative indices. Inspired by a special-case solution by Reinier van Loon." " (PopUpMenu labels: (String streamContents: [:s | 1 to: 100 do: [:i | s print: i; cr]. s skip: -1]) lines: (5 to: 100 by: 5)) startUpWithCaption: 'Give it a whirl...'. " | nLines nLinesPer allLabels from to subset subLines index | frame ifNil: [self computeForm]. allLabels := labelString findTokens: Character cr asString. nLines _ allLabels size. lineArray ifNil: [lineArray _ Array new]. nLinesPer _ segmentHeight // marker height - 3. from := 1. [ true ] whileTrue: [to := (from + nLinesPer) min: nLines. subset := allLabels copyFrom: from to: to. subset add: (to = nLines ifTrue: ['start over...'] ifFalse: ['more...']) before: subset first. subLines _ lineArray select: [:n | n >= from] thenCollect: [:n | n - (from-1) + 1]. subLines _ (Array with: 1) , subLines. index := (PopUpMenu labels: subset asStringWithCr lines: subLines) startUpWithCaption: captionOrNil at: location. index = 1 ifTrue: [from := to + 1. from > nLines ifTrue: [ from := 1 ]] ifFalse: [index = 0 ifTrue: [^ 0]. ^ from + index - 2]]! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 4/30/2000 10:05'! startUpWithCaption: captionOrNil "Display the menu, slightly offset from the cursor, so that a slight tweak is required to confirm any action." ^ self startUpWithCaption: captionOrNil at: (Smalltalk isMorphic ifTrue: [World cursorPoint] ifFalse: [Sensor cursorPoint])! ! !PopUpMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 12:11'! startUpWithCaption: captionOrNil at: location "Display the menu, with caption if supplied. Wait for the mouse button to go down, then track the selection as long as the button is pressed. When the button is released, answer the index of the current selection, or zero if the mouse is not released over any menu item. Location specifies the desired topLeft of the menu body rectangle." | maxHeight | maxHeight _ Display height*3//4. self frameHeight > maxHeight ifTrue: [^ self startUpSegmented: maxHeight withCaption: captionOrNil at: location]. Smalltalk isMorphic ifTrue: [selection _ Cursor normal showWhile: [(MVCMenuMorph from: self title: captionOrNil) invokeAt: location in: World]. ^ selection]. frame ifNil: [self computeForm]. Cursor normal showWhile: [self displayAt: location withCaption: captionOrNil during: [self controlActivity]]. ^ selection! ! !PopUpMenu methodsFor: 'displaying' stamp: 'sw 12/10/1999 09:55'! displayAt: aPoint withCaption: captionOrNil during: aBlock "Display the receiver just to the right of aPoint while aBlock is evaluated. If the receiver is forced off screen, display it just to the right." | delta savedArea captionForm captionSave outerFrame captionText tFrame frameSaveLoc captionBox | marker ifNil: [self computeForm]. frame _ frame align: marker leftCenter with: aPoint + (2@0). outerFrame _ frame. captionOrNil notNil ifTrue: [captionText _ (DisplayText text: captionOrNil asText textStyle: MenuStyle copy centered) foregroundColor: Color black backgroundColor: Color white. tFrame _ captionText boundingBox insetBy: -2. outerFrame _ frame merge: (tFrame align: tFrame bottomCenter with: frame topCenter + (0@2))]. delta _ outerFrame amountToTranslateWithin: Display boundingBox. frame right > Display boundingBox right ifTrue: [delta _ 0 - frame width @ delta y]. frame _ frame translateBy: delta. captionOrNil notNil ifTrue: [captionForm _ captionText form. captionBox _ captionForm boundingBox expandBy: 4. captionBox _ captionBox align: captionBox bottomCenter with: frame topCenter + (0@2). captionSave _ Form fromDisplay: captionBox. Display border: captionBox width: 4 fillColor: Color white. Display border: captionBox width: 2 fillColor: Color black. captionForm displayAt: captionBox topLeft + 4]. marker _ marker align: marker leftCenter with: aPoint + delta + (2@0). savedArea _ Form fromDisplay: frame. self menuForm displayOn: Display at: (frameSaveLoc _ frame topLeft). selection ~= 0 ifTrue: [Display reverse: marker]. Cursor normal showWhile: [aBlock value]. savedArea displayOn: Display at: frameSaveLoc. captionOrNil notNil ifTrue: [captionSave displayOn: Display at: captionBox topLeft]! ! !PopUpMenu methodsFor: 'marker adjustment' stamp: 'di 4/13/1999 17:42'! manageMarker "If the cursor is inside the receiver's frame, then highlight the marked item. Otherwise no item is to be marked." | pt | "Don't let pt get far from display box, so scrolling will go all the way" pt _ Sensor cursorPoint adhereTo: (Display boundingBox expandBy: 1). (frame inside containsPoint: pt) ifTrue: ["Need to cache the form for reasonable scrolling performance" ((Display boundingBox insetBy: 0@3) containsPoint: pt) ifFalse: [pt _ pt - (self scrollIntoView: pt)]. self markerOn: pt] ifFalse: [self markerOff]! ! !PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 5/28/2000 15:27'! markerOff "No item is selected. Reverse the highlight if any item has been marked as selected." self setSelection: 0! ! !PopUpMenu methodsFor: 'marker adjustment' stamp: 'sma 6/1/2000 13:01'! markerOn: aPoint "The item whose bounding area contains aPoint should be marked as selected. Highlight its area and set the selection to its index." selection = 0 | (marker containsPoint: aPoint) not ifTrue: [selection = 0 & (marker containsPoint: aPoint) ifTrue: [Display reverse: marker] ifFalse: [selection > 0 ifTrue: [Display reverse: marker]. marker _ marker align: marker topLeft with: marker left @ (self markerTop: aPoint). Display reverse: marker]]. selection _ marker top - frame top // marker height + 1! ! !PopUpMenu methodsFor: 'private' stamp: 'sma 6/1/2000 12:59'! computeForm "Compute and answer a Form to be displayed for this menu." | borderInset paraForm menuForm inside | borderInset _ 4@4. paraForm _ (DisplayText text: labelString asText textStyle: MenuStyle) form. menuForm _ Form extent: paraForm extent + (borderInset * 2). menuForm borderWidth: 2. paraForm displayOn: menuForm at: borderInset. lineArray == nil ifFalse: [lineArray do: [ :line | menuForm fillBlack: (4 @ ((line * font height) + borderInset y) extent: (menuForm width - 8 @ 1))]]. frame _ Quadrangle new. frame region: menuForm boundingBox. frame borderWidth: 4. inside _ frame inside. marker _ inside topLeft extent: (inside width @ MenuStyle lineGrid). selection _ 1. ^ form _ menuForm ! ! !PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 16:21'! labels: aString font: aFont lines: anArray labelString _ aString. font _ aFont. lineArray _ anArray. ! ! !PopUpMenu methodsFor: 'private' stamp: 'di 4/13/1999 17:51'! menuForm "Answer a Form to be displayed for this menu." form == nil ifTrue: [self computeForm]. ^ form! ! !PopUpMenu methodsFor: 'private' stamp: 'sma 2/5/2000 11:56'! rescan "Cause my form to be recomputed after a font change." labelString == nil ifTrue: [labelString _ 'NoText!!']. self labels: labelString font: (MenuStyle fontAt: 1) lines: lineArray. frame _ marker _ form _ nil. "PopUpMenu allSubInstancesDo: [:m | m rescan]"! ! !PopUpMenu methodsFor: 'selecting' stamp: 'sma 5/28/2000 12:27'! selection "Answer the current selection." ^ selection! ! !PopUpMenu methodsFor: 'selecting' stamp: 'sma 6/1/2000 11:01'! setSelection: index | newSelection | selection = index ifTrue: [^ self]. newSelection _ (0 max: index) min: frame height // marker height. selection > 0 ifTrue: [Display reverse: marker]. marker _ marker translateBy: 0 @ (newSelection - selection * marker height). selection _ newSelection. selection > 0 ifTrue: [Display reverse: marker]! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 13:08'! initialize "PopUpMenu initialize" (MenuStyle _ TextStyle default copy) gridForFont: TextStyle default defaultFontIndex withLead: 0; centered. PopUpMenu allSubInstancesDo: [:m | m rescan]! ! !PopUpMenu class methodsFor: 'class initialization' stamp: 'jm 10/5/2002 06:56'! setMenuFontTo: aFont MenuStyle _ aFont textStyle copy consistOnlyOf: aFont. MenuStyle gridForFont: 1 withLead: 0; centered. self allSubInstancesDo: [:m | m rescan]. ! ! !PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:44'! labelArray: labelArray "Answer an instance of me whose items are in labelArray." ^ self labelArray: labelArray lines: nil! ! !PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:43'! labelArray: labelArray lines: lineArray "Answer an instance of me whose items are in labelArray, with lines drawn after each item indexed by anArray. 2/1/96 sw" labelArray isEmpty ifTrue: [self error: 'Menu must not be zero size']. ^ self labels: (String streamContents: [:stream | labelArray do: [:each | stream nextPutAll: each; cr]. stream skip: -1 "remove last CR"]) lines: lineArray "Example: (PopUpMenu labelArray: #('frog' 'and' 'toad') lines: #()) startUp"! ! !PopUpMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 15:36'! labels: aString "Answer an instance of me whose items are in aString." ^ self labels: aString lines: nil! ! !PopUpMenu class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 17:55'! labels: aString lines: anArray "Answer an instance of me whose items are in aString, with lines drawn after each item indexed by anArray." ^ self new labels: aString font: MenuStyle defaultFont lines: anArray! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:48'! confirm: queryString "Put up a yes/no menu with caption queryString. Answer true if the response is yes, false if no. This is a modal question--the user must respond yes or no." "PopUpMenu confirm: 'Are you hungry?'" ^ self confirm: queryString trueChoice: 'Yes' falseChoice: 'No'! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 6/5/2000 09:11'! confirm: queryString orCancel: cancelBlock "Put up a yes/no/cancel menu with caption aString. Answer true if the response is yes, false if no. If cancel is chosen, evaluate cancelBlock. This is a modal question--the user must respond yes or no." "PopUpMenu confirm: 'Reboot universe' orCancel: [^'Nevermind']" | menu choice | menu _ PopUpMenu labelArray: {'Yes'. 'No'. 'Cancel'}. choice _ menu startUpWithCaption: queryString. choice = 1 ifTrue: [^ true]. choice = 2 ifTrue: [^ false]. ^ cancelBlock value! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 6/5/2000 09:12'! confirm: queryString trueChoice: trueChoice falseChoice: falseChoice "Put up a yes/no menu with caption queryString. The actual wording for the two choices will be as provided in the trueChoice and falseChoice parameters. Answer true if the response is the true-choice, false if it's the false-choice. This is a modal question -- the user must respond one way or the other." "PopUpMenu confirm: 'Are you hungry?' trueChoice: 'yes, I''m famished' falseChoice: 'no, I just ate'" | menu choice | menu _ PopUpMenu labelArray: {trueChoice. falseChoice}. [(choice _ menu startUpWithCaption: queryString) isNil] whileTrue. ^ choice = 1! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'! inform: aString "PopUpMenu inform: 'I like Squeak'" (PopUpMenu labels: ' OK ') startUpWithCaption: aString! ! !PopUpMenu class methodsFor: 'dialogs' stamp: 'sma 5/28/2000 15:57'! notify: message "Deprecated. Use #inform: instead." self inform: message! ! I represent an accessor for a sequence of objects (a collection) that are externally named by indices so that the point of access can be repositioned. I am abstract in that I do not implement the messages next and nextPut: which are inherited from my superclass Stream.! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:58'! next: n into: aCollection "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." ^self next: n into: aCollection startingAt: 1! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:54'! next: n into: aCollection startingAt: startIndex "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." | obj | 0 to: n-1 do:[:i| (obj _ self next) == nil ifTrue:[^aCollection copyFrom: 1 to: startIndex+i-1]. aCollection at: startIndex+i put: obj]. ^aCollection! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'! next: anInteger putAll: aCollection "Store the next anInteger elements from the given collection." ^self next: anInteger putAll: aCollection startingAt: 1! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 1/2/2000 15:32'! next: anInteger putAll: aCollection startingAt: startIndex "Store the next anInteger elements from the given collection." 0 to: anInteger-1 do:[:i| self nextPut: (aCollection at: startIndex + i). ]. ^aCollection! ! !PositionableStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 14:53'! nextInto: aCollection "Read the next elements of the receiver into aCollection. Return aCollection or a partial copy if less than aCollection size elements have been read." ^self next: aCollection size into: aCollection startingAt: 1.! ! !PositionableStream methodsFor: 'accessing' stamp: 'bf 11/24/1998 13:35'! nextLine "Answer next line (may be empty), or nil if at end" self atEnd ifTrue: [^nil]. ^self upTo: Character cr! ! !PositionableStream methodsFor: 'accessing' stamp: 'jm 5/29/2003 18:03'! nextWordsInto: aBitmap | blt pos mainX mainY frontX frontY little source | "Fill the word based buffer from my collection. Stored on stream as Little Endian. Optimized for speed." (collection class isBytes) ifTrue: ["1 to: aBitmap size do: [:index | aBitmap at: index put: (self nextNumber: 4)]." little _ Smalltalk endianness == #little. collection basicSize \\ 4 = 0 ifTrue: [source _ collection. pos _ self position. self skip: aBitmap size * aBitmap bytesPerElement "1, 2, or 4"] ifFalse: [source _ self next: aBitmap size * aBitmap bytesPerElement. "forced to copy it into a buffer" pos _ 0]. mainX _ pos \\ 4. mainY _ pos // 4. "two Blts required if not word aligned" frontX _ 0. frontY _ mainY + 1. blt _ (BitBlt toForm: (Form new hackBits: aBitmap)) sourceForm: (Form new hackBits: source). blt combinationRule: Form over. "store" blt sourceX: mainX; sourceY: mainY; height: aBitmap basicSize; width: 4-mainX. blt destX: 0; destY: 0. little ifTrue: [blt sourceX: 0; destX: mainX]. "just happens to be this way!!" blt copyBits. mainX = 0 ifTrue: [^ aBitmap]. "second piece when not word aligned" blt sourceX: frontX; sourceY: frontY; height: aBitmap size; width: mainX. blt destX: 4-mainX; destY: 0. little ifTrue: [blt sourceX: 4-mainX; destX: frontX]. "draw picture to understand this" blt copyBits. ^ aBitmap]. ^ self next: aBitmap size into: aBitmap startingAt: 1. ! ! !PositionableStream methodsFor: 'accessing' stamp: 'tk 7/18/1999 17:10'! upToAll: aCollection "Answer a subcollection from the current access position to the occurrence (if any, but not inclusive) of aCollection. If aCollection is not in the stream, answer the entire rest of the stream." | startPos endMatch result | startPos _ self position. (self match: aCollection) ifTrue: [endMatch _ self position. self position: startPos. result _ self next: endMatch - startPos - aCollection size. self position: endMatch. ^ result] ifFalse: [self position: startPos. ^ self upToEnd]! ! !PositionableStream methodsFor: 'testing' stamp: 'ar 1/2/2000 17:24'! isBinary "Return true if the receiver is a binary byte stream" ^collection class == ByteArray! ! !PositionableStream methodsFor: 'positioning' stamp: 'hmm 10/22/1999 21:18'! match: subCollection "Set the access position of the receiver to be past the next occurrence of the subCollection. Answer whether subCollection is found. No wildcards, and case does matter." | pattern startMatch | pattern _ ReadStream on: subCollection. startMatch _ nil. [pattern atEnd] whileFalse: [self atEnd ifTrue: [^ false]. (self next) = (pattern next) ifTrue: [pattern position = 1 ifTrue: [startMatch _ self position]] ifFalse: [pattern position: 0. startMatch ifNotNil: [ self position: startMatch. startMatch _ nil]]]. ^ true ! ! !PositionableStream methodsFor: 'nonhomogeneous accessing' stamp: 'di 12/6/1999 10:13'! nextLittleEndianNumber: n put: value "Answer the next n bytes as a positive Integer or LargePositiveInteger, where the bytes are ordered from least significant to most significant." | bytes | bytes _ ByteArray new: n. 1 to: n do: [: i | bytes at: i put: (value digitAt: i)]. self nextPutAll: bytes! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:09'! boolean "Answer the next boolean value from this (binary) stream." ^ self next ~= 0 ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 10/5/2001 12:11'! boolean: aBoolean "Store the given boolean value on this (binary) stream." self nextPut: (aBoolean ifTrue: [1] ifFalse: [0]). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:43'! int16 "Answer the next signed, 16-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + (self next). n >= 16r8000 ifTrue: [n _ n - 16r10000]. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:44'! int16: anInteger "Store the given signed, 16-bit integer on this (binary) stream." | n | (anInteger < -16r8000) | (anInteger >= 16r8000) ifTrue: [self error: 'outside 16-bit integer range']. anInteger < 0 ifTrue: [n _ 16r10000 + anInteger] ifFalse: [n _ anInteger]. self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 15:15'! int32 "Answer the next signed, 32-bit integer from this (binary) stream." "Details: As a fast check for negative number, check the high bit of the first digit" | n firstDigit | n _ firstDigit _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. firstDigit >= 128 ifTrue: [n _ -16r100000000 + n]. "decode negative 32-bit integer" ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 7/16/2001 14:46'! int32: anInteger "Store the given signed, 32-bit integer on this (binary) stream." | n | (anInteger < -16r80000000) | (anInteger >= 16r80000000) ifTrue: [self error: 'outside 32-bit integer range']. anInteger < 0 ifTrue: [n _ 16r100000000 + anInteger] ifFalse: [n _ anInteger]. self nextPut: (n digitAt: 4). self nextPut: (n digitAt: 3). self nextPut: (n digitAt: 2). self nextPut: (n digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 07:35'! string "Answer the next string from this (binary) stream." | size | size _ self uint16. ^ (self next: size) asString ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 9/5/2001 12:09'! string: aString "Store the given string on this (binary) stream. The string must contain 65535 or fewer characters." aString size > 16rFFFF ifTrue: [self error: 'string too long for this format']. self uint16: aString size. self nextPutAll: aString asByteArray. ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16 "Answer the next unsigned, 16-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + (self next). ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16: anInteger "Store the given unsigned, 16-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r10000) ifTrue: [self error: 'outside unsigned 16-bit integer range']. self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24 "Answer the next unsigned, 24-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24: anInteger "Store the given unsigned, 24-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r1000000) ifTrue: [self error: 'outside unsigned 24-bit integer range']. self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint32 "Answer the next unsigned, 32-bit integer from this (binary) stream." | n | n _ self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. n _ (n bitShift: 8) + self next. ^ n ! ! !PositionableStream methodsFor: 'data get/put' stamp: 'jm 8/20/2001 07:52'! uint32: anInteger "Store the given unsigned, 32-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r100000000) ifTrue: [self error: 'outside unsigned 32-bit integer range']. self nextPut: (anInteger digitAt: 4). self nextPut: (anInteger digitAt: 3). self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 9/29/1999 07:37'! adjustBookControls | inner | proceedButton ifNil: [^ self]. proceedButton align: proceedButton topLeft with: (inner _ self innerBounds) topLeft + (35@-4). debugButton align: debugButton topRight with: inner topRight - (16@4).! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! debug model debug! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 11/4/1998 09:50'! extent: newExtent super extent: (newExtent max: 100 @ 50). self adjustBookControls! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 18:06'! initialize | aFont proceedLabel debugLabel aWidth | super initialize. true "Preferences optionalMorphicButtons" ifFalse: [(aWidth _ self widthOfFullLabelText) > 280 ifTrue: [^ self]. "No proceed/debug buttons if title too long" aWidth > 210 ifTrue: "Abbreviated buttons if title pretty long" [proceedLabel _ 'p'. debugLabel _ 'd'] ifFalse: "Full buttons if title short enough" [proceedLabel _ 'proceed'. debugLabel _ 'debug']. aFont _ Preferences standardButtonFont. self addMorph: (proceedButton _ SimpleButtonMorph new borderWidth: 0; label: proceedLabel font: aFont; color: Color transparent; actionSelector: #proceed; target: self). proceedButton setBalloonText: 'continue execution'. self addMorph: (debugButton _ SimpleButtonMorph new borderWidth: 0; label: debugLabel font: aFont; color: Color transparent; actionSelector: #debug; target: self). debugButton setBalloonText: 'bring up a debugger'. proceedButton submorphs first color: Color blue. debugButton submorphs first color: Color red]. self adjustBookControls! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! proceed model proceed! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'tk 1/3/2000 12:54'! setLabelWidgetAllowance ^ labelWidgetAllowance _ (Smalltalk isMorphic | Preferences optionalButtons) ifTrue: [super setLabelWidgetAllowance] ifFalse: [180]! ! A general mechanism to store preference choices. The default setup treats any symbol as a potential boolean flag; flags unknown to the preference dictionary are always returned as false. It is also possible to store non-boolean data in the preference table. sw 8/91! !Preferences class methodsFor: 'initialization' stamp: 'sw 2/15/2000 18:40'! absorbAdditions "Preferences absorbAdditions" self initializeAddedPreferences. self initializeHelpMessages. self resetCategoryInfo! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 1/12/2000 22:34'! allPreferenceInitializationSpecs "Preferences allPreferenceInitializationSpecs" | aList additions | aList _ OrderedCollection new. (self class organization listAtCategoryNamed: 'initial values' asSymbol) do: [:aSelector | aSelector numArgs = 0 ifTrue: [additions _ self perform: aSelector. (additions isKindOf: Collection) ifFalse: [self error: 'method in "initial values" categories must return collections']. aList addAll: additions]]. ^ aList ! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:03'! callHelpMessageInitializers | listOfPairs | "Preferences callHelpMessageInitializers" (self class organization listAtCategoryNamed: #help) do: [:aSelector | aSelector numArgs = 0 ifTrue: [((listOfPairs _ self perform: aSelector) isKindOf: Collection) ifTrue: [listOfPairs do: [:pair | HelpDictionary at: pair first put: (pair first, ': ', pair last)]]]]! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:17'! chooseInitialSettings "Restore the default choices for Preferences." "Preferences chooseInitialSettings" self allPreferenceInitializationSpecs do: [:aSpec | aSpec second == #true ifTrue: [self enable: aSpec first] ifFalse: [self disable: aSpec first]]. self resetCategoryInfo ! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 7/1/1999 23:17'! compileAccessMethodFor: prefSymbol self class compileProgrammatically: (prefSymbol, ' ^ self valueOfFlag: #', prefSymbol) classified: 'standard preferences'! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 9/19/1998 22:47'! initialize "Preferences initialize" "Sometimes placed in a change-set even though unchanged, to trigger reinitialization upon update." FlagDictionary _ Dictionary new. self chooseInitialSettings. ! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 14:16'! initializeAddedPreferences "Initialize any preference not yet known to the prefs dictionary as per descriptions in the 'initial values' category, but don't change the setting of any existing preference. Also, compile accessor methods for retrieving any preference that lacks one" "Preferences initializeAddedPreferences" | sym | self allPreferenceInitializationSpecs do: [:triplet | (self class selectors includes: (sym _ triplet first)) ifFalse: [self compileAccessMethodFor: sym]. (FlagDictionary includesKey: sym) ifFalse: [triplet second == #true ifTrue: [self enable: sym] ifFalse: [self disable: sym]]]. self resetCategoryInfo ! ! !Preferences class methodsFor: 'initialization' stamp: 'sw 1/13/2000 13:49'! initializeHelpMessages "Preferences initializeHelpMessages" HelpDictionary _ Dictionary new. self callHelpMessageInitializers! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 10/19/1999 22:39'! annotationInfo ^ #( (timeStamp 'The time stamp of the last submission of the method.') (messageCategory 'Which method category the method lies in') (sendersCount 'A report of how many senders there of the message.') (implementorsCount 'A report of how many implementors there are of the message.') (recentChangeSet 'The most recent change set bearing the method.') (allChangeSets 'A list of all change sets bearing the method.') (priorVersionsCount 'A report of how many previous versions there are of the method' ) (priorTimeStamp 'The time stamp of the penultimate submission of the method, if any'))! ! !Preferences class methodsFor: 'parameters' stamp: 'jm 6/15/2003 12:35'! defaultAnnotationRequests (Parameters includesKey: #MethodAnnotations) ifFalse: [ Parameters at: #MethodAnnotations put: #(timeStamp messageCategory implementorsCount allChangeSets)]. ^ Parameters at: #MethodAnnotations ! ! !Preferences class methodsFor: 'parameters' stamp: 'jm 6/15/2003 12:36'! defaultAnnotationRequests: newList ^ Parameters at: #MethodAnnotations put: newList ! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 2/1/2000 14:05'! defaultPaintingExtent "Answer the preferred size for the onion-skin paint area when launching a new painting within a paste-up morph. Feel free to change the parameters to suit your configuration." ^ 800 @ 600! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 9/7/1999 12:45'! initializeParameters "Preferences initializeParameters" Parameters _ IdentityDictionary new. self restoreDefaultMenuParameters. Parameters at: #maxBalloonHelpLineLength put: 28. self initializeTextHighlightingParameters! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 11/5/1998 16:49'! maxBalloonHelpLineLength ^ Parameters at: #maxBalloonHelpLineLength! ! !Preferences class methodsFor: 'parameters' stamp: 'sw 1/27/2000 23:02'! parameterAt: aKey ^ Parameters at: aKey ifAbsent: [nil]! ! !Preferences class methodsFor: 'parameters' stamp: 'stp 01/13/2000 13:29'! setParameter: paramName to: paramValue "Set the given field in the parameters dictionary." Parameters at: paramName put: paramValue! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:52'! disable: preferenceNameSymbol "Shorthand access" self setPreference: preferenceNameSymbol toValue: false. self resetCategoryInfo "in case this call introduced a new pref"! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 5/23/2003 12:44'! doesNotUnderstand: aMessage "If the given message is unary, look up it's selector as a flag." aMessage arguments size > 0 ifTrue: [^ super doesNotUnderstand: aMessage]. ^ self valueOfFlag: aMessage selector ! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/19/2000 13:53'! enable: preferenceNameSymbol "Shorthand access" self setPreference: preferenceNameSymbol toValue: true. self resetCategoryInfo "in case this call introduced a new pref"! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 10/5/2002 06:54'! noteThatFlag: prefSymbol justChangedTo: aBoolean "Provides a hook so that a user's toggling of a preference might precipitate some immediate action." prefSymbol == #roundedWindowCorners ifTrue: [ Smalltalk isMorphic ifTrue: [World fullRepaintNeeded]]. (prefSymbol == #smartUpdating) ifTrue: [SystemWindow allSubInstancesDo: [:aWindow | aWindow amendSteppingStatus]]. ! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 10/16/2002 13:02'! openPreferencesInspector "Open a window on the current set of preferences choices, allowing the user to view and change their settings. If there is no Morphic in this image, use a dictionary inspector." Smalltalk hasMorphic ifFalse: [FlagDictionary inspectWithLabel: 'Preferences'] ifTrue: [self openPreferencesControlPanel]. ! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 5/29/2003 19:28'! orphanedHelpEntries "Answer a list of all the keys in the help dictionary that are not represented by actual preferences" "Preferences orphanedHelpEntries" | allFlags | allFlags _ self allPreferenceFlagKeys. ^ HelpDictionary keys asArray sort select: [:k | (allFlags includes: k) not] ! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'sw 1/13/2000 11:12'! preferencesLackingHelp ^ self allPreferenceFlagKeys select: [:aKey | (self helpMessageOrNilForPreference: aKey) == nil] "Preferences preferencesLackingHelp"! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 5/29/2003 19:31'! preferencesLackingInitializers "Preferences preferencesLackingInitializers" | initializedPrefs | initializedPrefs _ self allPreferenceInitializationSpecs collect: [:info | info first]. ^ self allPreferenceFlagKeys select: [:k | (initializedPrefs includes: k) not] ! ! !Preferences class methodsFor: 'preferences dictionary' stamp: 'jm 10/5/2002 06:56'! setPreference: prefSymbol toValue: aBoolean (FlagDictionary at: prefSymbol ifAbsent: [nil]) ~~ aBoolean ifTrue: [ FlagDictionary at: prefSymbol put: aBoolean. self noteThatFlag: prefSymbol justChangedTo: aBoolean]. ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 6/5/2003 21:28'! addHaloControlsTo: controlPage controlPage addTransparentSpacerOfSize: (0 @ 4). controlPage addMorphBack: self haloThemeRadioButtons. controlPage addTransparentSpacerOfSize: (0 @ 4). ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 5/29/2003 19:03'! allPreferenceFlagKeys "Preferences allPreferenceFlagKeys" ^ FlagDictionary keys asArray sort ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 6/15/2003 16:43'! defaultBackgroundColor "The background for the preferences control panel." ^ Color white ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 5/29/2003 19:02'! factoredCategories "Preferences factoredCategories" "CategoryInfo _ nil" | prefsWithoutInits extraItem | CategoryInfo ifNil: [CategoryInfo _ self initialCategoryInfo]. ((prefsWithoutInits _ self preferencesLackingInitializers) size > 0) ifTrue: [extraItem _ (Array with: 'uncategorized' with: prefsWithoutInits copy asArray sort)]. ^ extraItem ifNil: [CategoryInfo] ifNotNil: [CategoryInfo, (Array with: extraItem)] ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/13/2000 11:07'! helpMessageForPreference: aSymbol ^ (self helpMessageOrNilForPreference: aSymbol) ifNil: ['No help available for ', aSymbol]! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/13/2000 11:07'! helpMessageOrNilForPreference: aSymbol "If the HelpDictionary has a help message prepared for aSymbol, return it, else return nil" HelpDictionary ifNil: [self initializeHelpMessages]. ^ HelpDictionary at: aSymbol ifAbsent: [nil]! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 5/29/2003 19:04'! initialCategoryInfo | categories | categories _ IdentityDictionary new. self allPreferenceInitializationSpecs do: [:spec | spec size > 2 ifTrue: [ spec third do: [:sym | (categories includesKey: sym) ifFalse: [categories at: sym put: OrderedCollection new]. (categories at: sym) add: spec first]]]. ^ categories keys copy asArray sort collect: [:k | Array with: k with: (categories at: k) copy asArray sort] ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'jm 12/7/2002 18:10'! openPreferencesControlPanel "Preferences openPreferencesControlPanel" | panels panelColor panel prefsPanel window | panels _ Dictionary new. panelColor _ Color r: 0.645 g: 1.0 b: 1.0. self factoredCategories do: [:entry | panel _ (AlignmentMorph newColumn isSticky: true) color: panelColor. panel borderColor: panelColor; inset: 4. entry second do: [:pref | panel addMorphBack: (Preferences buttonRepresenting: pref wording: pref color: nil)]. entry first == #halos ifTrue: [self addHaloControlsTo: panel]. panels at: entry first put: panel]. prefsPanel _ CategorizedControlPanel new panels: panels. prefsPanel currentCategory: 'general'. prefsPanel extent: 194@212. Smalltalk isMorphic ifTrue: [ window _ (SystemWindow labelled: 'Preferences') model: nil. window bounds: (0@0 extent: 220@270). window addMorph: prefsPanel frame: (0@0 extent: 1@1). window updatePaneColors. window setProperty: #minimumExtent toValue: 220@270. self currentHand attachMorph: window. self currentWorld startSteppingSubmorphsOf: window] ifFalse: [ (window _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: prefsPanel. window startSteppingSubmorphsOf: prefsPanel. MorphWorldView openOn: window label: 'Preferences' extent: prefsPanel extent + 2]. ! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 1/19/2000 13:43'! resetCategoryInfo "Preferences resetCategoryInfo" CategoryInfo _ nil! ! !Preferences class methodsFor: 'preferences panel' stamp: 'sw 11/11/1998 16:39'! setHelpFor: prefName toString: aString HelpDictionary ifNil: [self initializeHelpMessages]. HelpDictionary at: prefName put: aString! ! !Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:16'! menuBorderColor Display depth <= 2 ifTrue: [^ Color black]. ^ Parameters at: #menuBorderColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'! menuBorderWidth ^ Parameters at: #menuBorderWidth! ! !Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:17'! menuColor Display depth <= 2 ifTrue: [^ Color white]. ^ Parameters at: #menuColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:37'! menuLineLowerColor ^ Parameters at: #menuLineLowerColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:36'! menuLineUpperColor ^ Parameters at: #menuLineUpperColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:19'! menuTitleBorderColor Display depth <= 2 ifTrue: [^ Color black]. ^ Parameters at: #menuTitleBorderColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:16'! menuTitleBorderWidth ^ Parameters at: #menuTitleBorderWidth! ! !Preferences class methodsFor: 'menu parameters' stamp: 'di 1/14/1999 20:18'! menuTitleColor Display depth = 1 ifTrue: [^ Color white]. Display depth = 2 ifTrue: [^ Color gray]. ^ Parameters at: #menuTitleColor! ! !Preferences class methodsFor: 'menu parameters' stamp: 'sw 11/3/1998 11:33'! restoreDefaultMenuParameters "Preferences restoreDefaultMenuParameters" "Restore the four color choices of the original implementors of MorphicMenus" Parameters at: #menuColor put: (Color r: 0.8 g: 0.8 b: 0.8). Parameters at: #menuBorderColor put: #raised. Parameters at: #menuBorderWidth put: 2. Parameters at: #menuTitleColor put: (Color r: 0.5 g: 1 b: 0.75). Parameters at: #menuTitleBorderColor put: #inset. Parameters at: #menuTitleBorderWidth put: 1. Parameters at: #menuLineUpperColor put: (Color r: 0.667 g: 0.667 b: 0.667). Parameters at: #menuLineLowerColor put: (Color r: 0.833 g: 0.833 b: 0.833).! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'jm 10/4/2002 15:02'! browseToolClass ^ Browser ! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'! cmdGesturesEnabled "compiled programatically -- return hard-coded preference value" ^ true! ! !Preferences class methodsFor: 'hard-coded prefs' stamp: 'programmatic 7/15/1999 09:55'! cmdKeysInText "compiled programatically -- return hard-coded preference value" ^ true! ! !Preferences class methodsFor: 'pref buttons' stamp: 'jm 6/15/2003 11:52'! buttonRepresenting: prefSymbol wording: aString color: aColor "self currentHand attachMorph: (Preferences buttonRepresenting: #balloonHelpEnabled wording: 'Balloon Help' color: nil)" "Return a button that controls the setting of prefSymbol. It will keep up to date even if the preference value is changed in a different place" | outerButton aButton str aHelp miniWrapper | (FlagDictionary includesKey: prefSymbol) ifFalse: [self error: 'Unknown preference: ', prefSymbol printString]. outerButton _ AlignmentMorph newRow height: 24. outerButton color: (aColor ifNil: [Color r: 0.645 g: 1.0 b: 1.0]). outerButton hResizing: #spaceFill; vResizing: #shrinkWrap. outerButton addMorph: (aButton _ ThreePhaseButtonMorph checkBox). aButton target: self; actionSelector: #togglePreference:; arguments: (Array with: prefSymbol); target: Preferences; getSelector: prefSymbol. outerButton addTransparentSpacerOfSize: (2 @ 0). str _ StringMorph contents: aString font: (StrikeFont familyName: 'NewYork' size: 12). miniWrapper _ AlignmentMorph newRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. miniWrapper color: Color transparent. miniWrapper addMorphBack: str lock. outerButton addMorphBack: miniWrapper. aButton setBalloonText: (aHelp _ Preferences helpMessageForPreference: prefSymbol). miniWrapper setBalloonText: aHelp; setProperty: #balloonTarget toValue: aButton. ^ outerButton! ! !Preferences class methodsFor: 'pref buttons' stamp: 'sw 7/13/1999 18:55'! togglePreference: prefSymbol | curr | curr _ (FlagDictionary at: prefSymbol ifAbsent: [^ self error: 'unknown pref: ', prefSymbol printString]). self setPreference: prefSymbol toValue: (curr == true) not ! ! !Preferences class methodsFor: 'misc' stamp: 'sw 10/6/1999 15:20'! addModelItemsToWindowMenu: aMenu aMenu addLine. aMenu add: 'restore default preference settings' target: self action: #chooseInitialSettings. aMenu add: 'restore default text highlighting' target: self action: #initializeTextHighlightingParameters! ! !Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'! menuColorString ^ (self valueOfFlag: #menuColorFromWorld) ifFalse: ['start menu-color-from-world'] ifTrue: ['stop menu-color-from-world']! ! !Preferences class methodsFor: 'misc' stamp: 'sw 11/30/1999 22:23'! roundedCornersString ^ ((self valueOfFlag: #roundedWindowCorners) ifFalse: ['start'] ifTrue: ['stop']), ' rounding window corners'! ! !Preferences class methodsFor: 'misc' stamp: 'sw 6/11/1999 20:53'! staggerPolicyString ^ (self valueOfFlag: #reverseWindowStagger) ifTrue: ['switch to tiling'] ifFalse: ['switch to staggering']! ! !Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:51'! toggleMenuColorPolicy self togglePreference: #menuColorFromWorld! ! !Preferences class methodsFor: 'misc' stamp: 'sw 7/13/1999 16:52'! toggleRoundedCorners self togglePreference: #roundedWindowCorners! ! !Preferences class methodsFor: 'misc' stamp: 'sw 6/11/1999 20:49'! toggleWindowPolicy self togglePreference: #reverseWindowStagger! ! !Preferences class methodsFor: 'personalization' stamp: 'sw 7/1/1999 23:07'! compileHardCodedPref: prefName enable: aBoolean "Compile a method that returns a simple true or false (depending on the value of aBoolean) when Preferences is sent prefName as a message" self class compileProgrammatically: (prefName asString, ' "compiled programatically -- return hard-coded preference value" ^ ', aBoolean storeString) classified: 'hard-coded prefs'. "Preferences compileHardCodedPref: #testing enable: false"! ! !Preferences class methodsFor: 'personalization' stamp: 'sw 6/29/1999 13:53'! disableProgrammerFacilities "Warning: do not call this lightly!! It disables all access to menus, debuggers, halos. There is no guaranteed return from this, which is to say, you cannot necessarily reenable these things once they are disabled -- you can only use whatever the UI of the current project affords, and you cannot even snapshot -- you can only quit. You can completely reverse the work of this method by calling the dual Preferences method enableProgrammerFacilities, provided you have left yourself leeway to bring about a call to that method. To set up a system that will come up in such a state, you have to request the snapshot in the same breath as you disable the programmer facilities. To do this, put the following line into the 'do' menu and then evaluate it from that 'do' menu: Preferences disableProgrammerFacilities. You will be prompted for a new image name under which to save the resulting image." self beep. (self confirm: 'CAUTION!!!! This is a drastic step!! Do you really want to do this?') ifFalse: [self beep. ^ self inform: 'whew!!']. self disable: #cmdDotEnabled. "No user-interrupt-into-debugger" self compileHardCodedPref: #cmdGesturesEnabled enable: false. "No halos, etc." self compileHardCodedPref: #cmdKeysInText enable: false. "No user commands invokable via cmd-key combos in text editor" self enable: #noviceMode. "No control-menu" self disable: #warnIfNoSourcesFile. self disable: #warnIfNoChangesFile. Smalltalk saveAs! ! !Preferences class methodsFor: 'personalization' stamp: 'sw 6/29/1999 13:55'! enableProgrammerFacilities "Meant as a one-touch recovery from a #disableProgrammerFacilities call." "Preferences enableProgrammerFacilities" self enable: #cmdDotEnabled. self compileHardCodedPref: #cmdGesturesEnabled enable: true. self compileHardCodedPref: #cmdKeysInText enable: true. self disable: #noviceMode. self enable: #warnIfNoSourcesFile. self enable: #warnIfNoChangesFile.! ! !Preferences class methodsFor: 'help' stamp: 'jm 10/16/2002 12:33'! helpMsgsAThroughF "This, and the other methodds in this category, are automatically called whenever you call: Preferences initializeHelpMessages or Preferences callHelpMessageInitializers" ^ #( (annotationPanes 'If true, a thin horizontal annotation pane is used in browsers.') (balloonHelpEnabled 'Whether balloon help should be offered when the cursor lingers over certain objects.') (browseWithPrettyPrint 'If true, browsers will automatically format their contents') (cautionBeforeClosing 'If true, Morphic windows seen in an mvc project will put up a warning before allowing themselves to be dismissed') (caseSensitiveFinds 'If true, then the "find" command in text will always make its searches in a case-sensitive fashion') (changeSetVersionNumbers 'If true, version-number extensions will be used when constructing names for change-set fileouts. If false, timestamp extensions are used.') (checkForSlips 'If true, then whenever you file out a change set, it is checked for ''slips'' and if any are found, you are so informed and given a chance to open a browser on them') (clickOnLabelToEdit 'If true, a click on the label of a system window lets you edit it; if false, allow dragging of system windows when clicking on the label') (cmdDotEnabled 'If true, cmd-dot brings up a debugger; if false, the cmd-dot interrupt is disabled') (colorWhenPrettyPrinting 'If true, then when browseWithPrettyPrint is in effect, the pretty-printing will be presented in color') (confirmFirstUseOfStyle 'If true, the first attempt to submit a method with non-standard style will bring up a confirmation dialog') (debugHaloHandle 'If true, a special debugging halo handle is displayed at the right of the halo; if false, no such handle is shown.') (diffsInChangeList 'If true, changeList browsers and Versions browsers will open up by default showing diffs, i.e. revealing the differences between successive versions or between the in-memory code and the code on disk') (fastDragWindowForMorphic 'If true, morphic window drag will be done by dragging an outline of the window.') ) "end of list" ! ! !Preferences class methodsFor: 'help' stamp: 'sw 2/15/2000 18:39'! helpMsgsAdditionA "This, and the other methodds in this category, are automatically called whenever you call Preferences initializeHelpMessages or Preferences callHelpMessageInitializers " ^ #( (simpleMenus 'If true, simpler menus are presented.') ) "Preferences resetCategoryInfo" ! ! !Preferences class methodsFor: 'help' stamp: 'programmatic 5/10/2000 15:45'! helpMsgsAdditionbrowsingalternativeBrowseIt ^ #((alternativeBrowseIt 'if true, then the "browse it" (cmd-b) feature in the text editor will offer you a list of class names matching the selection, if appropriate' ) )! ! !Preferences class methodsFor: 'help'! helpMsgsAdditionscrollinghiddenScrollBars ^ #((hiddenScrollBars 'If true, then scrollbars will only be shown if a pane''s contents are too large to fit inside the pane.' ) )! ! !Preferences class methodsFor: 'help' stamp: 'jm 10/16/2002 12:52'! helpMsgsGThroughP ^ #( (ignoreStyleIfOnlyBold 'If true, then any method submission in which the only style change is for bolding will be treated as a method with no style specifications') (inboardScrollbars 'If true, then ScrollPane will place scrollbars inside on the right and will not hide them on exit') (logDebuggerStackToFile 'If true, whenever you fall into a debugger a summary of its stack will be written to a file named ''SqueakDebug.log''') (menuColorFromWorld 'Governs whether the colors used in morphic menus should be derived from the color of the world background') (mvcProjectsAllowed 'If true, the open... menu will offer you the chance to open an mvc project') (noviceMode 'If true, certain novice-mode accommodations are made') (optionalButtons 'If true, then optional buttons will be used in certain standard tools, including browsers, message lists, fileLists, changeLists, and debuggers') (printAlternateSyntax 'If true, then prettyPrint using experimental syntax. Otherwise use normal ST-80 syntax') (projectZoom 'If true, then show a zoom effect when entering or leaving projects. This can be costly of memory (at least an extra screen buffer) so dont use it in low space situations. But it is cool') (promptForUpdateServer 'If false, the prompt for server choice when updating code from the server is suppressed. Set this to false to leave the server choice unchanged from update to update') ) ! ! !Preferences class methodsFor: 'help' stamp: 'jm 10/5/2002 07:22'! helpMsgsQThroughZ ^ #( (reverseWindowStagger 'If true, a reverse-stagger strategy is used for determining where newly launched windows will be placed; if false, a direct- stagger strategy is used.') (roundedMenuCorners 'Whether morphic menus should have rounded corners') (roundedWindowCorners 'Governs whether morphic system windows should have rounded corners') (scrollBarsNarrow 'If true, morphic scrollbars will be narrow.') (scrollBarsOnRight 'If true, morphic scrollbars in subsequently opened windows will appear on the right side of their pane.') (scrollBarsWithoutMenuButton 'If true, morphic scrollbars in subsequently opened windows will not include a menu button.') (smartUpdating 'If true, then morphic tools such as browsers and inspectors will keep their contents up to date automatically, so that if something changes anywhere, the change will be reflected everywhere.') (soundQuickStart 'If true, attempt to start playing sounds using optional "quick start"') (soundsEnabled 'If false, all sound playing is disabled') (systemWindowEmbedOK 'Determines whether, in Morphic, when a SystemWindow is dropped onto a willing receptor it should be deposited into that receptor.') (timeStampsInMenuTitles 'If true, then the author''s timestamp is displayed as the menu title of any message list; if false, no author''s timestamps are shown') (thoroughSenders 'If true, then ''senders'' browsers will dive inside structured literals in their search') (twentyFourHourFileStamps 'If #changeSetVersionNumbers is false, this preference determines whether the date/time suffix used with changeset fileouts is based on a 24-hr clock or a 12-hr clock.') (uniformWindowColors 'If true, then all standard windows are given the same color rather than their customized window-type-specific colors') (unlimitedPaintArea 'If true, the painting area for a new drawing will not be limited in size; if false, a reasonable limit will be applied, in an attempt to hold down memory and time price.') (updateRemoveSequenceNum 'If true, then remove the leading sequence number from the filename before automatically saving a local copy of any update loaded.') (updateSavesFile 'If true, then when an update is loaded from the server, a copy of it will automatically be saved on a local file as well.') (warnIfNoChangesFile 'If true, then you will be warned, whenever you start up, if no changes file can be found') (warnIfNoSourcesFile 'If true, then you will be warned, whenever you start up, if no sources file can be found') ) ! ! !Preferences class methodsFor: 'help' stamp: 'sw 5/9/2000 03:12'! moreHelpA ^ #( (systemWindowEmbedOK 'Determines whether, in Morphic, when a SystemWindow or MenuMorph is dropped onto a willing receptor, it should be deposited into that receptor.') ) ! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 5/10/2000 15:45'! alternativeBrowseIt ^ self valueOfFlag: #alternativeBrowseIt! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! annotationPanes ^ self valueOfFlag: #annotationPanes! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/16/2002 13:04'! autoAccessors ^ self valueOfFlag: #autoAccessors! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'! balloonHelpEnabled ^ self valueOfFlag: #balloonHelpEnabled! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'! browseWithPrettyPrint ^ self valueOfFlag: #browseWithPrettyPrint! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/16/2002 13:04'! browserShowsPackagePane ^ self valueOfFlag: #browserShowsPackagePane! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/1/1999 20:55'! caseSensitiveFinds ^ self valueOfFlag: #caseSensitiveFinds! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! cautionBeforeClosing ^ self valueOfFlag: #cautionBeforeClosing! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/13/1999 22:52'! changeSetVersionNumbers ^ self valueOfFlag: #changeSetVersionNumbers! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 12:21'! checkForSlips ^ self valueOfFlag: #checkForSlips! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! clickOnLabelToEdit ^ self valueOfFlag: #clickOnLabelToEdit! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:26'! cmdDotEnabled ^ self valueOfFlag: #cmdDotEnabled! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/6/1999 22:54'! colorWhenPrettyPrinting ^ self valueOfFlag: #colorWhenPrettyPrinting! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/16/2002 13:04'! compressFlashImages ^ self valueOfFlag: #compressFlashImages! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'! confirmFirstUseOfStyle ^ self valueOfFlag: #confirmFirstUseOfStyle! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/16/2002 13:04'! conversionMethodsAtFileOut ^ self valueOfFlag: #conversionMethodsAtFileOut! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! debugHaloHandle ^ self valueOfFlag: #debugHaloHandle! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! diffsInChangeList ^ self valueOfFlag: #diffsInChangeList! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'! extractFlashInHighQuality ^ self valueOfFlag: #extractFlashInHighQuality! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'! extractFlashInHighestQuality ^ self valueOfFlag: #extractFlashInHighestQuality! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:27'! fastDragWindowForMorphic ^ self valueOfFlag: #fastDragWindowForMorphic! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 6/1/2000 16:56'! hiddenScrollBars ^ self valueOfFlag: #hiddenScrollBars! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'! ignoreStyleIfOnlyBold ^ self valueOfFlag: #ignoreStyleIfOnlyBold! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'! inboardScrollbars ^ self valueOfFlag: #inboardScrollbars! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'! logDebuggerStackToFile ^ self valueOfFlag: #logDebuggerStackToFile! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 7/1/1999 22:32'! menuColorFromWorld ^ self valueOfFlag: #menuColorFromWorld! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 7/1/1999 23:28'! mouseOverHaloseEnabled ^ self valueOfFlag: #mouseOverHaloseEnabled! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! mvcProjectsAllowed ^ self valueOfFlag: #mvcProjectsAllowed! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'! noviceMode ^ self valueOfFlag: #noviceMode! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 12/13/1999 10:51'! optionalButtons ^ self valueOfFlag: #optionalButtons! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 20:50'! printAlternateSyntax ^ self valueOfFlag: #printAlternateSyntax! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! projectZoom ^ self valueOfFlag: #projectZoom! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! promptForUpdateServer ^ self valueOfFlag: #promptForUpdateServer! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:28'! reverseWindowStagger ^ self valueOfFlag: #reverseWindowStagger! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/26/1999 11:42'! roundedMenuCorners ^ self valueOfFlag: #roundedMenuCorners! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 7/1/1999 22:32'! roundedWindowCorners ^ self valueOfFlag: #roundedWindowCorners! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! scrollBarsNarrow ^ self valueOfFlag: #scrollBarsNarrow! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! scrollBarsOnRight ^ self valueOfFlag: #scrollBarsOnRight! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! scrollBarsWithoutMenuButton ^ self valueOfFlag: #scrollBarsWithoutMenuButton! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 2/15/2000 18:46'! simpleMenus ^ self valueOfFlag: #simpleMenus! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 10/20/1999 12:22'! smartUpdating ^ self valueOfFlag: #smartUpdating! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! soundQuickStart ^ self valueOfFlag: #soundQuickStart! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 1/12/2000 22:40'! soundsEnabled ^ self valueOfFlag: #soundsEnabled! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 10:57'! systemWindowEmbedOK ^ self valueOfFlag: #systemWindowEmbedOK! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:29'! thoroughSenders ^ self valueOfFlag: #thoroughSenders! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 1/13/2000 12:21'! timeStampsInMenuTitles ^ self valueOfFlag: #timeStampsInMenuTitles! ! !Preferences class methodsFor: 'standard preferences' stamp: 'programmatic 11/13/1999 22:52'! twentyFourHourFileStamps ^ self valueOfFlag: #twentyFourHourFileStamps! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'! unlimitedPaintArea ^ self valueOfFlag: #unlimitedPaintArea! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'! updateSavesFile ^ self valueOfFlag: #updateSavesFile! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 1/12/2000 22:56'! useAnnotationPanes "Because of so any senders, this wording retained here though we defer to the renamed flag" ^ self valueOfFlag: #annotationPanes! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'! warnIfNoChangesFile ^ self valueOfFlag: #warnIfNoChangesFile! ! !Preferences class methodsFor: 'standard preferences' stamp: 'sw 6/28/1999 16:30'! warnIfNoSourcesFile ^ self valueOfFlag: #warnIfNoSourcesFile! ! !Preferences class methodsFor: 'initial values' stamp: 'jm 10/16/2002 12:29'! initialValuesAToM "CategoryInfo _ nil" "Preferences openFactoredPanel" ^#( (annotationPanes false (browsing)) (autoAccessors false (general)) (balloonHelpEnabled true (morphic)) (browserShowsPackagePane false (browsing)) (browseWithPrettyPrint false (browsing)) (caseSensitiveFinds false (general)) (cautionBeforeClosing false (windows)) (changeSetVersionNumbers true (fileout)) (checkForSlips true (fileout)) (clickOnLabelToEdit true (windows)) (cmdDotEnabled true (debug)) (colorWhenPrettyPrinting false (browsing)) (compressFlashImages false (media)) (confirmFirstUseOfStyle true (browsing)) (conversionMethodsAtFileOut false (fileout)) (debugHaloHandle true (debug halos)) (diffsInChangeList true (browsing)) (extractFlashInHighQuality true (media)) (extractFlashInHighestQuality false (media)) (fastDragWindowForMorphic false (windows)) (ignoreStyleIfOnlyBold true (browsing)) (inboardScrollbars false (scrolling)) (logDebuggerStackToFile true (debug)) (menuColorFromWorld false (menus)) (mvcProjectsAllowed false (general)) ) ! ! !Preferences class methodsFor: 'initial values' stamp: 'sw 2/15/2000 18:37'! initialValuesAdditionA "Another lot of initial values for prefs. Simply placing methods of this sort in the 'initial values' category will assure that the initial values provided are ascribed to the preference when prefs are initialized" ^ #( (simpleMenus false (menus)) ) "Preferences resetCategoryInfo" ! ! !Preferences class methodsFor: 'initial values' stamp: 'programmatic 5/10/2000 15:45'! initialValuesAdditionbrowsingalternativeBrowseIt ^ #((alternativeBrowseIt false (browsing ) ) )! ! !Preferences class methodsFor: 'initial values'! initialValuesAdditionscrollinghiddenScrollBars ^ #((hiddenScrollBars false (scrolling ) ) )! ! !Preferences class methodsFor: 'initial values' stamp: 'jm 10/16/2002 12:50'! initialValuesNToZ "Another lot of initial values for prefs. Simply placing methods of this sort in the 'initial values' category will assure that the initial values provided are ascribed to the preference when prefs are initialized." ^ #( (noviceMode false (general)) (optionalButtons false (general)) (printAlternateSyntax false (browsing)) (projectZoom false (general)) (promptForUpdateServer true (updates)) (reverseWindowStagger true (windows)) (roundedMenuCorners true (menus)) (roundedWindowCorners false (windows)) (scrollBarsNarrow false (scrolling)) (scrollBarsOnRight false (scrolling)) (scrollBarsWithoutMenuButton false (menus scrolling)) (smartUpdating true (browsing)) (soundsEnabled false (media)) (soundQuickStart false (media)) (systemWindowEmbedOK false (windows)) (thoroughSenders true (general)) (timeStampsInMenuTitles false (menus)) (twentyFourHourFileStamps true (fileout)) (unlimitedPaintArea false (morphic)) (updateSavesFile false (updates)) (warnIfNoChangesFile true (general)) (warnIfNoSourcesFile true (general)) ) "Preferences resetCategoryInfo" ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 7/12/1999 17:41'! installBrightWindowColors "Preferences installBrightWindowColors" | windowColorDict | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new]. windowColorDict _ Parameters at: #windowColors. #( (Browser lightGreen) (ChangeList lightBlue) (ChangeSorter lightBlue) (Debugger lightRed) (DualChangeSorter lightBlue) (FileContentsBrowser tan) (FileList lightMagenta) (MessageSet lightBlue) (Object white) (SelectorBrowser lightCyan) (StringHolder lightYellow) (TranscriptStream lightOrange)) do: [:pair | windowColorDict at: pair first put: (Color perform: pair last)] ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 7/12/1999 17:41'! installPastelWindowColors "Preferences installPastelWindowColors" | windowColorDict | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new]. windowColorDict _ Parameters at: #windowColors. #( (Browser paleGreen) (ChangeList paleBlue) (ChangeSorter paleBlue) (Debugger veryPaleRed) (DualChangeSorter paleBlue) (FileContentsBrowser paleTan) (FileList paleMagenta) (MessageSet paleBlue) (Object white) (SelectorBrowser palePeach) (StringHolder paleYellow) (TranscriptStream paleOrange)) do: [:pair | windowColorDict at: pair first put: (Color perform: pair last)] ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 15:12'! installUniformWindowColors "Preferences installUniformWindowColors" | windowColorDict | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new]. windowColorDict _ Parameters at: #windowColors. #( (Browser white) (ChangeList white) (ChangeSorter white) (Debugger white) (DualChangeSorter white) (FileContentsBrowser white) (FileList white) (MessageSet white) (Object white) (SelectorBrowser white) (StringHolder white) (TranscriptStream white)) do: [:pair | windowColorDict at: pair first put: (Color perform: pair last)] ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 10/27/1999 11:34'! setWindowColorFor: modelSymbol to: incomingColor | aColor | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new. self installBrightWindowColors]. aColor _ incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. ^ (Parameters at: #windowColors) at: modelSymbol put: aColor ! ! !Preferences class methodsFor: 'window colors' stamp: 'jm 5/31/2003 16:44'! windowColorClasses ^ #(Browser ChangeList ChangeSorter Debugger DualChangeSorter FileContentsBrowser FileList MessageSet StringHolder TranscriptStream) ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 16:03'! windowColorFor: aModelClassName | classToCheck windowColors | (Parameters includesKey: #windowColors) ifFalse: [Parameters at: #windowColors put: IdentityDictionary new. self installBrightWindowColors]. classToCheck _ Smalltalk at: aModelClassName. windowColors _ Parameters at: #windowColors. [windowColors includesKey: classToCheck name] whileFalse: [classToCheck _ classToCheck superclass]. ^ windowColors at: classToCheck name ifAbsent: [Color white] ! ! !Preferences class methodsFor: 'window colors' stamp: 'sw 7/13/1999 20:10'! windowColorHelp "The 'Window Colors' panel lets you select colors for the standard Squeak windows. The three buttons entitled 'Bright', 'Pastel', and 'White' let you install three different standard color schemes. The rows of color swatches and tool names indicate what the color for each tool is currently set to be. You can change the color for any tool by clicking on its swatch, then choosing a new color in the ensuing color-picker. 'TranscriptStream' governs the color of Transcripts. 'MessageSet' governs the color of message-list browsers. 'ChangeList' governs the color of change-list browsers *and* versions browsers. 'StringHolder' governs the color of Workspaces. Any time you request a new window (browser, file-list, etc.), the current window-color setting for that kind of window will determine what color is used. But note that if in Morphic, the 'Tools' flap and the 'Standard Parts Bin' both contain pre-allocated window prototypes, and these will not automatically change when you edit the standard window colors. To get the Tools flap to reflect your latest color choices, hit the 'Update Tools Flap' button. To get the standard parts bin to reflect your latest color choices, evaluate 'ScriptingSystem resetStandardPartsBin'" (StringHolder new contents: (self class firstCommentAt: #windowColorHelp)) openLabel: 'About Window Colors' "Preferences windowColorHelp"! ! !Preferences class methodsFor: 'window colors' stamp: 'jm 6/15/2003 12:48'! windowSpecificationPanel "Preferences windowSpecificationPanel" | aPanel buttonRow aButton aRow aSwatch aColor aWindow aMiniWorld | aPanel _ AlignmentMorph newColumn hResizing: #shrinkWrap; vResizing: #shrinkWrap. aPanel addMorph: (buttonRow _ AlignmentMorph newRow color: (aColor _ Color tan lighter)). aButton _ SimpleButtonMorph new target: self. buttonRow addTransparentSpacerOfSize: 2@0. buttonRow addMorphBack: (SimpleButtonMorph new label: '?'; target: self; actionSelector: #windowColorHelp; setBalloonText: 'Click for an explanation of this panel'; color: Color veryVeryLightGray; yourself). buttonRow addTransparentSpacerOfSize: 8@0. #( ('Bright' installBrightWindowColors yellow 'Use standard bright colors for all windows.') ('Pastel' installPastelWindowColors paleMagenta 'Use standard pastel colors for all windows.') ('White' installUniformWindowColors white 'Use white backgrounds for all standard windows.') ) do: [:quad | aButton _ aButton fullCopy label: quad first; actionSelector: quad second; color: (Color colorFrom: quad third); setBalloonText: quad fourth; yourself. buttonRow addMorphBack: aButton. buttonRow addTransparentSpacerOfSize: 10@0]. self windowColorClasses do: [:clName | aRow _ AlignmentMorph newRow color: aColor. aSwatch _ UpdatingRectangleMorph new target: self; getSelector: #windowColorFor:; putSelector: #setWindowColorFor:to:; argument: clName; extent: (40 @ 20); yourself. aRow addMorphFront: aSwatch. aRow addTransparentSpacerOfSize: (12 @ 1). aRow addMorphBack: (StringMorph contents: clName font: TextStyle defaultFont). aPanel addMorphBack: aRow]. Smalltalk isMorphic ifTrue: [ aWindow _ aPanel wrappedInWindowWithTitle: 'Window Colors'. self currentHand attachMorph: aWindow. aWindow world startSteppingSubmorphsOf: aPanel.] ifFalse: [ (aMiniWorld _ MVCWiWPasteUpMorph newWorldForProject: nil) addMorph: aPanel. aMiniWorld startSteppingSubmorphsOf: aPanel. MorphWorldView openOn: aMiniWorld label: 'Window Colors' extent: aMiniWorld fullBounds extent]. ! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 13:00'! chooseInsertionPointColor ColorPickerMorph new sourceHand: self currentHand; target: self; selector: #insertionPointColor:; originalColor: self insertionPointColor; addToWorld: self currentWorld near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:57'! chooseTextHighlightColor ColorPickerMorph new sourceHand: self currentHand; target: self; selector: #textHighlightColor:; originalColor: self textHighlightColor; addToWorld: self currentWorld near: self currentHand cursorBounds! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 13:07'! initializeTextHighlightingParameters "Preferences initializeTextHighlightingParameters" Parameters at: #insertionPointColor put: (Color r: 0.4 g: 1.0 b: 0). Parameters at: #textHighlightColor put: (Color r: 0.4 g: 1.0 b: 0).! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'! insertionPointColor ^ Parameters at: #insertionPointColor! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'! insertionPointColor: aColor Parameters at: #insertionPointColor put: aColor! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:53'! textHighlightColor ^ Parameters at: #textHighlightColor! ! !Preferences class methodsFor: 'text highlighting' stamp: 'sw 9/7/1999 12:54'! textHighlightColor: aColor Parameters at: #textHighlightColor put: aColor! ! !Preferences class methodsFor: 'pretty-printing' stamp: 'jm 10/16/2002 13:09'! initializeSyntaxColorsAndStyles "To change the color choices, you can simply edit this method, and then evaluate the following line: Preferences initializeSyntaxColorsAndStyles Later, people may wish to produce interactive editors for modifying the choices" | specs | SyntaxColorsAndStyles _ IdentityDictionary new. # ( (temporaryVariable (magenta bold)) (methodArgument (magenta italic)) (blockArgument (magenta italic)) (comment (red normal)) (variable (blue bold)) (literal (brown normal)) (keyword (black normal))) do: [:nameAndSpecs | specs _ nameAndSpecs second. SyntaxColorsAndStyles at: nameAndSpecs first put: (SyntaxAttribute color: (Color perform: specs first) emphasis: specs last)]. ! ! !Preferences class methodsFor: 'pretty-printing' stamp: 'jm 10/16/2002 13:10'! syntaxAttributesFor: aPartSymbol SyntaxColorsAndStyles ifNil: [self initializeSyntaxColorsAndStyles]. ^ (SyntaxColorsAndStyles at: aPartSymbol ifAbsent: [^ #()]) attributeList ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 6/9/2003 22:11'! chooseFontWithPrompt: aPrompt andSendTo: aReceiver withSelector: aSelector Smalltalk isMorphic ifFalse: [self mvcPromptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector] ifTrue: [self promptForFont: aPrompt andSendTo: aReceiver withSelector: aSelector]. ! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 17:30'! chooseListFont self chooseFontWithPrompt: 'standard list font' andSendTo: self withSelector: #setListFontTo:! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 17:30'! chooseMenuFont self chooseFontWithPrompt: 'standard menu font' andSendTo: self withSelector: #setMenuFontTo:! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/10/1999 11:34'! chooseSystemFont self chooseFontWithPrompt: 'Default text font' andSendTo: self withSelector: #setSystemFontTo:! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:39'! chooseWindowTitleFont self chooseFontWithPrompt: 'window title font' andSendTo: self withSelector: #setWindowTitleFontTo:! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 10/5/2002 07:10'! fontConfigurationMenu | aMenu | aMenu _ MenuMorph new defaultTarget: Preferences. aMenu addTitle: 'Standard System Fonts'. aMenu add: 'default text font...' action: #chooseSystemFont. aMenu balloonTextForLastItem: 'Choose the default font to be used for code and in workspaces, transcripts, etc.'. aMenu lastItem font: TextStyle defaultFont. aMenu add: 'list font...' action: #chooseListFont. aMenu lastItem font: Preferences standardListFont. aMenu balloonTextForLastItem: 'Choose the font to be used in list panes'. aMenu balloonTextForLastItem: 'Choose the font to be used on textual flap tabs'. aMenu add: 'menu font...' action: #chooseMenuFont. aMenu lastItem font: Preferences standardMenuFont. aMenu balloonTextForLastItem: 'Choose the font to be used in menus'. aMenu add: 'window-title font...' action: #chooseWindowTitleFont. aMenu lastItem font: Preferences windowTitleFont emphasis: 1. aMenu balloonTextForLastItem: 'Choose the font to be used in window titles.'. aMenu add: 'balloon-help font...' target: BalloonMorph action: #chooseBalloonFont. aMenu lastItem font: BalloonMorph balloonFont. aMenu balloonTextForLastItem: 'choose the font to be used when presenting balloon help.'. "aMenu add: 'code font...' action: #chooseCodeFont. aMenu lastItem font: Preferences standardCodeFont. aMenu balloonTextForLastItem: 'Choose the font to be used in code panes.'." aMenu addLine. aMenu add: 'restore default font choices' action: #restoreDefaultFonts. aMenu balloonTextForLastItem: 'Use the standard system font defaults'. ^ aMenu ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 6/9/2003 22:20'! fontMenuForStyle: styleName target: target selector: selector | menu | menu _ MenuMorph entitled: styleName. (StrikeFont sizesForFamilyName: styleName) do: [:sz | menu add: (sz asString, ' Point') target: target selector: selector argument: ((TextStyle named: styleName) fontOfPointSize: sz). menu lastItem font: ((TextStyle named: styleName) fontOfPointSize: sz)]. ^ menu ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 6/9/2003 22:13'! mvcPromptForFont: aPrompt andSendTo: aTarget withSelector: aSelector "self mvcPromptForFont: 'Choose system font style' andSendTo: nil withSelector: #setSystemFontTo:" | aMenu aChoice aStyle namesAndSizes aFont | aMenu _ CustomMenu new. (StrikeFont familyNames copyWithout: 'DefaultTextStyle') do: [:fName | aMenu add: fName action: fName]. aChoice _ aMenu startUpWithCaption: aPrompt. aChoice ifNil: [^ self]. aMenu _ CustomMenu new. aStyle _ TextStyle named: aChoice. (namesAndSizes _ aStyle fontNamesWithHeights) do: [:aString | aMenu add: aString action: aString]. aChoice _ aMenu startUpWithCaption: nil. aChoice ifNil: [^ self]. aFont _ aStyle fontAt: (namesAndSizes indexOf: aChoice). aTarget perform: aSelector with: aFont. ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 10/5/2002 07:10'! presentMvcFontConfigurationMenu | aMenu result | aMenu _ CustomMenu new. aMenu title: 'Standard System Fonts'. aMenu add: 'default text font...' action: #chooseSystemFont. aMenu add: 'list font...' action: #chooseListFont. aMenu add: 'menu font...' action: #chooseMenuFont. aMenu add: 'window-title font...' action: #chooseWindowTitleFont. "aMenu add: 'code font...' action: #chooseCodeFont." aMenu addLine. aMenu add: 'restore default font choices' action: #restoreDefaultFonts. (result _ aMenu startUp) ifNotNil: [self perform: result] ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 6/9/2003 22:23'! promptForFont: aPrompt andSendTo: aTarget withSelector: aSelector "NOTE: Morphic ONLY!!!!. Derived from a method written by Robin Gibson" "self promptForFont: 'Choose system font:' andSendTo: nil withSelector: #setSystemFontTo:" | menu subMenu | menu _ MenuMorph entitled: aPrompt. (StrikeFont familyNames copyWithout: 'DefaultTextStyle') do: [:styleName | subMenu _ self fontMenuForStyle: styleName target: aTarget selector: aSelector. menu add: styleName subMenu: subMenu. menu lastItem font: ((TextStyle named: styleName) fontOfSize: 18)]. menu popUpForHand: self currentHand. ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 6/9/2003 22:12'! restoreDefaultFonts "Preferences restoreDefaultFonts" #( (setButtonFontTo: ComicBold 16) (setListFontTo: NewYork 12) (setMenuFontTo: NewYork 12) (setWindowTitleFontTo: NewYork 15) (setSystemFontTo: NewYork 12) ) do: [:triplet | self perform: triplet first with: (StrikeFont familyName: triplet second size: triplet third)]. Smalltalk at: #BalloonMorph ifPresent: [:thatClass | thatClass setBalloonFontTo: (StrikeFont familyName: #ComicPlain size: 12)]. "Note: The standard button font is reset by this code but is not otherwise settable by a public UI (too many things can go afoul) " ! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 22:06'! setButtonFontTo: aFont Parameters at: #standardButtonFont put: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 10/5/2002 06:58'! setListFontTo: aFont Parameters at: #standardListFont put: aFont. ListParagraph initialize. ! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 18:04'! setMenuFontTo: aFont Parameters at: #standardMenuFont put: aFont. PopUpMenu setMenuFontTo: aFont! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 10/5/2002 06:58'! setSystemFontTo: aFont "Establish the default text font and style." | aStyle newDefaultStyle | aFont ifNil: [^ self]. aStyle _ aFont textStyle ifNil: [^ self]. newDefaultStyle _ aStyle copy. newDefaultStyle defaultFontIndex: (aStyle fontIndexOf: aFont). TextConstants at: #DefaultTextStyle put: newDefaultStyle. ! ! !Preferences class methodsFor: 'fonts' stamp: 'jm 10/5/2002 06:58'! setWindowTitleFontTo: aFont Parameters at: #windowTitleFont put: aFont. StandardSystemView setLabelStyle. ! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:13'! standardButtonFont "Answer an attractive font to use for buttons" "Answer the font to be used for textual flap tab labels" ^ Parameters at: #standardButtonFont ifAbsent: [Parameters at: #standardButtonFont put: (StrikeFont familyName: #ComicBold size: 16)]! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:09'! standardListFont "Answer the font to be used in lists" ^ Parameters at: #standardListFont ifAbsent: [Parameters at: #standardListFont put: TextStyle defaultFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:58'! standardMenuFont "Answer the font to be used in menus" ^ Parameters at: #standardMenuFont ifAbsent: [Parameters at: #standardMenuFont put: TextStyle defaultFont]! ! !Preferences class methodsFor: 'fonts' stamp: 'sw 12/8/1999 16:10'! windowTitleFont "Answer the standard font to use for window titles" ^ Parameters at: #windowTitleFont ifAbsent: [Parameters at: #windowTitleFont put: (StrikeFont familyName: #NewYork size: 15)]! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/15/2003 12:13'! classicHaloSpecs "Non-iconic halos with traditional placements" "Preferences resetHaloSpecifications" " <- will result in the standard default halos being reinstalled" "NB: listed below in clockwise order" ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addMenuHandle: left top (red) none) (addDismissHandle: leftCenter top (red muchLighter) 'Halo-Dismiss') (addGrabHandle: center top (black) none) (addDragHandle: rightCenter top (brown) none) (addDupHandle: right top (green) none) (addDebugHandle: right topCenter (blue veryMuchLighter) none) (addRepaintHandle: right center (lightGray) none) (addGrowHandle: right bottom (yellow) none) (addFontEmphHandle: rightCenter bottom (lightBrown darker) none) (addFontStyleHandle: center bottom (lightRed) none) (addFontSizeHandle: leftCenter bottom (lightGreen) none) (addRotateHandle: left bottom (blue) none)) ! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/15/2003 12:13'! customHaloSpecs "Intended for you to modify to suit your personal preference. What is implemented in the default here is just a skeleton; in comment at the bottom of this method are some useful lines you may wish to paste in to the main body here, possibly modifying positions, colors, etc.. Note that in this example, we include: Dismiss handle, at top-left Menu handle, at top-right Resize handle, at bottom-right Rotate handle, at bottom-left Drag handle, at top-center Recolor handle, at left-center. (this one is NOT part of the standard formulary -- it is included here to illustrate how to add non-standard halos) Note that the optional handles for specialized morphs, such as Sketch, Text, PasteUp, are also included" ^ #( (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addMenuHandle: right top (red) 'Halo-Menu') (addDragHandle: center top (brown) 'Halo-Drag') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addRecolorHandle: left center (green muchLighter lighter) 'Halo-Recolor') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') ). " Other useful handles... selector horiz vert color info icon key --------- ------ ----------- ------------------------------- --------------- (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addRepaintHandle: right center (lightGray) 'Halo-Paint') " ! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/5/2003 21:31'! customHalosInForce ^ (self parameterAt: #HaloTheme) == #customHaloSpecs ! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/15/2003 12:19'! haloSpecifications "Answer a list of HaloSpecs that describe which halos are to be used, what they should look like, and where they should be situated" ^ Parameters at: #HaloSpecs ifAbsent: [self installHaloTheme: #iconicHaloSpecifications] ! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/15/2003 11:52'! haloThemeRadioButtons | buttonColumn aRow aRadioButton aStringMorph | buttonColumn _ AlignmentMorph newColumn color: Color transparent. #((iconicHaloSpecifications iconic iconicHalosInForce 'circular halos with icons inside') (customHaloSpecs custom customHalosInForce 'customizable halos') ) do: [:quad | aRow _ AlignmentMorph newRow color: Color transparent. aRow vResizing: #shrinkWrap. aRow addMorph: (aRadioButton _ ThreePhaseButtonMorph radioButton). aRadioButton target: Preferences. aRadioButton setBalloonText: quad fourth. aRadioButton actionSelector: #installHaloTheme:. aRadioButton getSelector: quad third. aRadioButton arguments: (Array with: quad first). aRow addTransparentSpacerOfSize: (4 @ 0). aRow addMorphBack: (aStringMorph _ StringMorph contents: quad second asString). aStringMorph setBalloonText: quad fourth. buttonColumn addMorphBack: aRow]. ^ buttonColumn "self currentHand attachMorph: Preferences haloThemeRadioButtons" ! ! !Preferences class methodsFor: 'halos' stamp: 'jm 6/15/2003 12:20'! iconicHaloSpecifications ^ #( " selector horiz vert color info icon key --------- ------ ----------- ------------------------------- ---------------" (addCollapseHandle: left topCenter (tan) 'Halo-Collapse') (addDebugHandle: right topCenter (blue veryMuchLighter) 'Halo-Debug') (addDismissHandle: left top (red muchLighter) 'Halo-Dismiss') (addRotateHandle: left bottom (blue) 'Halo-Rot') (addMenuHandle: leftCenter top (red) 'Halo-Menu') (addGrabHandle: center top (black) 'Halo-Grab') (addDragHandle: rightCenter top (brown) 'Halo-Drag') (addDupHandle: right top (green) 'Halo-Dup') (addHelpHandle: center bottom (lightBlue) 'Halo-Help') (addGrowHandle: right bottom (yellow) 'Halo-Scale') (addRepaintHandle: right center (lightGray) 'Halo-Paint') (addFontSizeHandle: leftCenter bottom (lightGreen) 'Halo-FontSize') (addFontStyleHandle: center bottom (lightRed) 'Halo-FontStyle') (addFontEmphHandle: rightCenter bottom (lightBrown darker) 'Halo-FontEmph') ) ! ! !Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:25'! iconicHalosInForce ^ (self parameterAt: #HaloTheme) == #iconicHaloSpecifications! ! !Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'! installCustomHaloSpecs "Install an alternative set of halos, as customized by the user" "Preferences installCustomHaloSpecs" self installHaloTheme: #customHaloSpecs! ! !Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 16:45'! installHaloSpecsFromArray: anArray | aColor | ^ Parameters at: #HaloSpecs put: (anArray collect: [:quin | aColor _ Color. quin fourth do: [:sel | aColor _ aColor perform: sel]. HaloSpec new horizontalPlacement: quin second verticalPlacement: quin third color: aColor iconSymbol: quin fifth addHandleSelector: quin first])! ! !Preferences class methodsFor: 'halos' stamp: 'sw 1/27/2000 23:15'! installHaloTheme: themeSymbol self installHaloSpecsFromArray: (self perform: themeSymbol). self setParameter: #HaloTheme to: themeSymbol ! ! !Preferences class methodsFor: 'halos' stamp: 'sw 1/28/2000 10:36'! installIconicHaloSpecs "Install an alternative set of halos, rather more based on the old placements, and without icons, , and lacking the scripting-relating handles.." "Preferences installIconicHaloSpecs" self installHaloTheme: #iconicHaloSpecifications! ! I represent an independent path of control in the system. This path of control may be stopped (by sending the message suspend) in such a way that it can later be restarted (by sending the message resume). When any one of several paths of control can be advanced, the single instance of ProcessorScheduler named Processor determines which one will actually be advanced partly using the value of priority. (If anyone ever makes a subclass of Process, be sure to use allSubInstances in anyProcessesAbove:.)! !Process methodsFor: 'changing process state' stamp: 'jm 5/23/2003 11:21'! terminate "Stop the process that the receiver represents forever." | context | Processor activeProcess == self ifTrue: [thisContext sender == nil ifFalse: [thisContext sender release]. thisContext removeSelf suspend] ifFalse: [myList == nil ifFalse: [myList remove: self ifAbsent: []. myList _ nil]. context _ suspendedContext. suspendedContext _ nil. (context ~~ nil and: [context sender ~~ nil]) ifTrue: [context sender release]] ! ! My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.! !ProcessorScheduler methodsFor: 'private' stamp: 'tk 6/24/1999 11:27'! anyProcessesAbove: highestPriority "Do any instances of Process exist with higher priorities?" ^(Process allInstances "allSubInstances" select: [:aProcess | aProcess priority > highestPriority]) isEmpty "If anyone ever makes a subclass of Process, be sure to use allSubInstances."! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'di 2/4/1999 08:45'! startUp "Install a background process of the lowest possible priority that is always runnable." "Details: The virtual machine requires that there is aways some runnable process that can be scheduled; this background process ensures that this is the case." Smalltalk installLowSpaceWatcher. BackgroundProcess == nil ifFalse: [BackgroundProcess terminate]. BackgroundProcess _ [self idleProcess] newProcess. BackgroundProcess priority: SystemRockBottomPriority. BackgroundProcess resume. ! ! !ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel ^ channel ! ! !ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:47'! channel: midiChannel channel _ midiChannel. ! ! !ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:49'! program ^ program ! ! !ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! program: midiProgramChange program _ midiProgramChange. ! ! !ProgramChangeEvent methodsFor: 'accessing' stamp: 'jm 9/10/1998 07:48'! program: midiProgramChange channel: midiChannel program _ midiProgramChange. channel _ midiChannel. ! ! !ProgramChangeEvent methodsFor: 'classification' stamp: 'jm 9/10/1998 09:46'! isProgramChange ^ true ! ! !ProgramChangeEvent methodsFor: 'midi' stamp: 'jm 9/10/1998 18:31'! outputOnMidiPort: aMidiPort "Output this event to the given MIDI port." aMidiPort midiCmd: 16rC0 channel: channel byte: program. ! ! !ProgramChangeEvent methodsFor: 'printing' stamp: 'jm 9/10/1998 08:28'! printOn: aStream aStream nextPut: $(. time printOn: aStream. aStream nextPutAll: ': prog '. program printOn: aStream. aStream nextPut: $). ! ! A Project stores the state of a complete Squeak desktop, including the windows, and the currently active changeSet. A project knows who its parent project is. When you change projects, whether by entering or exiting, the screen state of the project being exited is saved in that project. A project is retained by its view in the parent world. It is effectively named by the name of its changeSet, which can be changed either by renaming in a changeSorter, or by editing the label of its view from the parent project. As the site of major context switch, Projects are the locus of swapping between the old MVC and the new Morphic worlds. The distinction is based on whether the variable 'world' contains a WorldMorph or a ControlManager. Saving and Loading Projects may be stored on the disk in external format. Projects may be loaded from a server and stored back. Storing on a server never overwrites; it always makes a new version. A project remembers the url of where it lives in urlList. The list is length one, for now. The url may point to a local disk instead of a server. All projects that the user looks at, are cached in the Squeaklet folder. Sorted by server. The cache holds the most recent version only. ! !Project methodsFor: 'initialization' stamp: 'jm 6/16/2003 20:58'! defaultBackgroundColor ^ Color r: 1.0 g: 1.0 b: 0.065 ! ! !Project methodsFor: 'initialization' stamp: 'di 3/29/2000 14:16'! initMorphic "Written so that Morphic can still be removed." Smalltalk verifyMorphicAvailability ifFalse: [^ nil]. self initialize. world _ PasteUpMorph newWorldForProject: self. ! ! !Project methodsFor: 'initialization' stamp: 'di 4/14/1999 13:55'! initialProject self saveState. parentProject _ self. previousProject _ nextProject _ nil! ! !Project methodsFor: 'initialization' stamp: 'jm 6/21/2003 11:18'! initialize changeSet _ ChangeSet new. transcript _ TranscriptStream new. displayDepth _ Display depth. parentProject _ CurrentProject. ! ! !Project methodsFor: 'initialization' stamp: 'di 7/19/1999 15:00'! installPasteUpAsWorld: pasteUpMorph "(ProjectViewMorph newMorphicProjectOn: aPasteUpMorph) openInWorld." world _ pasteUpMorph beWorldForProject: self! ! !Project methodsFor: 'initialization' stamp: 'jm 10/7/2002 06:10'! setChangeSet: aChangeSet changeSet _ aChangeSet ! ! !Project methodsFor: 'initialization' stamp: 'di 3/29/2000 14:16'! setProjectHolder: aProject self initialize. world _ ControlManager new. ! ! !Project methodsFor: 'initialization' stamp: 'di 6/10/1998 13:54'! windowActiveOnFirstClick ^ true! ! !Project methodsFor: 'initialization' stamp: 'di 6/12/1998 15:58'! windowReqNewLabel: newLabel newLabel isEmpty ifTrue: [^ false]. newLabel = changeSet name ifTrue: [^ true]. (ChangeSorter changeSetNamed: newLabel) == nil ifFalse: [self inform: 'Sorry that name is already used'. ^ false]. changeSet name: newLabel. ^ true! ! !Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 16:29'! changeSet ^ changeSet! ! !Project methodsFor: 'accessing' stamp: 'jm 5/16/2003 09:31'! isMorphic "Answer true if this is a Morphic project." ^ world isMorph ! ! !Project methodsFor: 'accessing' stamp: 'di 3/29/2000 15:37'! isTopProject "Return true only if this is the top project (its own parent). Also include the test here for malformed project hierarchy." parentProject == self ifTrue: [^ true]. parentProject == nil ifTrue: [self error: 'No project should have a nil parent']. ^ false! ! !Project methodsFor: 'accessing' stamp: 'tk 6/26/1998 22:17'! labelString ^ changeSet name! ! !Project methodsFor: 'accessing' stamp: 'di 7/19/1999 15:06'! name changeSet == nil ifTrue: [^ 'no name']. ^ changeSet name! ! !Project methodsFor: 'accessing' stamp: 'sw 2/15/1999 12:12'! nextProject ^ nextProject ! ! !Project methodsFor: 'accessing' stamp: 'di 4/14/1999 13:59'! setParent: newParent parentProject _ newParent. nextProject _ previousProject _ nil.! ! !Project methodsFor: 'accessing' stamp: 'tk 4/5/2000 13:57'! urlList ^ urlList! ! !Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'! enter "Enter the new project" self enter: (CurrentProject parent == self) revert: false saveForRevert: false.! ! !Project methodsFor: 'menu messages' stamp: 'jm 10/30/2002 20:48'! enter: returningFlag revert: revertFlag saveForRevert: saveForRevert "Install my ChangeSet, Transcript, and scheduled views as current globals. If returningFlag is true, we will return to the project from whence the current project was entered; don't change its previousProject link in this case. If saveForRevert is true, save the ImageSegment of the project being left. If revertFlag is true, make stubs for the world of the project being left. If revertWithoutAsking is true in the project being left, then always revert." | showZoom forceRevert response seg | self == CurrentProject ifTrue: [^ self]. forceRevert _ false. CurrentProject rawParameters ifNil: [revertFlag ifTrue: [^ self inform: 'nothing to revert to']] ifNotNil: [saveForRevert ifFalse: [ forceRevert _ CurrentProject projectParameters at: #revertWithoutAsking ifAbsent: [false]]]. forceRevert not & revertFlag ifTrue: [ response _ SelectionMenu confirm: 'Are you sure you want to destroy this Project\ and revert to an older version?\\(From the parent project, click on this project''s thumbnail.)' withCRs trueChoice: 'Revert to saved version' falseChoice: 'Cancel'. response ifFalse: [^ self]]. revertFlag | forceRevert ifTrue: [seg _ CurrentProject projectParameters at: #revertToMe ifAbsent: [ ^ self inform: 'nothing to revert to']] ifFalse: [CurrentProject makeThumbnail]. (revertFlag | saveForRevert | forceRevert) ifFalse: []. "Update the display depth and make a thumbnail of the current project" CurrentProject displayDepth: Display depth. "Show the project transition. Note: The project zoom is run in the context of the old project, so that eventual errors can be handled accordingly" displayDepth == nil ifTrue: [displayDepth _ Display depth]. Display setExtent: Display extent depth: displayDepth. (showZoom _ self showZoom) ifTrue: [ self displayZoom: CurrentProject parent ~~ self]. (world isMorph and: [world hasProperty: #letTheMusicPlay]) ifTrue: [world removeProperty: #letTheMusicPlay] ifFalse: [Smalltalk at: #ScorePlayer ifPresent: [:playerClass | playerClass allSubInstancesDo: [:player | player pause]]]. returningFlag ifTrue: [nextProject _ CurrentProject] ifFalse: [previousProject _ CurrentProject]. CurrentProject saveState. CurrentProject _ self. Smalltalk newChanges: changeSet. TranscriptStream newTranscript: transcript. Sensor flushKeyboard. world isMorph ifTrue: [World _ world. "Signifies Morphic" world install] ifFalse: [World _ nil. "Signifies MVC" Smalltalk at: #ScheduledControllers put: world]. revertFlag | forceRevert ifTrue: [ seg clone revert]. "non-cloned one is for reverting again later" "Complete the enter: by launching a new process" world isMorph ifTrue: [self spawnNewProcessAndTerminateOld: true] ifFalse: [showZoom ifFalse: [ScheduledControllers restore]. ScheduledControllers searchForActiveController]! ! !Project methodsFor: 'menu messages' stamp: 'tk 10/26/1999 14:25'! exit "Leave the current project and return to the project in which this one was created." self isTopProject ifTrue: [^ PopUpMenu notify: 'Can''t exit the top project']. parentProject enter: false revert: false saveForRevert: false. ! ! !Project methodsFor: 'menu messages' stamp: 'jm 5/29/2003 18:07'! makeThumbnail "Make a thumbnail image of this project from the Display." viewSize ifNil: [viewSize _ Display extent // 8]. thumbnail _ Form extent: viewSize depth: Display depth. (WarpBlt toForm: thumbnail) sourceForm: Display; cellSize: 2; "installs a colormap" combinationRule: Form over; copyQuad: (Display boundingBox) innerCorners toRect: (0@0 extent: viewSize). ! ! !Project methodsFor: 'menu messages' stamp: 'sma 4/30/2000 10:11'! saveState "Save the current state in me prior to leaving this project" changeSet _ Smalltalk changes. Smalltalk isMorphic ifTrue: [world _ World. world sleep] ifFalse: [world _ ScheduledControllers. ScheduledControllers unCacheWindows]. transcript _ Transcript. activeProcess _ nil! ! !Project methodsFor: 'menu messages' stamp: 'di 9/29/1999 00:09'! viewLocFor: exitedProject "Look for a view of the exitedProject, and return its center" | ctlr | world isMorph ifTrue: [world submorphsDo: [:v | ((v isKindOf: SystemWindow) and: [v model == exitedProject]) ifTrue: [^ v center]]] ifFalse: [ctlr _ world controllerWhoseModelSatisfies: [:p | p == exitedProject]. ctlr ifNotNil: [^ ctlr view windowBox center]]. ^ Sensor cursorPoint. "default result" ! ! !Project methodsFor: 'release' stamp: 'di 9/28/1999 23:46'! addDependent: aMorph "Projects do not keep track of their dependents, lest they point into other projects and thus foul up the tree structure for image segmentation." ^ self "Ignore this request"! ! !Project methodsFor: 'release' stamp: 'sw 7/6/1998 11:16'! canDiscardEdits "Don't regard a window of mine as one to be discarded as part of a 'closeUnchangedWindows' sweep" ^ false! ! !Project methodsFor: 'release' stamp: 'sw 2/15/1999 12:15'! deletingProject: aProject "Clear my previousProject link if it points at the given Project, which is being deleted." previousProject == aProject ifTrue: [previousProject _ nil]. nextProject == aProject ifTrue: [nextProject _ nil] ! ! !Project methodsFor: 'release' stamp: 'jm 10/14/2002 18:34'! okToChange | ok hasSubProjects itsName | hasSubProjects _ world isMorph ifTrue: [(world submorphs select: [:m | (m isKindOf: SystemWindow) and: [m model isKindOf: Project]]) size > 0] ifFalse: [(world controllerWhoseModelSatisfies: [:m | m isKindOf: Project]) notNil]. hasSubProjects ifTrue: [PopUpMenu notify: 'The project ', self name printString, ' contains sub-projects. You must remove these explicitly before removing their parent.'. ^ false]. ok _ world isMorph not and: [world scheduledControllers size <= 1]. ok ifFalse: [self isMorphic ifTrue: [ self parent == Project current ifFalse: [^true]]]. "view from elsewhere. just delete it." ok _ (self confirm: 'Really delete the project ', self name printString, ' and all its windows?'). ok ifFalse: [^ false]. "about to delete this project; clear previous links to it from other Projects:" Project allProjects do: [:p | p deletingProject: self]. ProjectViewMorph allSubInstancesDo: [:p | p deletingProject: self. p project == self ifTrue: [p abandon]]. (changeSet isEmpty and: [(changeSet projectsBelongedTo copyWithout: self) isEmpty]) ifTrue: [itsName _ changeSet name. ChangeSorter removeChangeSet: changeSet. Transcript cr; show: 'project change set ', itsName, ' deleted.']. ^ true ! ! !Project methodsFor: 'active process' stamp: 'di 6/20/1998 13:14'! activeProcess ^ activeProcess! ! !Project methodsFor: 'active process' stamp: 'di 6/20/1998 13:20'! interruptName: labelString "Create a Notifier on the active scheduling process with the given label." | suspendingList projectProcess | Smalltalk isMorphic ifFalse: [^ ScheduledControllers interruptName: labelString]. projectProcess _ Project current activeProcess. (suspendingList _ projectProcess suspendingList) == nil ifTrue: [projectProcess == Processor activeProcess ifTrue: [projectProcess suspend]] ifFalse: [suspendingList remove: projectProcess. projectProcess offList]. Debugger openInterrupt: labelString onProcess: projectProcess ! ! !Project methodsFor: 'active process' stamp: 'di 6/20/1998 14:07'! resumeProcess: aProcess "Adopt aProcess as the project process -- probably because of proceeding from a debugger" activeProcess _ aProcess. activeProcess resume! ! !Project methodsFor: 'active process' stamp: 'di 6/20/1998 09:21'! spawnNewProcess exitFlag _ false. activeProcess _ [[World doOneCycle. Processor yield. exitFlag] whileFalse: []. self exit] newProcess priority: Processor userSchedulingPriority. activeProcess resume! ! !Project methodsFor: 'active process' stamp: 'di 6/20/1998 09:22'! spawnNewProcessAndTerminateOld: terminate self spawnNewProcess. terminate ifTrue: [Processor terminateActive] ifFalse: [Processor activeProcess suspend]! ! !Project methodsFor: 'active process' stamp: 'di 4/14/2000 12:38'! spawnNewProcessIfThisIsUI: suspendedProcess world isMorph ifFalse: [^self spawnNewProcess]. "does this ever happen?" self activeProcess == suspendedProcess ifTrue: ["Transcript show: 'spawning'; cr." self spawnNewProcess ] ifFalse: ["Transcript show: 'not spawning'; cr" ].! ! !Project methodsFor: 'file in/out' stamp: 'tk 10/26/1999 14:23'! revert | | "Exit this project and do not save it. Warn user unless in dangerous projectRevertNoAsk mode. Exit to the parent project. Do a revert on a clone of the segment, to allow later reverts." projectParameters ifNil: [^ self inform: 'nothing to revert to']. parentProject enter: false revert: true saveForRevert: false. "does not return!!" ! ! !Project methodsFor: 'project parameters' stamp: 'jm 10/7/2002 06:21'! initializeProjectParameters projectParameters _ IdentityDictionary new. ^ projectParameters ! ! !Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'! parameterAt: aSymbol ^self parameterAt: aSymbol ifAbsent:[nil]! ! !Project methodsFor: 'project parameters' stamp: 'ar 5/25/2000 23:23'! parameterAt: aSymbol ifAbsent: aBlock projectParameters ifNil:[^aBlock value]. ^projectParameters at: aSymbol ifAbsent: aBlock! ! !Project methodsFor: 'project parameters' stamp: 'sw 4/22/1999 15:14'! projectParameters ^ projectParameters ifNil: [self initializeProjectParameters]! ! !Project methodsFor: 'project parameters' stamp: 'tk 10/26/1999 13:55'! rawParameters ^ projectParameters! ! !Project methodsFor: 'displaying' stamp: 'jm 10/7/2002 06:27'! displayZoom: entering "Show the project transition when entering a new project" | newDisplay vanishingPoint | "show animated zoom to new display" newDisplay _ self imageForm. entering ifTrue: [vanishingPoint _ Sensor cursorPoint] ifFalse: [vanishingPoint _ self viewLocFor: CurrentProject]. Display zoomIn: entering orOutTo: newDisplay at: 0@0 vanishingPoint: vanishingPoint. ! ! !Project methodsFor: 'displaying' stamp: 'ar 6/2/1999 01:58'! imageForm ^self imageFormOfSize: Display extent depth: (displayDepth ifNil:[Display depth])! ! !Project methodsFor: 'displaying' stamp: 'ar 5/25/2000 18:01'! imageFormOfSize: extentPoint depth: d | newDisplay | newDisplay _ DisplayScreen extent: extentPoint depth: d. Display replacedBy: newDisplay do:[ world isMorph ifTrue:[world fullDrawOn: (Display getCanvas)] "Morphic" ifFalse:[world restore]. "MVC" ]. ^newDisplay! ! !Project methodsFor: 'displaying' stamp: 'sw 1/12/2000 18:44'! showZoom "Decide if user wants a zoom transition, and if there is enough memory to do it." ^ Preferences projectZoom and: "Only show zoom if there is room for both displays plus a megabyte" [Smalltalk garbageCollectMost > (Display boundingBox area*displayDepth //8+1000000)]! ! !Project class methodsFor: 'class initialization' stamp: 'di 4/14/1999 21:34'! initialize "This is the Top Project." CurrentProject ifNil: [CurrentProject _ super new initialProject. CurrentProject spawnNewProcessAndTerminateOld: true]. "Project initialize"! ! !Project class methodsFor: 'instance creation' stamp: 'di 6/20/1998 13:14'! activeProcess ^ CurrentProject activeProcess! ! !Project class methodsFor: 'instance creation' stamp: 'di 7/19/1999 14:55'! newMorphic "ProjectView open: Project newMorphic" ^ self basicNew initMorphic! ! !Project class methodsFor: 'utilities' stamp: 'jm 5/23/2003 13:04'! addItem: item toMenu: menu selection: action project: aProject | c | c _ aProject isMorphic ifTrue: [Color red darker] ifFalse: [Color veryVeryDarkGray]. (menu isKindOf: MenuMorph) ifTrue: [ menu add: item selector: #jumpToSelection: argument: action. menu items last color: c] ifFalse: [ menu add: item action: action]. ! ! !Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'! allNames ^ (self allProjects collect: [:p | p name]) asSortedCollection: [:n1 :n2 | n1 asLowercase < n2 asLowercase]! ! !Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:30'! allNamesAndProjects ^ (self allProjects asSortedCollection: [:p1 :p2 | p1 name asLowercase < p2 name asLowercase]) collect: [:aProject | Array with: aProject name with: aProject]! ! !Project class methodsFor: 'utilities' stamp: 'di 6/10/1999 11:44'! allProjects ^ self allSubInstances select: [:p | p name notNil]! ! !Project class methodsFor: 'utilities' stamp: 'sw 3/6/1999 22:54'! buildJumpToMenu: menu "Make the supplied menu offer a list of potential projects, consisting of: * The previous-project chain * The next project, if any * The parent project, if any * All projects, alphabetically" | prev listed i next toAdd | listed _ OrderedCollection with: CurrentProject. i _ 0. prev _ CurrentProject previousProject. [(prev ~~ nil and: [(listed includes: prev) not])] whileTrue: [i _ i + 1. listed add: prev. self addItem: prev name , ' (back ' , i printString , ')' toMenu: menu selection: ('%back' , i printString) project: prev. prev _ prev previousProject]. (((next _ CurrentProject nextProject) ~~ nil) and: [(listed includes: next) not]) ifTrue: [self addItem: (next name, ' (forward 1)') toMenu: menu selection: next name project: next]. (i > 0 or: [next ~~ nil]) ifTrue: [menu addLine]. "Then the parent" CurrentProject isTopProject ifFalse: [self addItem: CurrentProject parent name , ' (parent)' toMenu: menu selection: #parent project: CurrentProject parent. menu addLine]. "Finally all the projects, in alphabetical order" Project allNamesAndProjects do: [:aPair | toAdd _ aPair last == CurrentProject ifTrue: [aPair first, ' (current)'] ifFalse: [aPair first]. self addItem: toAdd toMenu: menu selection: aPair first project: aPair last]. ^ menu ! ! !Project class methodsFor: 'utilities' stamp: 'di 6/13/1998 11:24'! jumpToProject "Project jumpToProject" "Present a list of potential projects and enter the one selected." self jumpToSelection: (self buildJumpToMenu: CustomMenu new) startUp ! ! !Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:09'! jumpToSelection: selection "Enter the project corresponding to this menu selection." "Project jumpToProject" | nBack prev pr | selection ifNil: [^ self]. (selection beginsWith: '%back') ifTrue: [nBack _ (selection copyFrom: 6 to: selection size) asNumber. prev _ CurrentProject previousProject. 1 to: nBack-1 do: [:i | prev ifNotNil: [prev _ prev previousProject]]. prev ifNotNil: [prev enter: true revert: false saveForRevert: false]]. selection = #parent ifTrue: [ CurrentProject parent enter: false revert: false saveForRevert: false. ^ self]. (pr _ Project named: selection) ifNil: [^ self]. pr enter: false revert: false saveForRevert: false ! ! !Project class methodsFor: 'utilities' stamp: 'tk 3/10/2000 21:10'! named: projName "Answer the project with the given name, or nil if there is no project of that given name." "(Project named: 'New Changes') enter" ^ self allProjects detect: [:proj | proj name = projName] ifNone: [nil] ! ! !Project class methodsFor: 'utilities' stamp: 'jm 5/23/2003 13:03'! ofWorld: aPasteUpMorph "Find the project of a world." "Usually it is the current project" self current world == aPasteUpMorph ifTrue: [^ self current]. "Inefficient enumeration if it is not..." ^ self allSubInstances detect: [:pr | pr world == aPasteUpMorph] ifNone: [nil] ! ! !Project class methodsFor: 'utilities' stamp: 'tk 10/26/1999 14:25'! returnToPreviousProject "Return to the project from which this project was entered. Do nothing if the current project has no link to its previous project." | prevProj | prevProj _ CurrentProject previousProject. prevProj ifNotNil: [prevProj enter: true revert: false saveForRevert: false]. ! ! !Project class methodsFor: 'constants' stamp: 'jm 5/29/2003 18:31'! current "Answer the project that is currently being used." ^ CurrentProject ! ! !ProjectController methodsFor: 'control activity' stamp: 'tk 10/26/1999 14:26'! redButtonActivity | index | view isCollapsed ifTrue: [^ super redButtonActivity]. (view insetDisplayBox containsPoint: Sensor cursorPoint) ifFalse: [^ super redButtonActivity]. index _ (PopUpMenu labelArray: #('enter' 'jump to project...') lines: #()) startUpCenteredWithCaption: nil. index = 0 ifTrue: [^ self]. "save size on enter for thumbnail on exit" model setViewSize: view insetDisplayBox extent. index = 1 ifTrue: [^ model enter: false revert: false saveForRevert: false]. index = 2 ifTrue: [Project jumpToProject. ^ self]. ! ! !ProjectView methodsFor: 'initialization' stamp: 'sw 8/4/1998 19:15'! maybeRelabel: newLabel "If the change set name given by newLabel is already in use, do nothing; else relabel the view" (newLabel isEmpty or: [newLabel = self label]) ifTrue: [^ self]. (ChangeSorter changeSetNamed: newLabel) == nil ifFalse: [^ self]. self relabel: newLabel! ! !ProjectView methodsFor: 'initialization' stamp: 'sw 1/11/2000 15:30'! uncacheBits super uncacheBits. self label ~= model name ifTrue: [self setLabelTo: model name]! ! !ProjectView methodsFor: 'displaying' stamp: 'tk 4/20/2000 21:27'! displayDeEmphasized | cmd | "Display this view with emphasis off. Check for a command that could not be executed in my subproject. Once it is done, remove the trigger." super displayDeEmphasized. ArmsLengthCmd ifNil: [^ self]. cmd _ ArmsLengthCmd. ArmsLengthCmd _ nil. model "project" perform: cmd. model "project" enter. ! ! !ProjectView methodsFor: 'displaying' stamp: 'sw 1/11/2000 15:32'! displayView super displayView. self label = model name ifFalse: [self setLabelTo: model name]. self isCollapsed ifTrue: [^ self]. model thumbnail ifNil: [^ self]. self insetDisplayBox extent = model thumbnail extent ifTrue: [model thumbnail displayAt: self insetDisplayBox topLeft] ifFalse: [(model thumbnail magnify: model thumbnail boundingBox by: self insetDisplayBox extent asFloatPoint / model thumbnail extent) displayAt: self insetDisplayBox topLeft] ! ! !ProjectView methodsFor: 'displaying' stamp: 'sw 9/14/1998 13:01'! release super release. Smalltalk garbageCollect! ! !ProjectView class methodsFor: 'as yet unclassified' stamp: 'tk 10/26/1999 14:26'! openAndEnter: aProject "Answer an instance of me for the argument, aProject. It is created on the display screen." | topView | topView _ self new model: aProject. topView minimumSize: 50 @ 30. topView borderWidth: 2. topView window: (RealEstateAgent initialFrameFor: topView). ScheduledControllers schedulePassive: topView controller. aProject enter: false revert: false saveForRevert: false! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'sw 9/22/1999 11:30'! borderColor ^ currentBorderColor ifNil: [currentBorderColor _ Color gray]! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'di 6/29/1999 10:44'! fullDrawOn: aCanvas (Preferences roundedWindowCorners and: [(owner isKindOf: SystemWindow) not]) ifTrue: [CornerRounder roundCornersOf: self on: aCanvas displayBlock: [super fullDrawOn: aCanvas] borderWidth: 1] ifFalse: [super fullDrawOn: aCanvas]! ! !ProjectViewMorph methodsFor: 'drawing' stamp: 'jm 11/13/2002 11:00'! showBorderAs: aColor form border: form boundingBox width: 1 fillColor: aColor. currentBorderColor _ aColor. self changed. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'tk 12/9/1999 08:03'! abandon "Home ViewMorph of project is going away." project _ nil. super abandon. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:34'! balloonText ^ 'Click here to enter the project named "', project name, '"'! ! !ProjectViewMorph methodsFor: 'events' stamp: 'di 6/22/1998 09:41'! deletingProject: aProject "My project is being deleted. Delete me as well." project == aProject ifTrue: [self delete].! ! !ProjectViewMorph methodsFor: 'events' stamp: 'jm 5/29/2003 18:07'! drawOn: aCanvas project ifNil: [^ super drawOn: aCanvas]. project thumbnail ifNil: [ form fill: (0@0 extent: form extent) rule: Form over fillColor: project defaultBackgroundColor. ^ super drawOn: aCanvas]. project thumbnail ~~ lastProjectThumbnail ifTrue: ["scale thumbnail to fit my bounds" (WarpBlt toForm: form) sourceForm: project thumbnail; cellSize: 2; "installs a colormap" combinationRule: Form over; copyQuad: (project thumbnail boundingBox) innerCorners toRect: (0@0 extent: form extent). lastProjectThumbnail _ project thumbnail. form borderWidth: 1]. super drawOn: aCanvas. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'jm 10/14/2002 18:41'! enter "Enter my project." (owner isKindOf: SystemWindow) ifTrue: [project setViewSize: self extent]. self showBorderAs: Color gray. project enter: false revert: false saveForRevert: false. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'jm 11/13/2002 11:01'! extent: aPoint "Set my image Form to the given extent." | newExtent scaleP scale | ((bounds extent = aPoint) and: [form depth = Display depth]) ifFalse: [ lastProjectThumbnail ifNil: [newExtent _ aPoint] ifNotNil: [ scaleP _ aPoint / lastProjectThumbnail extent. scale _ scaleP "scaleP x asFloat max: scaleP y asFloat". newExtent _ (lastProjectThumbnail extent * scale) rounded]. self form: (Form extent: newExtent depth: Display depth). lastProjectThumbnail _ nil]. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:41'! handlesMouseOver: evt ^ true! ! !ProjectViewMorph methodsFor: 'events' stamp: 'jm 6/15/2003 17:12'! initialize super initialize. color _ Color paleGreen. currentBorderColor _ Color gray. ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 12:48'! mouseDown: evt self showBorderAs: Color red. self world displayWorld. mouseDownTime _ Time millisecondClockValue! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:25'! mouseEnter: evt self showBorderAs: Color blue! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:20'! mouseLeave: evt self showBorderAs: Color gray! ! !ProjectViewMorph methodsFor: 'events' stamp: 'jm 10/2/2002 11:58'! mouseMove: evt | menu selection | (self containsPoint: evt cursorPoint) ifTrue: [self showBorderAs: Color red. mouseDownTime ifNil: [mouseDownTime _ Time millisecondClockValue] ifNotNil: [((Time millisecondClockValue - mouseDownTime) > 1100) ifTrue: [menu _ CustomMenu new. menu add: 'enter this project' action: #enter. selection _ (menu build preSelect: #enter) startUpCenteredWithCaption: ('Project Named ', '"', project name, '"'). selection = #enter ifTrue: [^ self enter]. ]]] ifFalse: [self showBorderAs: Color blue. mouseDownTime _ nil] ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'sw 9/22/1999 11:27'! mouseUp: evt (self containsPoint: evt cursorPoint) ifTrue: [^ self enter]. self showBorderAs: Color gray ! ! !ProjectViewMorph methodsFor: 'events' stamp: 'tk 4/1/2000 18:55'! step | cmd | "Check for a command that could not be executed in my subproject. Once it is done, remove the trigger. If this is too slow, make armsLengthCmd an inst var." cmd _ self valueOfProperty: #armsLengthCmd. cmd ifNil: [^ super step]. self removeProperty: #armsLengthCmd. (self valueOfProperty: #wasStepping) ifFalse: [ self stopStepping]. self removeProperty: #wasStepping. project perform: cmd. project enter.! ! !ProjectViewMorph methodsFor: 'accessing' stamp: 'tk 8/30/1999 11:48'! project ^project! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'jm 6/15/2003 17:07'! newMVCProject "Create an instance of me on a new MVC project (in a SystemWindow)." | proj window | proj _ Project new. window _ (SystemWindow labelled: proj name) model: proj. window addMorph: (self on: proj) frame: (0@0 corner: 1.0@1.0). ^ window ! ! !ProjectViewMorph class methodsFor: 'project window creation' stamp: 'di 7/19/1999 14:55'! newMorphicProjectOn: aPasteUpOrNil "Return an instance of me on a new Morphic project (in a SystemWindow)." | proj window | proj _ Project newMorphic. aPasteUpOrNil ifNotNil: [proj installPasteUpAsWorld: aPasteUpOrNil]. window _ (SystemWindow labelled: proj name) model: proj. window addMorph: (self on: proj) frame: (0@0 corner: 1.0@1.0). ^ window ! ! An instance of ProtocolBrowser shows the methods a class understands--inherited or implemented at this level--as a "flattened" list.! !ProtocolBrowser methodsFor: 'private' stamp: 'jm 5/15/2003 23:12'! onSubProtocolOf: aClass "Initialize with the entire protocol for the class, aClass, but excluding those inherited from Object." | sels | sels _ Set new. aClass withAllSuperclasses do: [:c | c == Object ifFalse: [sels addAll: c selectors]]. self initListFrom: sels asSortedCollection highlighting: aClass. ! ! !ProtocolBrowser methodsFor: 'private' stamp: 'di 3/31/1999 14:33'! setClassAndSelectorIn: csBlock "Decode strings of the form <selectorName> (<className> [class]) " | i classAndSelString sel | sel _ self selection asString. i _ sel indexOf: $(. "Rearrange to <className> [class] <selectorName> , and use MessageSet" classAndSelString _ (sel copyFrom: i + 1 to: sel size - 1) , ' ' , (sel copyFrom: 1 to: i - 1) withoutTrailingBlanks. MessageSet parse: classAndSelString toClassAndSelector: csBlock! ! !PseudoClass methodsFor: 'class'! classComment: aChangeRecord self organization classComment: aChangeRecord! ! !PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! classPool self exists ifFalse: [^ nil]. ^ self realClass classPool! ! !PseudoClass methodsFor: 'class'! comment | rStr | rStr := self organization commentRemoteStr. ^rStr isNil ifTrue:[self name,' has not been commented'] ifFalse:[rStr string]! ! !PseudoClass methodsFor: 'class'! comment: aString self commentString: aString.! ! !PseudoClass methodsFor: 'class' stamp: 'wod 4/15/98 17:21'! commentString ^self organization classComment asString! ! !PseudoClass methodsFor: 'class'! commentString: aString self classComment: aString asText. "Just wrap it"! ! !PseudoClass methodsFor: 'class'! definition ^definition ifNil:['There is no class definition for this class'].! ! !PseudoClass methodsFor: 'class'! definition: aString definition := aString! ! !PseudoClass methodsFor: 'class'! metaClass ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! ! !PseudoClass methodsFor: 'class'! renameTo: aString self hasDefinition ifTrue:[ self isMetaClass ifTrue:[ self definition: (self definition copyReplaceAll: name,' class' with: aString, ' class'). ] ifFalse:[ self definition: (self definition copyReplaceAll:'ubclass: #',name with:'ubclass: #', aString)]]. name := aString. metaClass ifNotNil:[metaClass renameTo: aString].! ! !PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! sharedPools self exists ifFalse: [^ nil]. ^ self realClass sharedPools! ! !PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'! allInstVarNames ^#()! ! !PseudoClass methodsFor: 'accessing' stamp: 'sma 2/6/2000 12:30'! allSuperclasses ^ self realClass allSuperclasses! ! !PseudoClass methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:24'! compilerClass ^ (Smalltalk at: name ifAbsent: [^ Compiler]) compilerClass! ! !PseudoClass methodsFor: 'accessing'! fullName ^self name! ! !PseudoClass methodsFor: 'accessing'! name ^name! ! !PseudoClass methodsFor: 'accessing'! name: anObject name _ anObject! ! !PseudoClass methodsFor: 'accessing'! organization ^organization ifNil:[organization := PseudoClassOrganizer defaultList: SortedCollection new].! ! !PseudoClass methodsFor: 'accessing'! realClass ^Smalltalk at: self name asSymbol! ! !PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! ! !PseudoClass methodsFor: 'removing'! removeAllUnmodified | stClass | self exists ifFalse:[^self]. self removeUnmodifiedMethods: self selectors. stClass := self realClass. (self hasDefinition and:[stClass definition = self definition]) ifTrue:[definition := nil]. (self hasComment and:[stClass comment asString = self commentString]) ifTrue:[ self classComment: nil]. metaClass isNil ifFalse:[metaClass removeAllUnmodified].! ! !PseudoClass methodsFor: 'removing'! removeUnmodifiedMethods: aCollection | stClass | self exists ifFalse:[^self]. stClass := self realClass. aCollection do:[:sel| (self sourceCodeAt: sel) = (stClass sourceCodeAt: sel ifAbsent:['']) asString ifTrue:[ self removeMethod: sel. ]. ]. self organization removeEmptyCategories.! ! !PseudoClass methodsFor: 'private' stamp: 'sma 2/6/2000 12:23'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level ^ self realClass allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! ! !PseudoClass methodsFor: 'private'! confirmRemovalOf: aString ^self confirm:'Remove ',aString,' ?'! ! !PseudoClass methodsFor: 'private'! evaluate: aString ^Compiler evaluate: aString for: nil logged: true! ! !PseudoClass methodsFor: 'private'! makeSureClassExists: aString | theClass | theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil]. theClass ifNotNil:[^true]. ^self confirm: aString,' does not exist in the system. Use nil instead?'.! ! !PseudoClass methodsFor: 'private'! makeSureSuperClassExists: aString | theClass | theClass := Smalltalk at: (aString asSymbol) ifAbsent:[nil]. theClass ifNotNil:[^true]. ^self confirm: 'The super class ',aString,' does not exist in the system. Use nil instead?'.! ! !PseudoClass methodsFor: 'private'! parserClass ^Parser! ! !PseudoClass methodsFor: 'testing'! exists ^(Smalltalk at: self name asSymbol ifAbsent:[^false]) isKindOf: Behavior! ! !PseudoClass methodsFor: 'testing'! hasChanges self sourceCode isEmpty ifFalse:[^true]. self organization hasNoComment ifFalse:[^true]. definition isNil ifFalse:[^true]. metaClass isNil ifFalse:[^metaClass hasChanges]. ^false! ! !PseudoClass methodsFor: 'testing'! hasComment ^self organization commentRemoteStr notNil! ! !PseudoClass methodsFor: 'testing'! hasDefinition ^definition notNil! ! !PseudoClass methodsFor: 'testing'! hasMetaclass ^metaClass notNil! ! !PseudoClass methodsFor: 'testing'! isMetaClass ^false! ! !PseudoClass methodsFor: 'testing'! nameExists ^Smalltalk includesKey: self name asSymbol! ! !PseudoClass methodsFor: 'testing'! needsInitialize ^self hasMetaclass and:[ self metaClass selectors includes: #initialize]! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileIn "FileIn the receiver" self hasDefinition ifTrue:[self fileInDefinition]. self fileInMethods: self selectors. metaClass ifNotNil:[metaClass fileIn]. self needsInitialize ifTrue:[ self evaluate: self name,' initialize'. ].! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileInCategory: aCategory ^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileInDefinition (self makeSureSuperClassExists: (definition copyUpTo: Character space)) ifFalse:[^self]. self hasDefinition ifTrue:[ Transcript cr; show:'Defining ', self name. self evaluate: self definition]. self exists ifFalse:[^self]. self hasComment ifTrue:[self realClass classComment: self comment].! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileInMethod: selector ^self fileInMethods: (Array with: selector)! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileInMethods ^self fileInMethods: self selectors! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileInMethods: aCollection "FileIn all methods with selectors taken from aCollection" | theClass cat | self exists ifFalse:[^self classNotDefined]. theClass := self realClass. aCollection do:[:sel| cat := self organization categoryOfElement: sel. cat = self removedCategoryName ifFalse:[ theClass compile: (self sourceCodeAt: sel) classified: cat withStamp: (self stampAt: sel) notifying: nil. ]. ].! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOut | f | f := (FileStream newFileNamed: self name,'.st'). self fileOutOn: f. self needsInitialize ifTrue:[ f cr; nextChunkPut: self name,' initialize'. ]. f close! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutCategory: categoryName | f | f := (FileStream newFileNamed: self name,'-',categoryName,'.st'). self fileOutMethods: (self organization listAtCategoryNamed: categoryName) on: f. f close ! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutDefinitionOn: aStream self hasDefinition ifFalse:[^self]. aStream nextChunkPut: self definition; cr. self hasComment ifTrue:[ aStream cr; nextPut: $!!; nextChunkPut: self name,' comment: '; cr. aStream nextChunkPut: self commentString printString. ].! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutMethod: selector | f | f := (FileStream newFileNamed: self name,'-', selector, '.st'). self fileOutMethods: (Array with: selector) on: f. f close! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutMethods: aCollection on: aStream "FileOut all methods with selectors taken from aCollection" | cat categories | categories := Dictionary new. aCollection do:[:sel| cat := self organization categoryOfElement: sel. cat = self removedCategoryName ifFalse:[ (categories includesKey: cat) ifFalse:[categories at: cat put: Set new]. (categories at: cat) add: sel]. ]. categories associationsDo:[:assoc| cat := assoc key. aStream cr; cr; nextPut:$!!; nextChunkPut:(String streamContents:[:s| s nextPutAll: self fullName; nextPutAll:' methodsFor: '; print: cat asString]). assoc value do:[:sel| aStream cr. aStream nextChunkPut: (self sourceCodeAt: sel). ]. aStream space; nextPut:$!!. ].! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutMethodsOn: aStream ^self fileOutMethods: self selectors on: aStream.! ! !PseudoClass methodsFor: 'fileIn/fileOut'! fileOutOn: aStream "FileOut the receiver" self fileOutDefinitionOn: aStream. metaClass ifNotNil:[metaClass fileOutDefinitionOn: aStream]. self fileOutMethods: self selectors on: aStream. metaClass ifNotNil:[metaClass fileOutMethods: metaClass selectors on: aStream].! ! !PseudoClass methodsFor: 'errors'! classNotDefined ^self inform: self name,' is not defined in the system. You have to define this class first.'.! ! !PseudoClass methodsFor: 'categories'! removeCategory: selector (self organization listAtCategoryNamed: selector) do:[:sel| self organization removeElement: sel. self sourceCode removeKey: sel. ]. self organization removeCategory: selector.! ! !PseudoClass methodsFor: 'categories'! removedCategoryName ^'*** removed methods ***' asSymbol! ! !PseudoClass methodsFor: 'categories'! 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 organization categoryOfElement: aSelector! ! !PseudoClass methodsFor: 'methods' stamp: 'sma 6/1/2000 14:54'! addMethodChange: aChangeRecord | selector | selector _ self parserClass new parseSelector: aChangeRecord string. self organization classify: selector under: aChangeRecord category. self sourceCodeAt: selector put: aChangeRecord! ! !PseudoClass methodsFor: 'methods'! methodChange: aChangeRecord aChangeRecord isMetaClassChange ifTrue:[ ^self metaClass addMethodChange: aChangeRecord. ] ifFalse:[ ^self addMethodChange: aChangeRecord. ]. ! ! !PseudoClass methodsFor: 'methods'! removeMethod: selector self organization removeElement: selector. self sourceCode removeKey: selector. ! ! !PseudoClass methodsFor: 'methods'! removeSelector: aSelector | catName | catName := self removedCategoryName. self organization addCategory: catName before: self organization categories first. self organization classify: aSelector under: catName. self sourceCodeAt: aSelector put:'methodWasRemoved' asText.! ! !PseudoClass methodsFor: 'methods'! selectors ^self sourceCode keys! ! !PseudoClass methodsFor: 'methods'! sourceCode ^source ifNil:[source := Dictionary new]! ! !PseudoClass methodsFor: 'methods'! sourceCodeAt: sel ^(self sourceCode at: sel) string! ! !PseudoClass methodsFor: 'methods'! sourceCodeAt: sel put: object self sourceCode at: sel put: object! ! !PseudoClass methodsFor: 'methods'! sourceCodeTemplate ^''! ! !PseudoClass methodsFor: 'methods'! stampAt: selector ^(self sourceCode at: selector) stamp! ! !PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'! literalScannedAs: scannedLiteral notifying: requestor ^ scannedLiteral! ! !PseudoClass methodsFor: 'testing method dictionary' stamp: 'sma 6/5/2000 10:26'! scopeHas: varName ifTrue: assocBlock (self exists and: [self realClass scopeHas: varName ifTrue: assocBlock]) ifTrue: [^ true]. assocBlock value: (Smalltalk associationAt: varName asSymbol ifAbsent: [^ false]). ^ true! ! !PseudoClassOrganizer methodsFor: 'as yet unclassified' stamp: 'wod 4/15/98 17:08'! classComment "Answer the comment associated with the object that refers to the receiver." globalComment == nil ifTrue: [^'']. ^globalComment! ! !PseudoClassOrganizer methodsFor: 'as yet unclassified'! classComment: aChangeRecord globalComment := aChangeRecord! ! !PseudoClassOrganizer methodsFor: 'as yet unclassified'! setDefaultList: aCollection super setDefaultList: aCollection. self classComment: nil.! ! !PseudoMetaclass methodsFor: 'accessing'! fullName ^self name,' class'! ! !PseudoMetaclass methodsFor: 'accessing'! realClass ^super realClass class! ! !PseudoMetaclass methodsFor: 'testing'! isMetaClass ^true! ! I represent a particular kind of Rectangle that has a border and inside color.! !RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 2/7/2000 15:34'! next: anInteger "Answer the next anInteger elements of my collection. Must override to get class right." | newArray | newArray _ (isBinary ifTrue: [ByteArray] ifFalse: [String]) new: anInteger. ^ self nextInto: newArray! ! !RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 1/14/1999 20:16'! padToEndWith: aChar "We don't have pages, so we are at the end, and don't need to pad."! ! !RWBinaryOrTextStream methodsFor: 'as yet unclassified' stamp: 'tk 10/1/1998 11:54'! setFileTypeToObject "do nothing. We don't have a file type"! ! This Random Number Generator graciously contributed by David N. Smith. It is an adaptation of the Park-Miller RNG which uses Floats to avoid the need for LargeInteger arithmetic.! !Random methodsFor: 'initialization' stamp: 'di 8/6/1999 15:32'! initialize " Set a reasonable Park-Miller starting seed " [seed := (Time millisecondClockValue bitAnd: 16r3FFFFFFF) bitXor: self hash. seed = 0] whileTrue: ["Try again if ever get a seed = 0"]. a := 16r000041A7 asFloat. " magic constant = 16807 " m := 16r7FFFFFFF asFloat. " magic constant = 2147483647 " q := (m quo: a) asFloat. r := (m \\ a) asFloat. ! ! !Random methodsFor: 'initialization' stamp: 'sma 5/12/2000 12:29'! seed: anInteger seed _ anInteger! ! !Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'! next "Answer a random Float in the interval [0 to 1)." ^ (seed _ self nextValue) / m! ! !Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:45'! next: anInteger ^ self next: anInteger into: (Array new: anInteger)! ! !Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:46'! next: anInteger into: anArray 1 to: anInteger do: [:index | anArray at: index put: self next]. ^ anArray! ! !Random methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:25'! nextInt: anInteger "Answer a random integer in the interval [1, anInteger]." ^ (self next * anInteger) truncated + 1! ! !Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'! check: nDice "Roll some dice, WoD-style." ^ self check: nDice difficulty: 6! ! !Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:47'! check: nAttack against: nDefend "Roll some dice, WoD-style." ^ self check: nAttack against: nDefend difficulty: 6! ! !Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:46'! check: nAttack against: nDefend difficulty: diff "Roll some dice, WoD-style." | attacks defends | attacks _ self check: nAttack difficulty: diff. attacks < 0 ifTrue: [^ attacks]. defends _ self check: nDefend difficulty: diff. ^ attacks - defends min: 0! ! !Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:42'! check: nDice difficulty: diff "Roll some dice, WoD-style." | result die | result _ 0. nDice timesRepeat: [(die _ self nextInt: 10) = 1 ifTrue: [result _ result - 1] ifFalse: [die >= diff ifTrue: [result _ result + 1]]]. ^ result! ! !Random methodsFor: 'die rolling' stamp: 'sma 5/12/2000 13:48'! diceToken: stream "Private. Mini scanner, see #roll:" stream atEnd ifTrue: [^ nil]. stream peek isDigit ifTrue: [^ Number readFrom: stream]. ^ stream next asLowercase! ! !Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:28'! nextValue "This method generates random instances of Integer in the interval 0 to 16r7FFFFFFF. This method does NOT update the seed; repeated sends answer the same value. The algorithm is described in detail in 'Random Number Generators: Good Ones Are Hard to Find' by Stephen K. Park and Keith W. Miller (Comm. Asso. Comp. Mach., 31(10):1192--1201, 1988)." | lo hi aLoRHi answer | hi _ (seed quo: q) asFloat. lo _ seed - (hi * q). " = seed rem: q" aLoRHi _ (a * lo) - (r * hi). answer _ (aLoRHi > 0.0) ifTrue: [aLoRHi] ifFalse: [aLoRHi + m]. ^ answer! ! !Random methodsFor: 'private' stamp: 'sma 5/12/2000 12:43'! seed ^ seed! ! !Random class methodsFor: 'examples' stamp: 'sma 5/12/2000 12:39'! example "If you just want a quick random integer, use: 10 atRandom Every integer interval can give a random number: (6 to: 12) atRandom SequenceableCollections can give randomly selected elements: 'pick one of these letters randomly' atRandom SequenceableCollections also respond to shuffled, as in: ($A to: $Z) shuffled The correct way to use class Random is to store one in an instance or class variable: myGenerator _ Random new. Then use it every time you need another number between 0.0 and 1.0 (excluding) myGenerator next You can also generate a positive integer myGenerator nextInt: 10 "! ! !Random class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 12:41'! seed: anInteger ^ self new initialize seed: anInteger! ! I represent an accessor for a sequence of objects that can only read objects from the sequence.! !ReadStream methodsFor: 'accessing'! next "Primitive. Answer the next object in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Optional. See Object documentation whatIsAPrimitive." <primitive: 65> position >= readLimit ifTrue: [^nil] ifFalse: [^collection at: (position _ position + 1)]! ! !ReadStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:46'! next: anInteger "Answer the next anInteger elements of my collection. overriden for efficiency" | ans endPosition | endPosition _ position + anInteger min: readLimit. ans _ collection copyFrom: position+1 to: endPosition. position _ endPosition. ^ans ! ! !ReadStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:01'! next: n into: aCollection startingAt: startIndex "Read n objects into the given collection. Return aCollection or a partial copy if less than n elements have been read." | max | max _ (readLimit - position) min: n. aCollection replaceFrom: startIndex to: startIndex+max-1 with: collection startingAt: position+1. position _ position + max. max = n ifTrue:[^aCollection] ifFalse:[^aCollection copyFrom: 1 to: startIndex+max-1]! ! !ReadStream methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:20'! size "Compatibility with other streams (e.g., FileStream)" ^readLimit! ! !ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'! upTo: anObject "fast version using indexOf:" | start end | start _ position+1. end _ collection indexOf: anObject startingAt: start ifAbsent: [ 0 ]. "not present--return rest of the collection" end = 0 ifTrue: [ ^self upToEnd ]. "skip to the end and return the data passed over" position _ end. ^collection copyFrom: start to: (end-1)! ! !ReadStream methodsFor: 'accessing' stamp: 'ls 9/12/1998 00:59'! upToEnd | start | start _ position+1. position _ collection size. ^collection copyFrom: start to: position! ! I represent an accessor for a sequence of objects. My instances can both read and store objects.! !ReadWriteStream methodsFor: 'accessing' stamp: 'ls 8/16/1998 00:47'! next: anInteger "Answer the next anInteger elements of my collection. overriden for efficiency" | ans endPosition | endPosition _ position + anInteger min: readLimit. ans _ collection copyFrom: position+1 to: endPosition. position _ endPosition. ^ans ! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'di 5/25/1998 15:25'! checkForPreamble: chunk ((chunk beginsWith: '"Change Set:') and: [Smalltalk changes preambleString == nil]) ifTrue: [Smalltalk changes preambleString: chunk]. ((chunk beginsWith: '"Postscript:') and: [Smalltalk changes postscriptString == nil]) ifTrue: [Smalltalk changes postscriptString: chunk]. ! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:31'! fileIn "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation." ^ self fileInAnnouncing: 'Reading ' , self name! ! !ReadWriteStream methodsFor: 'fileIn/Out' stamp: 'sw 11/19/1998 16:29'! fileInAnnouncing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title." | val chunk | announcement displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar value: self position. self skipSeparators. val _ (self peekFor: $!!) ifTrue: [(Compiler evaluate: self nextChunk logged: false) scanFrom: self] ifFalse: [chunk _ self nextChunk. self checkForPreamble: chunk. Compiler evaluate: chunk logged: true]. self skipStyleChunk]. self close]. ^ val! ! !ReadWriteStream methodsFor: 'converting' stamp: 'tk 3/22/2000 18:03'! asUnZippedStream | isGZip outputStream first | "Decompress this file if needed, and return a stream. No file is written. File extension may be .gz or anything else." self binary. first _ self next. isGZip _ (self next * 256 + first) = (GZipConstants at: #GZipMagic). self skip: -2. isGZip ifTrue: [outputStream _ (RWBinaryOrTextStream with: (GZipReadStream on: self) upToEnd) reset. self close] ifFalse: [outputStream _ self]. ^ outputStream! ! Responsible for real-estate management on the screen, which is to say, controlling where new windows appear, with what sizes, etc. 5/20/96 sw! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jm 5/29/2003 19:23'! assignCollapseFrameFor: aSSView "Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames." | grid otherFrames topLeft viewBox collapsedFrame extent newFrame verticalBorderDistance top | grid _ 8. verticalBorderDistance _ 8. Smalltalk isMorphic ifTrue: [otherFrames _ ((SystemWindow windowsIn: World satisfying: [:w | w ~= aSSView]) collect: [:w | w collapsedFrame]) select: [:rect | rect notNil]. viewBox _ World viewBox] ifFalse: [otherFrames _ (ScheduledControllers scheduledWindowControllers collect: [:aController | aController view ~= aSSView ifTrue: [aController view collapsedFrame]]) select: [:rect | rect notNil]. viewBox _ Display boundingBox]. collapsedFrame _ aSSView collapsedFrame. extent _ collapsedFrame notNil ifTrue: [collapsedFrame extent] ifFalse: [Smalltalk isMorphic ifTrue: [aSSView getRawLabel width + aSSView labelWidgetAllowance @ (aSSView labelHeight + 2)] ifFalse: [(aSSView labelText extent x + 70) @ aSSView labelHeight min: aSSView labelDisplayBox extent ] ]. collapsedFrame notNil ifTrue: [(otherFrames anySatisfy: [:f | collapsedFrame intersects: f]) ifFalse: ["non overlapping" ^ collapsedFrame]]. top _ viewBox top + verticalBorderDistance. [topLeft _ viewBox left @ top. newFrame _ topLeft extent: extent. newFrame bottom <= (viewBox height - verticalBorderDistance)] whileTrue: [(otherFrames anySatisfy: [:w | newFrame intersects: w]) ifFalse: ["no overlap" ^ newFrame]. top _ top + grid]. "If all else fails... (really to many wins here)" ^ 0 @ 0 extent: extent! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'jm 5/29/2003 19:23'! assignCollapsePointFor: aSSView "Offer up a location along the left edge of the screen for a collapsed SSView. Make sure it doesn't overlap any other collapsed frames." | grid otherFrames y free topLeft viewBox | grid _ 24. "should be mult of 8, since manual move is gridded by 8" Smalltalk isMorphic ifTrue: [otherFrames _ ((SystemWindow windowsIn: World satisfying: [:w | true]) collect: [:w | w collapsedFrame]) select: [:rect | rect notNil]. viewBox _ World viewBox] ifFalse: [otherFrames _ (ScheduledControllers scheduledWindowControllers collect: [:aController | aController view collapsedFrame]) select: [:rect | rect notNil]. viewBox _ Display boundingBox]. y _ viewBox top. [(y _ y + grid) <= (viewBox height - grid)] whileTrue: [topLeft _ viewBox left@y. free _ true. otherFrames do: [:w | free _ free & (topLeft ~= w topLeft)]. free ifTrue: [^ topLeft]]. "If all else fails..." ^ 0 @ 0! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 8/10/1999 11:57'! initialFrameFor: aView "Find a plausible initial screen area for the supplied view. See called method." ^ self initialFrameFor: aView initialExtent: aView initialExtent! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:49'! initialFrameFor: aView initialExtent: initialExtent "Find a plausible initial screen area for the supplied view, which should be a StandardSystemView, taking into account the 'reverseWindowStagger' Preference, the size needed, and other windows currently on the screen." | allOrigins screenRight screenBottom putativeOrigin putativeFrame allowedArea staggerOrigin otherFrames | Preferences reverseWindowStagger ifTrue: [^ self strictlyStaggeredInitialFrameFor: aView initialExtent: initialExtent]. allowedArea _ self maximumUsableArea. screenRight _ allowedArea right. screenBottom _ allowedArea bottom. otherFrames _ Smalltalk isMorphic ifTrue: [(SystemWindow windowsIn: World satisfying: [:w | w isCollapsed not]) collect: [:w | w bounds]] ifFalse: [ScheduledControllers scheduledWindowControllers select: [:aController | aController view ~~ nil] thenCollect: [:aController | aController view isCollapsed ifTrue: [aController view expandedFrame] ifFalse: [aController view displayBox]]]. allOrigins _ otherFrames collect: [:f | f origin]. self standardPositions do: "First see if one of the standard positions is free" [:aPosition | (allOrigins includes: aPosition) ifFalse: [^ (aPosition extent: initialExtent) squishedWithin: allowedArea]]. staggerOrigin _ self standardPositions first. "Fallback: try offsetting from top left" putativeOrigin _ staggerOrigin. [putativeOrigin _ putativeOrigin + StaggerOffset. putativeFrame _ putativeOrigin extent: initialExtent. (putativeFrame bottom < screenBottom) and: [putativeFrame right < screenRight]] whileTrue: [(allOrigins includes: putativeOrigin) ifFalse: [^ (putativeOrigin extent: initialExtent) squishedWithin: allowedArea]]. ^ (self scrollBarSetback @ self screenTopSetback extent: initialExtent) squishedWithin: allowedArea! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'tk 11/26/1998 09:34'! initialize "Initialize the class variables in the receiver. 5/22/96 sw" "RealEstateAgent initialize" StaggerOffset _ 6 @ 20. ReverseStaggerOffset _ -6 @ 20. StaggerOrigin _ 200 @ 30. StandardSize _ 600@400.! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:49'! maximumUsableArea | allowedArea | allowedArea _ Display usableArea. Smalltalk isMorphic ifTrue: [allowedArea _ allowedArea intersect: World viewBox]. ^allowedArea ! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 9/22/1998 20:58'! screenTopSetback Smalltalk isMorphic ifTrue: [^ 0] ifFalse: [^ 18]! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'di 9/22/1998 20:58'! scrollBarSetback Smalltalk isMorphic ifTrue: [^ 16-3] "width = 16; inset from border by 3" ifFalse: [^ 24]! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:49'! standardPositions "Return a list of standard window positions -- this may have one, two, or four of them, depending on the size and shape of the display screen. " | anArea aList midX midY | anArea _ self maximumUsableArea. midX _ self scrollBarSetback + ((anArea width - self scrollBarSetback) // 2). midY _ self screenTopSetback + ((anArea height - self screenTopSetback) // 2). aList _ OrderedCollection with: (self scrollBarSetback @ self screenTopSetback). self windowColumnsDesired > 1 ifTrue: [aList add: (midX @ self screenTopSetback)]. self windowRowsDesired > 1 ifTrue: [aList add: (self scrollBarSetback @ (midY+self screenTopSetback)). self windowColumnsDesired > 1 ifTrue: [aList add: (midX @ (midY+self screenTopSetback))]]. ^ aList! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:55'! standardWindowExtent "Answer the standard default extent for new windows. " | effectiveExtent width strips height grid allowedArea maxLevel | effectiveExtent _ self maximumUsableArea extent - (self scrollBarSetback @ self screenTopSetback). Preferences reverseWindowStagger ifTrue: ["NOTE: following copied from strictlyStaggeredInitialFrameFor:" allowedArea _ self maximumUsableArea insetBy: ( self scrollBarSetback @ self screenTopSetback extent: 0@0 ). "Number to be staggered at each corner (less on small screens)" maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. "Amount by which to stagger (less on small screens)" grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. ^ (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2))) min: StandardSize "600@400"]. width _ (strips _ self windowColumnsDesired) > 1 ifTrue: [effectiveExtent x // strips] ifFalse: [(3 * effectiveExtent x) // 4]. height _ (strips _ self windowRowsDesired) > 1 ifTrue: [effectiveExtent y // strips] ifFalse: [(3 * effectiveExtent y) //4]. ^ width @ height "RealEstateAgent standardWindowExtent"! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:53'! strictlyStaggeredInitialFrameFor: aStandardSystemView initialExtent: initialExtent "This method implements a staggered window placement policy that I like. Basically it provides for up to 4 windows, staggered from each of the 4 corners. The windows are staggered so that there will always be a corner visible. " | allowedArea grid initialFrame otherFrames cornerSel corner delta putativeCorner free maxLevel | allowedArea _ self maximumUsableArea insetBy: ( self scrollBarSetback @ self screenTopSetback extent: 0@0 ). "Number to be staggered at each corner (less on small screens)" maxLevel _ allowedArea area > 300000 ifTrue: [3] ifFalse: [2]. "Amount by which to stagger (less on small screens)" grid _ allowedArea area > 500000 ifTrue: [40] ifFalse: [20]. initialFrame _ 0@0 extent: ((initialExtent "min: (allowedArea extent - (grid*(maxLevel+1*2) + (grid//2)))) min: 600@400")). otherFrames _ Smalltalk isMorphic ifTrue: [(SystemWindow windowsIn: World satisfying: [:w | w isCollapsed not]) collect: [:w | w bounds]] ifFalse: [ScheduledControllers scheduledWindowControllers select: [:aController | aController view ~~ nil] thenCollect: [:aController | aController view isCollapsed ifTrue: [aController view expandedFrame] ifFalse: [aController view displayBox]]]. 0 to: maxLevel do: [:level | 1 to: 4 do: [:ci | cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: ci. corner _ allowedArea perform: cornerSel. "The extra grid//2 in delta helps to keep title tabs distinct" delta _ (maxLevel-level*grid+(grid//2)) @ (level*grid). 1 to: ci-1 do: [:i | delta _ delta rotateBy: #right centerAt: 0@0]. "slow way" putativeCorner _ corner + delta. free _ true. otherFrames do: [:w | free _ free & ((w perform: cornerSel) ~= putativeCorner)]. free ifTrue: [^ (initialFrame align: (initialFrame perform: cornerSel) with: putativeCorner) squishedWithin: allowedArea]]]. "If all else fails..." ^ (self scrollBarSetback @ self screenTopSetback extent: initialFrame extent) squishedWithin: allowedArea! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:54'! windowColumnsDesired "Answer how many separate vertical columns of windows are wanted. 5/22/96 sw" ^ Preferences reverseWindowStagger ifTrue: [1] ifFalse: [(self maximumUsableArea width > 640) ifTrue: [2] ifFalse: [1]]! ! !RealEstateAgent class methodsFor: 'as yet unclassified' stamp: 'RAA 11/21/1999 22:54'! windowRowsDesired "Answer how many separate horizontal rows of windows are wanted. 5/22/96 sw" ^ Preferences reverseWindowStagger ifTrue: [1] ifFalse: [(self maximumUsableArea height > 480) ifTrue: [2] ifFalse: [1]]! ! I am a simple interface for recording sounds. ! !RecordingControlsMorph methodsFor: 'initialization' stamp: 'jm 6/15/2003 20:23'! addButtonRows | r | r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: (self buttonName: 'Record' action: #record). r addMorphBack: (Morph new extent: 4@1; color: color). r addMorphBack: (self buttonName: 'Stop' action: #stop). r addMorphBack: (Morph new extent: 4@1; color: color). r addMorphBack: self makeStatusLight. self addMorphBack: r. r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: (self buttonName: 'Play' action: #playback). r addMorphBack: (Morph new extent: 4@1; color: color). r addMorphBack: (self buttonName: 'Trim' action: #trim). r addMorphBack: (Morph new extent: 4@1; color: color). r addMorphBack: (self buttonName: 'Edit' action: #showSamples). self addMorphBack: r. ! ! !RecordingControlsMorph methodsFor: 'initialization' stamp: 'jm 7/4/1998 14:43'! initialize | r | super initialize. borderWidth _ 2. orientation _ #vertical. recorder _ SoundRecorder new. self addButtonRows. self addRecordLevelSlider. r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: self makeRecordMeter. self addMorphBack: r. self extent: 10@10. "make minimum size" ! ! !RecordingControlsMorph methodsFor: 'button commands' stamp: 'jm 6/15/2003 19:48'! showSamples "Show my samples in a SimpleWaveEditor." | ed w | recorder pause. ed _ SimpleWaveEditor new. ed data: recorder condensedSamples. ed samplingRate: recorder samplingRate. w _ self world. w activeHand ifNil: [w addMorph: ed] ifNotNil: [w activeHand attachMorph: ed]. ! ! !RecordingControlsMorph methodsFor: 'stepping' stamp: 'tk 6/24/1999 11:41'! startStepping "Make the level meter active when dropped into the world. Do nothing if already recording. Note that this will cause other recorders to stop recording..." super startStepping. recorder isPaused ifTrue: [ SoundRecorder allSubInstancesDo: [:r | r stopRecording]. "stop all other sound recorders" recorder pause]. "meter is updated while paused" ! ! !RecordingControlsMorph methodsFor: 'other' stamp: 'jm 7/4/1998 14:49'! addRecordLevelSlider | levelSlider r | levelSlider _ SimpleSliderMorph new color: color; extent: 100@2; target: recorder; actionSelector: #recordLevel:; adjustToValue: recorder recordLevel. r _ AlignmentMorph newRow color: color; inset: 0; centering: #center; hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: '0 '). r addMorphBack: levelSlider. r addMorphBack: (StringMorph contents: ' 10'). self addMorphBack: r. ! ! !RecordingControlsMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! I represent a rectangular area of the screen. Arithmetic functions take points as arguments and carry out scaling and translating operations to create new instances of me. Rectangle functions create new instances by determining intersections of rectangles with rectangles.! !Rectangle methodsFor: 'accessing' stamp: 'acg 2/23/2000 00:52'! aboveCenter "Answer the point slightly above the center of the receiver." ^self topLeft + self bottomRight // (2@3)! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/22/1998 16:11'! adjustTo: newRect along: side "Return a copy adjusted to fit a neighbor that has changed size." side = #left ifTrue: [^ self withRight: newRect left]. side = #right ifTrue: [^ self withLeft: newRect right]. side = #top ifTrue: [^ self withBottom: newRect top]. side = #bottom ifTrue: [^ self withTop: newRect bottom].! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:00'! bordersOn: her along: herSide (herSide = #right and: [self left = her right]) | (herSide = #left and: [self right = her left]) ifTrue: [^ (self top max: her top) < (self bottom min: her bottom)]. (herSide = #bottom and: [self top = her bottom]) | (herSide = #top and: [self bottom = her top]) ifTrue: [^ (self left max: her left) < (self right min: her right)]. ^ false! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 16:11'! forPoint: aPoint closestSideDistLen: sideDistLenBlock "Evaluate the block with my side (symbol) closest to aPoint, the approx distance of aPoint from that side, and the length of the side (or 0 if aPoint is beyond the side)" | side | side _ self sideNearestTo: aPoint. side == #right ifTrue: [^ sideDistLenBlock value: side value: (self right - aPoint x) abs value: ((aPoint y between: self top and: self bottom) ifTrue: [self height] ifFalse: [0])]. side == #left ifTrue: [^ sideDistLenBlock value: side value: (self left - aPoint x) abs value: ((aPoint y between: self top and: self bottom) ifTrue: [self height] ifFalse: [0])]. side == #bottom ifTrue: [^ sideDistLenBlock value: side value: (self bottom - aPoint y) abs value: ((aPoint x between: self left and: self right) ifTrue: [self width] ifFalse: [0])]. side == #top ifTrue: [^ sideDistLenBlock value: side value: (self top - aPoint y) abs value: ((aPoint x between: self left and: self right) ifTrue: [self width] ifFalse: [0])].! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'di 10/21/1998 15:09'! sideNearestTo: aPoint | distToLeft distToRight distToTop distToBottom closest side | distToLeft _ aPoint x - self left. distToRight _ self right - aPoint x. distToTop _ aPoint y - self top. distToBottom _ self bottom - aPoint y. closest _ distToLeft. side _ #left. distToRight < closest ifTrue: [closest _ distToRight. side _ #right]. distToTop < closest ifTrue: [closest _ distToTop. side _ #top]. distToBottom < closest ifTrue: [closest _ distToBottom. side _ #bottom]. ^ side " | r | r _ Rectangle fromUser. Display border: r width: 1. [Sensor anyButtonPressed] whileFalse: [(r sideNearestTo: Sensor cursorPoint) , ' ' displayAt: 0@0] "! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'di 9/8/1999 21:25'! withSideOrCorner: side setToPoint: newPoint "Return a copy with side set to newPoint" ^ self withSideOrCorner: side setToPoint: newPoint minExtent: 0@0! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:16'! withSideOrCorner: side setToPoint: newPoint minExtent: minExtent "Return a copy with side set to newPoint" ^self withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: ((#(left top) includes: side) ifTrue: [SmallInteger minVal] ifFalse: [SmallInteger maxVal])! ! !Rectangle methodsFor: 'rectangle functions' stamp: 'bf 9/10/1999 16:07'! withSideOrCorner: side setToPoint: newPoint minExtent: minExtent limit: limit "Return a copy with side set to newPoint" side = #top ifTrue: [^ self withTop: (newPoint y min: corner y - minExtent y max: limit + minExtent y)]. side = #bottom ifTrue: [^ self withBottom: (newPoint y min: limit - minExtent y max: origin y + minExtent y)]. side = #left ifTrue: [^ self withLeft: (newPoint x min: corner x - minExtent x max: limit + minExtent x)]. side = #right ifTrue: [^ self withRight: (newPoint x min: limit - minExtent x max: origin x + minExtent x)]. side = #topLeft ifTrue: [^ (newPoint min: corner - minExtent) corner: self bottomRight]. side = #bottomRight ifTrue: [^ self topLeft corner: (newPoint max: origin + minExtent)]. side = #bottomLeft ifTrue: [^ self topRight rect: ((newPoint x min: corner x - minExtent x) @ (newPoint y max: origin y + minExtent y))]. side = #topRight ifTrue: [^ self bottomLeft rect: ((newPoint x max: origin x + minExtent x) @ (newPoint y min: corner y - minExtent y))].! ! !Rectangle methodsFor: 'testing' stamp: 'jm 6/17/1999 19:40'! intersects: aRectangle "Answer whether aRectangle intersects the receiver anywhere." "Optimized; old code answered: (origin max: aRectangle origin) < (corner min: aRectangle corner)" | rOrigin rCorner | rOrigin _ aRectangle origin. rCorner _ aRectangle corner. rCorner x < origin x ifTrue: [^ false]. rCorner y < origin y ifTrue: [^ false]. rOrigin x > corner x ifTrue: [^ false]. rOrigin y > corner y ifTrue: [^ false]. ^ true ! ! !Rectangle methodsFor: 'truncation and round off' stamp: 'jm 5/29/1998 15:53'! truncated "Answer a Rectangle whose origin and corner have any fractional parts removed. Answer the receiver if its coordinates are already integral." (origin x isInteger and: [origin y isInteger and: [corner x isInteger and: [corner y isInteger]]]) ifTrue: [^ self]. ^ Rectangle origin: origin truncated corner: corner truncated ! ! I am a simple rectangle with a border. ! !RectangleMorph methodsFor: 'initialization' stamp: 'jm 10/9/2002 06:06'! initialize super initialize. color _ Color gray. ! ! !RectangleMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:02'! includeInNewMorphMenu ^ true ! ! !RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:28'! setSourcePointer: aSourcePointer sourceFileNumber _ SourceFiles fileIndexFromSourcePointer: aSourcePointer. filePositionHi _ SourceFiles filePositionFromSourcePointer: aSourcePointer! ! !RemoteString methodsFor: 'accessing' stamp: 'hmm 4/26/2000 20:47'! sourcePointer sourceFileNumber ifNil: [^ 0]. ^SourceFiles sourcePointerFromFileIndex: sourceFileNumber andPosition: filePositionHi! ! !RepeatingSound methodsFor: 'sound generation' stamp: 'jm 6/30/1998 18:28'! reset super reset. sound reset. samplesPerIteration _ sound samplesRemaining. iterationCount == #forever ifTrue: [iteration _ 1] ifFalse: [iteration _ iterationCount]. ! ! !RepeatingSound methodsFor: 'sound generation' stamp: 'jm 1/18/1999 10:31'! samplesRemaining iterationCount == #forever ifTrue: [^ 1000000]. iteration > 0 ifTrue: [^ sound samplesRemaining + ((iteration - 1) * samplesPerIteration)] ifFalse: [^ 0]. ! ! !RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 10:01'! carMotorSound "Return a repeating sound for the sound of a car engine." "RepeatingSound carMotorSound play" ^ self carMotorSound: 10.0! ! !RepeatingSound class methodsFor: 'car motor example' stamp: 'jm 1/29/1999 09:32'! carMotorSound: speed "Return a repeating sound for the sound of a car engine running at the given speed." "(RepeatingSound carMotorSound: 2.0) play" CarMotorSamples ifNil: [self initializeCarMotor]. ^ RepeatingSound repeatForever: ((LoopedSampledSound unloopedSamples: CarMotorSamples pitch: 20.0 samplingRate: 22050) setPitch: speed dur: 100.0 loudness: 1.0) ! ! !RestSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:07'! duration "Answer the duration of this sound in seconds." ^ initialCount asFloat / self samplingRate ! ! !RestSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:42'! duration: seconds super duration: seconds. count _ initialCount _ (seconds * self samplingRate) rounded. ! ! !RestSound methodsFor: 'accessing' stamp: 'jm 4/20/2003 20:13'! gain ^ 1.0 ! ! !RestSound methodsFor: 'accessing' stamp: 'di 2/17/1999 21:09'! samples ^ SoundBuffer newMonoSampleCount: initialCount! ! !RestSound class methodsFor: 'instance creation' stamp: 'jm 3/31/1999 21:05'! dur: d "Return a rest of the given duration." ^ self new setDur: d ! ! I represent an expression of the form ^expr.! !ReturnNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:51'! asTranslatorNode ^ TReturnNode new setExpression: expr asTranslatorNode ! ! I'm a translucent rectangle that displays its current width and height. I'm useful as a way to measure the size of objects on the screen. ! !RulerMorph methodsFor: 'drawing' stamp: 'jm 6/15/2003 12:03'! initialize super initialize. self color: ((Color r: 0.8 g: 1.0 b: 1.0) alpha: 0.3). self borderWidth: 1. ! ! !RulerMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:07'! includeInNewMorphMenu ^ true ! ! !RunArray methodsFor: 'accessing' stamp: 'di 1/15/1999 00:04'! = otherArray "Test if all my elements are equal to those of otherArray" (otherArray isMemberOf: RunArray) ifFalse: [^ self hasEqualElements: otherArray]. "Faster test between two RunArrays" ^ (runs hasEqualElements: otherArray runs) and: [values hasEqualElements: otherArray values]! ! !RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:16'! addFirst: value "Add value as the first element of the receiver." lastIndex _ nil. "flush access cache" (runs size=0 or: [values first ~= value]) ifTrue: [runs addFirst: 1. values addFirst: value] ifFalse: [runs at: 1 put: runs first+1]! ! !RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'! addLast: value "Add value as the last element of the receiver." lastIndex _ nil. "flush access cache" (runs size=0 or: [values last ~= value]) ifTrue: [runs addLast: 1. values addLast: value] ifFalse: [runs at: runs size put: runs last+1]! ! !RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'! addLast: value times: times "Add value as the last element of the receiver, the given number of times" times = 0 ifTrue: [ ^self ]. lastIndex _ nil. "flush access cache" (runs size=0 or: [values last ~= value]) ifTrue: [runs add: times. values add: value] ifFalse: [runs at: runs size put: runs last+times]! ! !RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'! repeatLast: times ifEmpty: defaultBlock "add the last value back again, the given number of times. If we are empty, add (defaultBlock value)" times = 0 ifTrue: [^self ]. lastIndex _ nil. "flush access cache" (runs size=0) ifTrue: [runs addLast: times. values addLast: defaultBlock value] ifFalse: [runs at: runs size put: runs last+times] ! ! !RunArray methodsFor: 'adding' stamp: 'ls 8/20/1998 10:18'! repeatLastIfEmpty: defaultBlock "add the last value back again. If we are empty, add (defaultBlock value)" lastIndex _ nil. "flush access cache" (runs size=0) ifTrue:[ runs addLast: 1. values addLast: defaultBlock value] ifFalse: [runs at: runs size put: runs last+1]! ! !RunArray methodsFor: 'copying' stamp: 'ls 10/10/1999 13:15'! copyFrom: start to: stop | newRuns run1 run2 offset1 offset2 | stop < start ifTrue: [^RunArray new]. self at: start setRunOffsetAndValue: [:r :o :value1 | run1 _ r. offset1 _ o. value1]. self at: stop setRunOffsetAndValue: [:r :o :value2 | run2 _ r. offset2 _ o. value2]. run1 = run2 ifTrue: [newRuns _ Array with: offset2 - offset1 + 1] ifFalse: [newRuns _ runs copyFrom: run1 to: run2. newRuns at: 1 put: (newRuns at: 1) - offset1. newRuns at: newRuns size put: offset2 + 1]. ^RunArray runs: newRuns values: (values copyFrom: run1 to: run2)! ! !RunArray methodsFor: 'printing' stamp: 'sma 6/1/2000 09:47'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' runs: '; print: runs; nextPutAll: ' values: '; print: values! ! !RunArray methodsFor: 'enumerating' stamp: 'ar 12/27/1999 13:43'! runsAndValuesDo: aBlock "Evaluate aBlock with run lengths and values from the receiver" ^runs with: values do: aBlock.! ! !RunArray class methodsFor: 'instance creation' stamp: 'ls 8/20/1998 10:12'! new ^self runs: OrderedCollection new values: OrderedCollection new! ! !RunArray class methodsFor: 'instance creation' stamp: 'ls 8/20/1998 10:12'! new: size withAll: value "Answer a new instance of me, whose every element is equal to the argument, value." size = 0 ifTrue: [^self new]. ^self runs: (OrderedCollection with: size) values: (OrderedCollection with: value)! ! !RunArray class methodsFor: 'instance creation' stamp: 'tk 1/13/1999 08:28'! scanFrom: strm "Read the style section of a fileOut or sources file. nextChunk has already been done. We need to return a RunArray of TextAttributes of various kinds." | rr vv aa this | (strm peekFor: $( ) ifFalse: [^ nil]. rr _ OrderedCollection new. [strm skipSeparators. strm peekFor: $)] whileFalse: [rr add: (Number readFrom: strm)]. vv _ OrderedCollection new. "Value array" aa _ OrderedCollection new. "Attributes list" [(this _ strm next) == nil] whileFalse: [ this == $, ifTrue: [vv add: aa asArray. aa _ OrderedCollection new]. this == $f ifTrue: [aa add: (TextFontChange new fontNumber: (Number readFrom: strm))]. this == $b ifTrue: [aa add: (TextEmphasis bold)]. this == $i ifTrue: [aa add: (TextEmphasis italic)]. this == $u ifTrue: [aa add: (TextEmphasis underlined)]. this == $= ifTrue: [aa add: (TextEmphasis struckOut)]. this == $n ifTrue: [aa add: (TextEmphasis normal)]. this == $- ifTrue: [aa add: (TextKern kern: -1)]. this == $+ ifTrue: [aa add: (TextKern kern: 1)]. this == $c ifTrue: [aa add: (TextColor scanFrom: strm)]. "color" this == $L ifTrue: [aa add: (TextLink scanFrom: strm)]. "L not look like 1" this == $R ifTrue: [aa add: (TextURL scanFrom: strm)]. "R capitalized so it can follow a number" this == $q ifTrue: [aa add: (TextSqkPageLink scanFrom: strm)]. this == $d ifTrue: [aa add: (TextDoIt scanFrom: strm)]. "space, cr do nothing" ]. aa size > 0 ifTrue: [vv add: aa asArray]. ^ self runs: rr asArray values: vv asArray " RunArray scanFrom: (ReadStream on: '(14 50 312)f1,f1b,f1LInteger +;i') "! ! This class implements the SMTP (mail sending) protocol specified in RFC 821. Note that it does not look up DNS MX records when sending to the specified host, so it will not work correctly to send directly to large structured domain names like "intel.com" or "microsoft.com", but it will work fine for talking with your local mail server which will then pass along the mail to the real destination. Note also that the error reporting is done with error: and so an exception handler must be wrapped around the sending call in case it fails.! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'jm 10/14/1998 12:52'! connectToSMTPServer: serverName "connect to the given server on the SMTP port" | addr | Socket initializeNetwork. addr _ NetNameResolver addressForName: serverName. addr ifNil: [self error: 'Could not find host address']. Transcript show: 'connecting to ', serverName, '...'. self connectTo: addr port: 25. self waitForConnectionUntil: Socket standardDeadline. self isConnected ifFalse: [ ^false ]. self checkSMTPResponse. self sendCommand: 'HELO aSqueakSystem'. self checkSMTPResponse. ^true! ! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'jm 5/24/2003 13:36'! data: messageData "send the data of a message" | cookedLine | "inform the server we are sending the message data" self sendCommand: 'DATA'. self checkSMTPResponse. "process the data one line at a time" messageData lines do: [ :messageLine | cookedLine _ messageLine. (cookedLine beginsWith: '.') ifTrue: [ "lines beginning with a dot must have the dot doubled" cookedLine _ '.', cookedLine ]. self sendCommand: cookedLine ]. "inform the server the entire message text has arrived" self sendCommand: '.'. self checkSMTPResponse.! ! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:13'! getSMTPResponse "wait for an SMTP response, and return the number of the response" | line | [ line _ self getResponse. Transcript show: line. (line at: 4) = $- ] whileTrue. ^(line copyFrom: 1 to: 3) asNumber! ! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:21'! mailFrom: fromAddress self sendCommand: 'MAIL FROM: <', fromAddress, '>'. self checkSMTPResponse.! ! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:31'! quit "send a QUIT command. This is polite to do, and indeed some servers might drop messages that don't have an associated QUIT" self sendCommand: 'QUIT'. self checkSMTPResponse.! ! !SMTPSocket methodsFor: 'low-level protocol' stamp: 'ls 9/10/1998 22:20'! recipient: aRecipient "specify a recipient for the message. aRecipient should be a bare email address" self sendCommand: 'RCPT TO: <', aRecipient, '>'. self checkSMTPResponse.! ! !SMTPSocket methodsFor: 'private' stamp: 'ls 9/10/1998 22:37'! checkSMTPResponse "get an SMTP response, and check that it's in the 200's or 300's. If it's not, close the socket and issue an error:" (#(2 3) includes: self getSMTPResponse // 100) ifFalse: [ self close. self error: 'server responded with an error' ].! ! !SMTPSocket methodsFor: 'public protocol' stamp: 'mdr 10/12/1998 14:41'! mailFrom: sender to: recipientList text: messageText "deliver this mail to a list of users. NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" self mailFrom: sender. recipientList do: [ :recipient | self recipient: recipient ]. self data: messageText. ! ! !SMTPSocket class methodsFor: 'sending mail' stamp: 'mdr 1/28/1999 16:42'! deliverMailFrom: fromAddress to: recipientList text: messageText usingServer: serverName "Deliver a single email to a list of users and then close the connection. For delivering multiple messages, it is best to create a single connection and send all mail over it. NOTE: the recipient list should be a collection of simple internet style addresses -- no '<>' or '()' stuff" | sock | sock _ self usingServer: serverName. sock mailFrom: fromAddress to: recipientList text: messageText. sock quit. sock close. ^true ! ! !SMTPSocket class methodsFor: 'examples' stamp: 'ls 9/10/1998 22:40'! example "SMTPSocket example" "send a message over SMTP" self deliverMailFrom: 'lex@cc.gatech.edu' to: #(root src) text: 'From: test To: "not listed" Subject: this is a test Hello from Squeak!! ' usingServer: 'localhost'. ! ! !SMTPSocket class methodsFor: 'examples' stamp: 'ls 9/10/1998 22:36'! example2 "SMTPSocket example2" "send a message using the low-level protocol methods. Normally one would just use the high-level class message" | sock | sock _ self new. sock connectToSMTPServer: 'localhost'. sock mailFrom: 'lex@cc.gatech.edu'. sock recipient: 'lex@localhost'. sock recipient: 'root'. sock data: 'From: test To: "not listed" Subject: this is a test Hi, this is a test message. '. sock quit. sock close.! ! !SMTPSocket class methodsFor: 'instance creation' stamp: 'mdr 1/29/1999 18:59'! usingServer: serverName "Create a SMTP socket to the specified server for sending one or more mail messages" | sock | Socket initializeNetwork. sock _ self new. sock connectToSMTPServer: serverName. ^sock! ! I represent a collection of individual notes at different pitches, volumes, and articulations. On request, I can select the best note to use for a given pitch, duration, and volume. I currently only support two volumes, loud and soft, and two articulations, normal and staccato, but I can easily be extended to include more. The main barrier to keeping more variations is simply the memory space (assuming my component notes are sampled sounds). ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 4/20/2003 19:53'! allKeyMaps: keyMap sustainedSoft _ keyMap. sustainedLoud _ keyMap. staccatoSoft _ keyMap. staccatoLoud _ keyMap. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 17:30'! allSampleSets: sortedNotes | keyMap | keyMap _ self midiKeyMapFor: sortedNotes. sustainedSoft _ keyMap. sustainedLoud _ keyMap. staccatoSoft _ keyMap. staccatoLoud _ keyMap. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/3/1998 19:04'! initialize sustainedThreshold _ 0.15. loudThreshold _ 0.5. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'! loudThreshold ^ loudThreshold ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'! loudThreshold: aNumber loudThreshold _ aNumber asFloat. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 10:02'! staccatoLoudAndSoftSampleSet: sortedNotes staccatoLoud _ self midiKeyMapFor: sortedNotes. staccatoSoft _ staccatoLoud. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! staccatoLoudSampleSet: sortedNotes staccatoLoud _ self midiKeyMapFor: sortedNotes. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! staccatoSoftSampleSet: sortedNotes staccatoSoft _ self midiKeyMapFor: sortedNotes. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! sustainedLoudSampleSet: sortedNotes sustainedLoud _ self midiKeyMapFor: sortedNotes. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/2/1998 09:54'! sustainedSoftSampleSet: sortedNotes sustainedSoft _ self midiKeyMapFor: sortedNotes. ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:21'! sustainedThreshold ^ sustainedThreshold ! ! !SampledInstrument methodsFor: 'accessing' stamp: 'jm 8/4/1998 23:22'! sustainedThreshold: aNumber sustainedThreshold _ aNumber asFloat. ! ! !SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 18:53'! soundForMidiKey: midiKey dur: d loudness: l "Answer an initialized sound object that generates a note for the given MIDI key (in the range 0..127), duration (in seconds), and loudness (in the range 0.0 to 1.0)." | keymap note | l >= loudThreshold ifTrue: [ d >= sustainedThreshold ifTrue: [keymap _ sustainedLoud] ifFalse: [keymap _ staccatoLoud]] ifFalse: [ d >= sustainedThreshold ifTrue: [keymap _ sustainedSoft] ifFalse: [keymap _ staccatoSoft]]. keymap ifNil: [keymap _ sustainedLoud]. note _ (keymap at: midiKey) copy. ^ note setPitch: (AbstractSound pitchForMIDIKey: midiKey) dur: d loudness: (l * note gain) ! ! !SampledInstrument methodsFor: 'playing' stamp: 'jm 8/3/1998 16:53'! soundForPitch: pitchNameOrNumber dur: d loudness: l "Answer an initialized sound object that generates a note of the given pitch, duration, and loudness. Pitch may be a numeric pitch or a string pitch name such as 'c4'. Duration is in seconds and loudness is in the range 0.0 to 1.0." "Note: Generally, SampledInstruments are expected to be played via MIDI key numbers rather than by pitches, since finding the MIDI key for a given pitch is expensive." ^ self soundForMidiKey: (AbstractSound midiKeyForPitch: pitchNameOrNumber) dur: d loudness: l ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 12:39'! allNotes "Answer a collection containing of all the unique sampled sounds used by this instrument." | r | r _ IdentitySet new. r addAll: sustainedLoud. sustainedSoft ~~ sustainedLoud ifTrue: [r addAll: sustainedSoft]. staccatoLoud ~~ sustainedLoud ifTrue: [r addAll: staccatoLoud]. staccatoSoft ~~ staccatoLoud ifTrue: [r addAll: staccatoSoft]. ^ (r asSortedCollection: [:n1 :n2 | n1 pitch < n2 pitch]) asArray ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/2/1998 12:55'! chooseSamplesForPitch: pitchInHz from: sortedNotes "From the given collection of LoopedSampledSounds, choose the best one to be pitch-shifted to produce the given pitch." "Assume: the given collection is sorted in ascending pitch order." | i lower higher | i _ 1. [(i < sortedNotes size) and: [(sortedNotes at: i) pitch < pitchInHz]] whileTrue: [i _ i + 1]. i = 1 ifTrue: [^ sortedNotes at: 1]. lower _ sortedNotes at: i - 1. higher _ sortedNotes at: i. "note: give slight preference for down-shifting a higher-pitched sample set" (pitchInHz / lower pitch) < ((0.95 * higher pitch) / pitchInHz) ifTrue: [^ lower] ifFalse: [^ higher]. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 9/8/1998 16:24'! memorySpace "Answer the number of bytes required to store the samples for this instrument." | total | total _ 0. self allNotes do: [:n | total _ total + (n leftSamples monoSampleCount * 2). n isStereo ifTrue: [total _ total + (n leftSamples monoSampleCount * 2)]]. ^ total ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/3/1998 16:42'! midiKeyMapFor: sortedNotes "Return a 128 element array that maps each MIDI key number to the sampled note from the given set with the closests pitch. A precise match isn't necessary because the selected note will be pitch shifted to play at the correct pitch." ^ (0 to: 127) collect: [:k | self chooseSamplesForPitch: (AbstractSound pitchForMIDIKey: k) from: sortedNotes]. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/18/1998 10:57'! playChromaticRunFrom: startPitch to: endPitch (AbstractSound chromaticRunFrom: startPitch to: endPitch on: self) play. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 15:52'! pruneNoteList: aNoteList notesPerOctave: notesPerOctave "Return a pruned version of the given note list with only the given number of notes per octave. Assume the given notelist is in sorted order." | r interval lastPitch | r _ OrderedCollection new: aNoteList size. interval _ (2.0 raisedTo: (1.0 / notesPerOctave)) * 0.995. lastPitch _ 0.0. aNoteList do: [:n | n pitch > (lastPitch * interval) ifTrue: [ r addLast: n. lastPitch _ n pitch]]. ^ r ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/6/1998 00:39'! pruneToNotesPerOctave: notesPerOctave "Prune all my keymaps to the given number of notes per octave." sustainedLoud _ self midiKeyMapFor: (self pruneNoteList: sustainedLoud notesPerOctave: notesPerOctave). sustainedSoft _ self midiKeyMapFor: (self pruneNoteList: sustainedSoft notesPerOctave: notesPerOctave). staccatoLoud _ self midiKeyMapFor: (self pruneNoteList: staccatoLoud notesPerOctave: notesPerOctave). staccatoSoft _ self midiKeyMapFor: (self pruneNoteList: staccatoSoft notesPerOctave: notesPerOctave). ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/11/1998 14:44'! pruneToSingleNote: aNote "Fill all my keymaps with the given note." | oneNoteMap | oneNoteMap _ Array new: 128 withAll: aNote. sustainedLoud _ oneNoteMap. sustainedSoft _ oneNoteMap. staccatoLoud _ oneNoteMap. staccatoSoft _ oneNoteMap. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/4/1998 18:22'! readSampleSetFrom: dirName "Answer a collection of sounds read from AIFF files in the given directory and sorted in ascending pitch order." | all dir fullName snd | all _ SortedCollection sortBlock: [:s1 :s2 | s1 pitch < s2 pitch]. dir _ FileDirectory default on: dirName. dir fileNames do: [:n | fullName _ dir fullNameFor: n. Utilities informUser: 'Reading AIFF file ', n during: [snd _ LoopedSampledSound new fromAIFFFileNamed: fullName mergeIfStereo: true]. all add: snd]. ^ all asArray ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/2/1998 20:32'! readSampleSetInfoFrom: dirName "MessageTally spyOn: [SampledInstrument new readSampleSetFrom: 'Tosh:Desktop Folder:AAA Squeak2.0 Beta:Organ Samples:Flute8'] timeToRun" | all dir fullName info | all _ OrderedCollection new. dir _ FileDirectory default on: dirName. dir fileNames do: [:n | fullName _ dir fullNameFor: n. info _ AIFFFileReader new readFromFile: fullName mergeIfStereo: false skipDataChunk: true. all add: n -> info]. ^ all ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/4/1998 23:13'! testAtPitch: aPitch "SampledInstrument testAtPitch: 'c4'" | pattern | pattern _ (#( (c4 0.64 100) (c4 0.64 200) (c4 0.64 400) (c4 0.64 600) (c4 0.64 800) (c4 1.28 1000) (c4 1.28 400) (c4 0.32 500) (c4 0.32 500) (c4 0.32 500) (c4 0.32 500) (c4 0.16 500) (c4 0.16 500) (c4 0.16 500) (c4 0.16 500) (c4 0.16 500) (c4 0.08 500) (c4 0.08 500) (c4 0.16 500) (c4 0.08 500) (c4 0.08 500) (c4 0.64 500)) collect: [:triple | triple copy at: 1 put: aPitch; yourself]). (AbstractSound noteSequenceOn: self from: pattern) play. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 15:16'! trimAttackOf: sampleBuffer threshold: threshold "Trim 'silence' off the initial attacks of the given sound buffer." (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd | snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold). snd isStereo ifTrue: [ snd rightSamples: (self trimAttackOf: snd rightSamples threshold: threshold)]]. ! ! !SampledInstrument methodsFor: 'other' stamp: 'jm 8/5/1998 11:07'! trimAttacks: threshold "Trim 'silence' off the initial attacks all my samples." (sustainedSoft, sustainedLoud, staccatoSoft, staccatoLoud) do: [:snd | snd leftSamples: (self trimAttackOf: snd leftSamples threshold: threshold). snd isStereo ifTrue: [ snd rightSamples: (self trimAttackOf: snd rightSamples threshold: threshold)]]. ! ! !SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 6/7/1999 11:26'! buildSmallOrchestra "Example of how to build a skeleton orchestra that uses less memory (about 14 MBytes)." "SampledInstrument buildSmallOrchestra" | dir | AbstractSound unloadSampledTimbres. dir _ 'Tosh:Not Backed Up:Sample Library:Orchestra'. #(clarinet oboe bassoon trombone tympani) do: [:instName | SampledInstrument readSimpleInstrument: instName fromDirectory: dir. (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 1]. #(flute bass) do: [:instName | SampledInstrument readSimpleInstrument: instName fromDirectory: dir. (AbstractSound soundNamed: instName, '-f') pruneToNotesPerOctave: 2]. (AbstractSound soundNamed: 'bass-f') allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 2500)]. (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped. n firstSample: (n findStartPointForThreshold: 0)]. (AbstractSound soundNamed: 'trombone-f') allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1800)]. AbstractSound soundNamed: 'trumpet-f' put: (AbstractSound soundNamed: 'trombone-f'). AbstractSound soundNamed: 'horn-f' put: (AbstractSound soundNamed: 'trombone-f'). AbstractSound soundNamed: 'violin-f' put: (AbstractSound soundNamed: 'bass-f'). AbstractSound soundNamed: 'viola-f' put: (AbstractSound soundNamed: 'bass-f'). AbstractSound soundNamed: 'cello-f' put: (AbstractSound soundNamed: 'bass-f'). (AbstractSound soundNamed: 'bassoon-f') allNotes do: [:n | n beUnlooped]. ! ! !SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/19/1998 09:29'! readLoudAndStaccatoInstrument: instName fromDirectory: orchestraDir "SampledInstrument readLoudAndStaccatoInstrument: 'oboe' fromDirectory: 'Tosh:Sample Library:Orchestra'" | sampleSetDir memBefore memAfter loud short snd | sampleSetDir _ orchestraDir, ':', instName. memBefore _ Smalltalk garbageCollect. loud _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' f'. short _ SampledInstrument new readSampleSetFrom: sampleSetDir, ' stacc'. memAfter _ Smalltalk garbageCollect. Transcript show: instName, ': ', (memBefore - memAfter) printString, ' bytes; ', memAfter printString, ' bytes left'; cr. AbstractSound soundNamed: instName, '-f&stacc' put: (snd _ SampledInstrument new allSampleSets: loud; staccatoLoudAndSoftSampleSet: short). "fix slow attacks" snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 500)]. AbstractSound soundNamed: instName, '-f' put: (snd _ SampledInstrument new allSampleSets: loud). "fix slow attacks" snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)]. ! ! !SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/19/1998 09:29'! readPizzInstrument: instName fromDirectory: orchestraDir "SampledInstrument readPizzInstrument: 'violin' fromDirectory: 'Tosh:Sample Library:Orchestra'" | sampleSetDir memBefore memAfter sampleSet snd | sampleSetDir _ orchestraDir, ':', instName, ' pizz'. memBefore _ Smalltalk garbageCollect. sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir. memAfter _ Smalltalk garbageCollect. Transcript show: instName, ': ', (memBefore - memAfter) printString, ' bytes; ', memAfter printString, ' bytes left'; cr. AbstractSound soundNamed: instName, '-pizz' put: (snd _ SampledInstrument new allSampleSets: sampleSet). "fix slow attacks" snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)]. ^ snd ! ! !SampledInstrument class methodsFor: 'instance creation' stamp: 'jm 8/17/1998 18:06'! readSimpleInstrument: instName fromDirectory: orchestraDir "SampledInstrument readSimpleInstrument: 'oboe' fromDirectory: 'Tosh:Sample Library:Orchestra'" | sampleSetDir memBefore memAfter sampleSet snd | sampleSetDir _ orchestraDir, ':', instName, ' f'. memBefore _ Smalltalk garbageCollect. sampleSet _ SampledInstrument new readSampleSetFrom: sampleSetDir. memAfter _ Smalltalk garbageCollect. Transcript show: instName, ': ', (memBefore - memAfter) printString, ' bytes; ', memAfter printString, ' bytes left'; cr. AbstractSound soundNamed: instName, '-f' put: (snd _ SampledInstrument new allSampleSets: sampleSet). "fix slow attacks" snd allNotes do: [:n | n firstSample: (n findStartPointForThreshold: 1000)]. ^ snd ! ! !SampledSound methodsFor: 'initialization' stamp: 'jm 1/18/1999 06:42'! pitch: pitchNameOrNumber | p | p _ self nameOrNumberToPitch: pitchNameOrNumber. originalSamplingRate _ ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger. self reset. ! ! !SampledSound methodsFor: 'initialization' stamp: 'jm 9/27/2003 12:23'! setPitch: pitchNameOrNumber dur: d loudness: vol "Used to play scores using the default sample table." "(SampledSound pitch: 880.0 dur: 1.5 loudness: 0.6) play" | p | super setPitch: pitchNameOrNumber dur: d loudness: vol. p _ self nameOrNumberToPitch: pitchNameOrNumber. "samples _ DefaultSampleTable." samplesSize _ samples size. initialCount _ (d * self samplingRate asFloat) rounded. originalSamplingRate _ ((self samplingRate asFloat * p asFloat) / NominalSamplePitch asFloat) asInteger. self loudness: vol. self reset. ! ! !SampledSound methodsFor: 'initialization' stamp: 'jm 7/20/2003 22:26'! setSamples: anArray from: startIndex to: endIndex samplingRate: rate loudness: loudness "Initialize me to play the given range of the given array at the given sampling rate." | buf | anArray class isWords ifFalse: [ "convert the subarray into a SoundBuffer" buf _ SoundBuffer fromArray: (anArray copyFrom: startIndex to: endIndex). ^ self setSamples: buf samplingRate: rate]. anArray class isWords ifTrue: [samples _ anArray] ifFalse: [samples _ SoundBuffer fromArray: anArray]. samplesSize _ samples size. originalSamplingRate _ rate. self loudness: loudness. initialCount _ ((endIndex - (startIndex - 1)) * SoundPlayer samplingRate) // rate. scaledInitialIndex _ startIndex * IncrementScaleFactor. "scaled index of the first sample to play" self reset. ! ! !SampledSound methodsFor: 'initialization' stamp: 'jm 7/9/1999 19:23'! setSamples: anArray samplingRate: rate "Set my samples array to the given array with the given nominal sampling rate. Altering the rate parameter allows the sampled sound to be played back at different pitches." "Note: There are two ways to use sampled sound: (a) you can play them through once (supported by this method) or (b) you can make them the default waveform with which to play a musical score (supported by the class method defaultSampleTable:)." "Assume: anArray is either a SoundBuffer or a collection of signed 16-bit sample values." "(SampledSound samples: SampledSound coffeeCupClink samplingRate: 5000) play" "copy the array into a SoundBuffer if necessary" anArray class isWords ifTrue: [samples _ anArray] ifFalse: [samples _ SoundBuffer fromArray: anArray]. samplesSize _ samples size. samplesSize >= SmallInteger maxVal ifTrue: [ "this is unlikely..." self error: 'sample count must be under ', SmallInteger maxVal printString]. originalSamplingRate _ rate. initialCount _ (samplesSize * self samplingRate) // originalSamplingRate. self loudness: 1.0. self reset. ! ! !SampledSound methodsFor: 'accessing' stamp: 'jm 8/23/2003 18:51'! currentPosition "Answer the current position of the playback head in seconds since the start of this sound (at the original sampling)." | sampleIndex | sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits). ^ sampleIndex asFloat / originalSamplingRate ! ! !SampledSound methodsFor: 'accessing' stamp: 'jm 9/11/1998 15:39'! duration: seconds super duration: seconds. count _ initialCount _ (seconds * self samplingRate) rounded. ! ! !SampledSound methodsFor: 'accessing' stamp: 'jm 8/23/2003 18:12'! playbackRate "Answer the playback rate." ^ (scaledIncrement * self samplingRate) asFloat / (originalSamplingRate * IncrementScaleFactor) ! ! !SampledSound methodsFor: 'accessing' stamp: 'jm 8/23/2003 18:15'! playbackRate: aNumber "Set the playback rate." | rate | rate _ aNumber asFloat max: 0.01. scaledIncrement _ ((rate * originalSamplingRate * IncrementScaleFactor) / self samplingRate) rounded. ! ! !SampledSound methodsFor: 'playing' stamp: 'jm 7/9/1999 22:33'! 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." | lastIndex outIndex sampleIndex sample i s overflow | <primitive: 185> self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'. self var: #samples declareC: 'short int *samples'. lastIndex _ (startIndex + n) - 1. outIndex _ startIndex. "index of next stereo output sample pair" sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits). [(sampleIndex <= samplesSize) and: [outIndex <= lastIndex]] whileTrue: [ sample _ ((samples at: sampleIndex) * scaledVol) // ScaleFactor. leftVol > 0 ifTrue: [ i _ (2 * outIndex) - 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 * outIndex. s _ (aSoundBuffer at: i) + ((sample * rightVol) // ScaleFactor). s > 32767 ifTrue: [s _ 32767]. "clipping!!" s < -32767 ifTrue: [s _ -32767]. "clipping!!" aSoundBuffer at: i put: s]. 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]]. scaledIndex _ scaledIndex + scaledIncrement. scaledIndex >= ScaledIndexOverflow ifTrue: [ overflow _ scaledIndex >> IncrementFractionBits. indexHighBits _ indexHighBits + overflow. scaledIndex _ scaledIndex - (overflow << IncrementFractionBits)]. sampleIndex _ indexHighBits + (scaledIndex >> IncrementFractionBits). outIndex _ outIndex + 1]. count _ count - n. ! ! !SampledSound methodsFor: 'playing' stamp: 'jm 7/15/2003 12:29'! reset "Details: The sample index and increment are scaled to allow fractional increments without having to do floating point arithmetic in the inner loop." super reset. scaledIncrement _ ((originalSamplingRate asFloat / self samplingRate) * IncrementScaleFactor) rounded. count _ initialCount. scaledIndex _ IncrementScaleFactor. "index of the first sample, scaled" scaledInitialIndex ifNotNil: [scaledIndex _ scaledInitialIndex]. indexHighBits _ 0. ! ! !SampledSound methodsFor: 'playing' stamp: 'jm 9/9/1998 21:58'! stopAfterMSecs: mSecs "Terminate this sound this note after the given number of milliseconds." count _ (mSecs * self samplingRate) // 1000. ! ! !SampledSound methodsFor: 'file i/o' stamp: 'jm 12/16/2001 21:13'! storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream "Store my samples on the given stream at the current SoundPlayer sampling rate. If bigFlag is true, then each 16-bit sample is stored most-significant byte first (AIFF files), otherwise it is stored least-significant byte first (WAV files)." | reverseBytes | self samplingRate ~= originalSamplingRate ifTrue: [ ^ super storeSampleCount: samplesToStore bigEndian: bigEndianFlag on: aBinaryStream]. "optimization: if sampling rates match, just store my buffer" reverseBytes _ bigEndianFlag ~= (Smalltalk endianness = #big). reverseBytes ifTrue: [samples reverseEndianness]. (aBinaryStream isKindOf: StandardFileStream) ifTrue: [ "optimization for files: write sound buffer directly to file" aBinaryStream next: (samples size // 2) putAll: samples startingAt: 1] "size in words" ifFalse: [ "for non-file streams:" 1 to: samples monoSampleCount do: [:i | aBinaryStream int16: (samples at: i)]]. reverseBytes ifTrue: [samples reverseEndianness]. "restore to original endianness" ! ! !SampledSound class methodsFor: 'class initialization' stamp: 'jm 7/9/1999 19:07'! initialize "SampledSound initialize" IncrementFractionBits _ 16. IncrementScaleFactor _ 2 raisedTo: IncrementFractionBits. ScaledIndexOverflow _ 2 raisedTo: 29. "handle overflow before needing LargePositiveIntegers" self useCoffeeCupClink. SoundLibrary ifNil: [SoundLibrary _ Dictionary new]. ! ! !SampledSound class methodsFor: 'instance creation' stamp: 'jm 1/14/1999 10:34'! fromAIFFfileNamed: fileName "Read a SampledSound from the AIFF file of the given name, merging stereo to mono if necessary." "(SampledSound fromAIFFfileNamed: '1.aif') play" "| snd | FileDirectory default fileNames do: [:n | (n endsWith: '.aif') ifTrue: [ snd _ SampledSound fromAIFFfileNamed: n. snd play. SoundPlayer waitUntilDonePlaying: snd]]." | aiffFileReader | aiffFileReader _ AIFFFileReader new. aiffFileReader readFromFile: fileName mergeIfStereo: true skipDataChunk: false. ^ self samples: (aiffFileReader channelData at: 1) samplingRate: aiffFileReader samplingRate ! ! !SampledSound class methodsFor: 'instance creation' stamp: 'LY 6/30/2003 18:28'! fromWaveFileNamed: fileName "(SampledSound fromWaveFileNamed: 'c:\windows\media\chimes.wav') play" "| snd fd | fd := FileDirectory on:'c:\windows\media\'. fd fileNames do: [:n | (n asLowercase endsWith: '.wav') ifTrue: [ snd _ SampledSound fromWaveFileNamed: (fd pathName,n). snd play. SoundPlayer waitUntilDonePlaying: snd]]." | stream header data type channels samplingRate blockAlign bitsPerSample leftAndRight | stream _ FileStream readOnlyFileNamed: fileName. header _ self readWaveChunk: 'fmt ' inRIFF: stream. data _ self readWaveChunk: 'data' inRIFF: stream. stream close. stream _ ReadStream on: header. type _ self next16BitWord: false from: stream. type = 1 ifFalse: [^ self error:'Unexpected wave format']. channels _ self next16BitWord: false from: stream. (channels < 1 or: [channels > 2]) ifTrue: [^ self error: 'Unexpected number of wave channels']. samplingRate _ self next32BitWord: false from: stream. stream skip: 4. "skip average bytes per second" blockAlign _ self next16BitWord: false from: stream. bitsPerSample _ self next16BitWord: false from: stream. (bitsPerSample = 8 or: [bitsPerSample = 16]) ifFalse: [ "recompute bits per sample" bitsPerSample _ (blockAlign // channels) * 8]. bitsPerSample = 8 ifTrue: [data _ self convert8bitUnsignedTo16Bit: data] ifFalse: [data _ self convertBytesTo16BitSamples: data mostSignificantByteFirst: false]. channels = 2 ifTrue: [ leftAndRight _ data splitStereo. ^ MixedSound new add: (self samples: leftAndRight first samplingRate: samplingRate) pan: 0.0; add: (self samples: leftAndRight last samplingRate: samplingRate) pan: 1.0; yourself]. ^ self samples: data samplingRate: samplingRate ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:59'! addLibrarySoundNamed: aString fromAIFFfileNamed: fileName "Add a sound from the given AIFF file to the library." "SampledSound addLibrarySoundNamed: 'shutterClick' fromAIFFfileNamed: '7.aif'" "Add all .aif files in the current directory to the sound library: | fileNames | fileNames _ FileDirectory default fileNamesMatching: '*.aif'. fileNames do: [:fName | SampledSound addLibrarySoundNamed: (fName copyUpTo: $.) fromAIFFfileNamed: fName]" | snd | snd _ self fromAIFFfileNamed: fileName. self addLibrarySoundNamed: aString samples: snd samples samplingRate: snd originalSamplingRate. ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:41'! addLibrarySoundNamed: aString samples: sampleData samplingRate: samplesPerSecond "Add the given sound to the sound library. The sample data may be either a ByteArray or a SoundBuffer. If the former, it is take to be 8-bit unsigned samples. If the latter, it is taken to be 16 bit signed samples." SoundLibrary at: aString put: (Array with: sampleData with: samplesPerSecond). ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:04'! playSoundNamed: aString "Play the sound with given name. Do nothing if there is no sound of that name in the library." "SampledSound playSoundNamed: 'croak'" | snd | snd _ self soundNamed: aString. snd ifNotNil: [snd play]. ^ snd ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 10:40'! putCoffeeCupClinkInSoundLibrary "SampledSound putCoffeeCupClinkInSoundLibrary" self addLibrarySoundNamed: 'clink' samples: self coffeeCupClink samplingRate: 11025! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:06'! soundLibrary "Answer the sound library dictionary." ^ SoundLibrary ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:07'! soundNamed: aString "Answer the sound of the given name, or nil if there is no sound of that name." "(SampledSound soundNamed: 'shutterClick') play" | entry samples | entry _ SoundLibrary at: aString ifAbsent: [self inform: aString, ' not found in the Sound Library'. ^ nil]. entry ifNil: [^ nil]. samples _ entry at: 1. samples class isBytes ifTrue: [samples _ self convert8bitSignedTo16Bit: samples]. ^ self samples: samples samplingRate: (entry at: 2) ! ! !SampledSound class methodsFor: 'sound library' stamp: 'jm 1/14/1999 11:08'! soundNames "Answer a list of sound names for the sounds stored in the sound library." "| s | SampledSound soundNames asSortedCollection do: [:n | n asParagraph display. s _ SampledSound soundNamed: n. s ifNotNil: [s playAndWaitUntilDone]]" ^ SoundLibrary keys asArray ! ! I scan a string or text, picking out Smalltalk syntactic tokens. I look one character ahead. I put each token found into the instance variable, token, and its type (a Symbol) into the variable, tokenType. At the end of the input stream, I pretend to see an endless sequence of special characters called doits.! !Scanner methodsFor: 'multi-character scans' stamp: 'di 5/29/1998 12:25'! xBinary tokenType _ #binary. token _ Symbol internCharacter: self step. [(typeTable at: hereChar asciiValue) = #xBinary and: [hereChar ~= $-]] whileTrue: [token _ (token , (String with: self step)) asSymbol]! ! !Scanner methodsFor: 'multi-character scans' stamp: 'di 10/10/1999 23:43'! xLitQuote "Symbols and vectors: #(1 (4 5) 2 3) #ifTrue:ifFalse: #'abc'." | start | self step. "litQuote" self scanToken. tokenType = #leftParenthesis ifTrue: [start _ mark. self scanToken; scanLitVec. tokenType == #doIt ifTrue: [mark _ start. self offEnd: 'Unmatched parenthesis']] ifFalse: [(#(word keyword colon ) includes: tokenType) ifTrue: [self scanLitWord] ifFalse: [(tokenType==#literal) ifTrue: [(token isMemberOf: Symbol) ifTrue: "##word" [token _ token "May want to move toward ANSI here"]] ifFalse: [tokenType==#string ifTrue: [token _ token asSymbol]]]]. tokenType _ #literal " #(Pen) #Pen #'Pen' ##Pen ###Pen "! ! !Scanner class methodsFor: 'instance creation' stamp: 'jm 5/30/2003 10:21'! new ^ self basicNew initScanner ! ! !Scanner class methodsFor: 'testing' stamp: 'bf 4/27/2000 12:56'! isLiteralSymbol: aSymbol "Test whether a symbol can be stored as # followed by its characters. Symbols created internally with asSymbol may not have this property, e.g. '3' asSymbol." | i ascii type | i _ aSymbol size. i = 0 ifTrue: [^ false]. i = 1 ifTrue: [('$''"()#0123456789' includes: (aSymbol at: 1)) ifTrue: [^ false] ifFalse: [^ true]]. ascii _ (aSymbol at: 1) asciiValue. "TypeTable should have been origined at 0 rather than 1 ..." ascii = 0 ifTrue: [^ false]. type _ TypeTable at: ascii. (type == #xColon or: [type == #verticalBar]) ifTrue: [^ i = 1]. type == #xBinary ifTrue: [[i > 1] whileTrue: [ascii _ (aSymbol at: i) asciiValue. ascii = 0 ifTrue: [^ false]. (TypeTable at: ascii) == #xBinary ifFalse: [^ false]. i _ i - 1]. ^ true]. type == #xLetter ifTrue: [[i > 1] whileTrue: [ascii _ (aSymbol at: i) asciiValue. ascii = 0 ifTrue: [^ false]. type _ TypeTable at: ascii. (type == #xLetter or: [type == #xDigit or: [type == #xColon]]) ifFalse: [^ false]. i _ i - 1]. ^ true]. ^ false! ! This is a real-time player for MIDI scores (i.e., scores read from MIDI files). Score can be played using either the internal sound synthesis or an external MIDI synthesizer on platforms that support MIDI output. ! !ScorePlayer methodsFor: 'initialization' stamp: 'di 6/15/1999 11:17'! initialize super initialize. score _ MIDIScore new initialize. instruments _ Array new. overallVolume _ 0.5. leftVols _ Array new. rightVols _ Array new. muted _ Array new. rate _ 1.0. repeat _ false. durationInTicks _ 100.! ! !ScorePlayer methodsFor: 'initialization' stamp: 'di 6/15/1999 11:18'! onScore: aMIDIScore | trackCount totalVol incr curr pan | score _ aMIDIScore. trackCount _ score tracks size. durationInTicks _ score durationInTicks. instruments _ (1 to: trackCount) collect: [:i | FMSound oboe1]. leftVols _ Array new: trackCount. rightVols _ Array new: trackCount. muted _ Array new: trackCount withAll: false. rate _ 1.0. repeat _ false. tempo _ 120.0. trackCount = 0 ifTrue: [^ self]. 1 to: trackCount do: [:i | leftVols at: i put: ScaleFactor // 4. rightVols at: i put: ScaleFactor // 4]. "distribute inital panning of tracks left-to-right" totalVol _ 1.0. incr _ totalVol / (((trackCount // 2) + 1) * 2). curr _ 0. 1 to: trackCount do: [:t | t even ifTrue: [pan _ curr] ifFalse: [ curr _ curr + incr. pan _ totalVol - curr]. self panForTrack: t put: pan]. ! ! !ScorePlayer methodsFor: 'initialization' stamp: 'di 6/20/1999 00:46'! updateDuration durationInTicks _ score durationInTicks. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 19:07'! doControl super doControl. 1 to: activeSounds size do: [:i | (activeSounds at: i) first doControl]. ticksSinceStart _ ticksSinceStart + ticksClockIncr. self processAllAtTick: ticksSinceStart asInteger. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 16:58'! isDone | track | activeSounds size > 0 ifTrue: [^ false]. activeMIDINotes size > 0 ifTrue: [^ false]. 1 to: score tracks size do: [:i | track _ score tracks at: i. (trackEventIndex at: i) <= track size ifTrue: [^ false]]. ^ true ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'di 8/5/1998 23:07'! isPlaying ^ SoundPlayer isPlaying: self! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:28'! jumpToTick: startTick | | self reset. self processTempoMapAtTick: startTick. self skipNoteEventsThruTick: startTick. ticksSinceStart _ startTick. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 7/4/1998 08:21'! mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: leftVol rightVol: rightVol "Play a number of sounds concurrently. The level of each sound can be set independently for the left and right channels." | myLeftVol myRightVol someSoundIsDone pair snd trk left right | myLeftVol _ (leftVol * overallVolume) asInteger. myRightVol _ (rightVol * overallVolume) asInteger. someSoundIsDone _ false. 1 to: activeSounds size do: [:i | pair _ activeSounds at: i. snd _ pair at: 1. trk _ pair at: 2. left _ (myLeftVol * (leftVols at: trk)) // ScaleFactor. right _ (myRightVol * (rightVols at: trk)) // ScaleFactor. snd samplesRemaining > 0 ifTrue: [ snd mixSampleCount: n into: aSoundBuffer startingAt: startIndex leftVol: left rightVol: right] ifFalse: [someSoundIsDone _ true]]. someSoundIsDone ifTrue: [ activeSounds _ activeSounds select: [:p | p first samplesRemaining > 0]]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 10/30/2002 18:30'! processAllAtTick: scoreTick self processTempoMapAtTick: scoreTick. midiPort ifNil: [self processNoteEventsAtTick: scoreTick] ifNotNil: [self processMIDIEventsAtTick: scoreTick]. self isDone ifTrue: [ repeat ifTrue: [self reset] ifFalse: [done _ true]]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 9/10/1998 17:49'! processNoteEventsAtTick: scoreTick "Process note events through the given score tick using internal Squeak sound synthesis." | instr j evt snd | 1 to: score tracks size do: [:i | instr _ instruments at: i. j _ trackEventIndex at: i. [evt _ score eventForTrack: i after: j ticks: scoreTick. evt ~~ nil] whileTrue: [ (evt isNoteEvent and: [(muted at: i) not]) ifTrue: [ snd _ instr soundForMidiKey: evt midiKey dur: secsPerTick * evt duration loudness: evt velocity asFloat / 127.0. activeSounds add: (Array with: snd with: i)]. j _ j + 1. trackEventIndex at: i put: j]]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 21:04'! processTempoMapAtTick: scoreTick "Process tempo changes through the given score tick." | map tempoChanged | map _ score tempoMap. map ifNil: [^ self]. tempoChanged _ false. [(tempoMapIndex <= map size) and: [(map at: tempoMapIndex) time <= scoreTick]] whileTrue: [ tempoChanged _ true. tempoMapIndex _ tempoMapIndex + 1]. tempoChanged ifTrue: [ tempo _ (120.0 * (500000.0 / (map at: tempoMapIndex - 1) tempo)) roundTo: 0.01. self tempoOrRateChanged]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 10/30/2002 18:29'! reset super reset. tempo _ 120.0. self tempoOrRateChanged. done _ false. ticksSinceStart _ 0. "one index for each sound track, plus one for the ambient track..." trackEventIndex _ Array new: score tracks size+1 withAll: 1. tempoMapIndex _ 1. activeSounds _ OrderedCollection new. activeMIDINotes _ OrderedCollection new. overallVolume ifNil: [overallVolume _ 0.5]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:56'! skipNoteEventsThruTick: startTick "Skip note events through the given score tick using internal Squeak sound synthesis." | j evt | 1 to: score tracks size do: [:i | j _ trackEventIndex at: i. [evt _ score eventForTrack: i after: j ticks: startTick. evt == nil] whileFalse: [ evt isNoteEvent ifTrue: [ (((evt time + evt duration) > startTick) and: [(muted at: i) not]) ifTrue: [ self startNote: evt forStartTick: startTick trackIndex: i]] ifFalse: [ midiPort == nil ifFalse: [evt outputOnMidiPort: midiPort]]. j _ j + 1]. trackEventIndex at: i put: j]. ! ! !ScorePlayer methodsFor: 'sound generation' stamp: 'jm 6/16/1999 20:30'! startNote: noteEvent forStartTick: startTick trackIndex: trackIndex "Prepare a note to begin playing at the given tick. Used to start playing at an arbitrary point in the score. Handle both MIDI and built-in synthesis cases." | snd | midiPort ifNil: [ snd _ (instruments at: trackIndex) soundForMidiKey: noteEvent midiKey dur: secsPerTick * (noteEvent endTime - startTick) loudness: noteEvent velocity asFloat / 127.0. activeSounds add: (Array with: snd with: trackIndex)] ifNotNil: [ noteEvent startNoteOnMidiPort: midiPort. activeMIDINotes add: (Array with: noteEvent with: trackIndex)]. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 17:13'! closeMIDIPort "Stop using MIDI for output. Music will be played using the built-in sound synthesis." self pause. midiPort _ nil. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/24/1998 22:33'! midiPlayLoop | mSecsPerStep tStart mSecs | mSecsPerStep _ 5. [done] whileFalse: [ tStart _ Time millisecondClockValue. self processAllAtTick: ticksSinceStart asInteger. (Delay forMilliseconds: mSecsPerStep) wait. mSecs _ Time millisecondClockValue - tStart. mSecs < 0 ifTrue: [mSecs _ mSecsPerStep]. "clock wrap" ticksSinceStart _ ticksSinceStart + (mSecs asFloat / (1000.0 * secsPerTick))]. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 10/12/1998 15:56'! openMIDIPort: portNum "Open the given MIDI port. Music will be played as MIDI commands to the given MIDI port." midiPort _ SimpleMIDIPort openOnPortNumber: portNum. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 18:31'! processMIDIEventsAtTick: scoreTick "Process note events through the given score tick using MIDI." | j evt | 1 to: score tracks size do: [:i | j _ trackEventIndex at: i. [evt _ score eventForTrack: i after: j ticks: scoreTick. evt ~~ nil] whileTrue: [ evt isNoteEvent ifTrue: [ (muted at: i) ifFalse: [ evt startNoteOnMidiPort: midiPort. activeMIDINotes add: (Array with: evt with: i)]] ifFalse: [evt outputOnMidiPort: midiPort]. j _ j + 1. trackEventIndex at: i put: j]]. self turnOffActiveMIDINotesAt: scoreTick. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 20:45'! startMIDIPlaying "Start up a process to play this score via MIDI." midiPort ensureOpen. midiPlayerProcess ifNotNil: [midiPlayerProcess terminate]. midiPlayerProcess _ [self midiPlayLoop] newProcess. midiPlayerProcess priority: Processor userInterruptPriority; resume. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 20:44'! stopMIDIPlaying "Terminate the MIDI player process and turn off any active notes." midiPlayerProcess ifNotNil: [midiPlayerProcess terminate]. midiPlayerProcess _ nil. activeMIDINotes do: [:pair | pair first endNoteOnMidiPort: midiPort]. activeMIDINotes _ activeMIDINotes species new. ! ! !ScorePlayer methodsFor: 'midi output' stamp: 'jm 9/10/1998 17:48'! turnOffActiveMIDINotesAt: scoreTick "Turn off any active MIDI notes that should be turned off at the given score tick." | evt someNoteEnded | midiPort ifNil: [^ self]. someNoteEnded _ false. activeMIDINotes do: [:pair | evt _ pair first. evt endTime <= scoreTick ifTrue: [ evt endNoteOnMidiPort: midiPort. someNoteEnded _ true]]. someNoteEnded ifTrue: [ activeMIDINotes _ activeMIDINotes select: [:p | p first endTime > scoreTick]]. ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 12/16/2001 11:59'! duration "Answer the duration in seconds of my MIDI score when played at the current rate. Take tempo changes into account." | totalSecs currentTempo lastTempoChangeTick | totalSecs _ 0.0. currentTempo _ 120.0. "quarter notes per minute" lastTempoChangeTick _ 0. score tempoMap ifNotNil: [ score tempoMap do: [:tempoEvt | "accumulate time up to this tempo change event" secsPerTick _ 60.0 / (currentTempo * rate * score ticksPerQuarterNote). totalSecs _ totalSecs + (secsPerTick * (tempoEvt time - lastTempoChangeTick)). "set the new tempo" currentTempo _ (120.0 * (500000.0 / tempoEvt tempo)) roundTo: 0.01. lastTempoChangeTick _ tempoEvt time]]. "add remaining time through end of score" secsPerTick _ 60.0 / (currentTempo * rate * score ticksPerQuarterNote). totalSecs _ totalSecs + (secsPerTick * (score durationInTicks - lastTempoChangeTick)). ^ totalSecs ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'di 6/15/1999 11:37'! durationInTicks durationInTicks == nil ifTrue: [^ 1000]. ^ durationInTicks! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 12/16/2001 20:20'! isStereo ^ true ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/28/1998 22:58'! midiPort ^ midiPort ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'di 5/30/1999 12:46'! millisecondsSinceStart "Answer the approximate number of milliseconds of real time since the beginning of the score. Since this calculation uses the current tempo, which can change throughout the piece, it is safer to use ticksSinceStart for synchronization." ^ (secsPerTick * ticksSinceStart * 1000) asInteger ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/10/1998 17:25'! mutedForTrack: trackIndex put: aBoolean muted at: trackIndex put: aBoolean. aBoolean ifFalse: [^ self]. "silence any currently sounding notes for this track" activeSounds do: [:pair | pair last = trackIndex ifTrue: [activeSounds remove: pair ifAbsent: []]]. midiPort ifNotNil: [ activeMIDINotes do: [:pair | pair last = trackIndex ifTrue: [ pair first endNoteOnMidiPort: midiPort. activeMIDINotes remove: pair ifAbsent: []]]]. ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 5/30/1999 17:16'! mutedState ^ muted ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:17'! overallVolume ^ overallVolume ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 08:18'! overallVolume: aNumber "Set the overally playback volume to a value between 0.0 (off) and 1.0 (full blast)." overallVolume _ (aNumber asFloat min: 1.0) max: 0.0. ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:32'! panForTrack: i | left right fullVol pan | left _ leftVols at: i. right _ rightVols at: i. left = right ifTrue: [^ 0.5]. "centered" fullVol _ left max: right. left < fullVol ifTrue: [pan _ left asFloat / (2.0 * fullVol)] ifFalse: [pan _ 1.0 - (right asFloat / (2.0 * fullVol))]. ^ pan roundTo: 0.001 ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:58'! panForTrack: i put: aNumber "Set the left-right pan for this track to a value in the range [0.0..1.0], where 0.0 means full-left." | fullVol pan left right | fullVol _ (leftVols at: i) max: (rightVols at: i). pan _ (aNumber asFloat min: 1.0) max: 0.0. pan <= 0.5 ifTrue: [ "attenuate right channel" left _ fullVol. right _ 2.0 * pan * fullVol] ifFalse: [ "attenuate left channel" left _ 2.0 * (1.0 - pan) * fullVol. right _ fullVol]. rightVols at: i put: right asInteger. leftVols at: i put: left asInteger. ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'di 6/20/1999 00:42'! positionInScore ^ self ticksSinceStart asFloat / (self durationInTicks max: 1)! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 6/16/1999 22:50'! positionInScore: pos self isPlaying ifTrue: [^ self "ignore rude intrusion"]. ticksSinceStart _ pos * durationInTicks. done _ false. ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/22/1998 09:32'! ticksForMSecs: mSecs ^ (mSecs asFloat / (1000.0 * secsPerTick)) rounded ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 9/10/1998 20:48'! ticksSinceStart "Answer the number of score ticks that have elapsed since this piece started playing. The duration of a tick is determined by the MIDI score." ^ ticksSinceStart ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'di 6/19/1999 10:45'! ticksSinceStart: newTicks "Adjust ticks to folow, eg, piano roll autoscrolling" self isPlaying ifFalse: [ticksSinceStart _ newTicks] ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 7/4/1998 09:16'! volumeForTrack: i | vol | vol _ (leftVols at: i) max: (rightVols at: i). ^ (vol asFloat / ScaleFactor) roundTo: 0.0001 ! ! !ScorePlayer methodsFor: 'accessing' stamp: 'jm 6/30/1998 20:22'! volumeForTrack: i put: aNumber | newVol oldLeft oldRight oldFullVol left right | newVol _ ((aNumber asFloat max: 0.0) min: 1.0) * ScaleFactor. oldLeft _ leftVols at: i. oldRight _ rightVols at: i. oldFullVol _ oldLeft max: oldRight. oldFullVol = 0 ifTrue: [oldFullVol _ 1.0]. oldLeft < oldFullVol ifTrue: [ left _ newVol * oldLeft / oldFullVol. right _ newVol] ifFalse: [ left _ newVol. right _ newVol * oldRight / oldFullVol]. leftVols at: i put: left asInteger. rightVols at: i put: right asInteger. ! ! !ScorePlayer methodsFor: 'operating' stamp: 'jm 10/30/2002 18:29'! pause "Pause this sound. It can be resumed from this point, or reset and resumed to start from the beginning." super pause. activeSounds _ activeSounds species new. midiPort ifNotNil: [self stopMIDIPlaying]. ! ! !ScorePlayer methodsFor: 'operating' stamp: 'jm 10/30/2002 18:28'! resumePlaying "Resume playing. Start over if done." done ifTrue: [self reset]. self jumpToTick: ticksSinceStart. "Play up to here in case we got scrolled to new position." midiPort ifNil: [super resumePlaying] "let the sound player drive sound generation" ifNotNil: [self startMIDIPlaying]. "start a process to drive MIDI output" ! ! !ScorePlayer methodsFor: 'operating' stamp: 'jm 9/10/1998 20:56'! tempoOrRateChanged "This method should be called after changing the tempo or rate." secsPerTick _ 60.0 / (tempo * rate * score ticksPerQuarterNote). ticksClockIncr _ (1.0 / self controlRate) / secsPerTick. ! ! A ScorePlayerMorph mediates between a score such as a MIDIScore, a PianoRollScoreMorph, and the actual SoundPlayer synthesizer. It provides control over volume, tempo, instrumentation, and location in the score.! !ScorePlayerMorph methodsFor: 'initialization' stamp: 'jm 10/12/1998 17:14'! closeMIDIPort scorePlayer closeMIDIPort. LastMIDIPort _ nil. ! ! !ScorePlayerMorph methodsFor: 'initialization' stamp: 'di 6/15/1999 10:31'! onScorePlayer: aScorePlayer title: scoreName | divider col r | scorePlayer _ aScorePlayer. scorePlayer ifNotNil: [scorePlayer reset. instrumentSelector _ Array new: scorePlayer score tracks size]. divider _ AlignmentMorph new extent: 10@1; borderWidth: 1; inset: 0; borderColor: #raised; color: color; hResizing: #spaceFill; vResizing: #rigid. self removeAllMorphs. self addMorphBack: self makeControls. scorePlayer ifNil: [^ self]. r _ self makeRow hResizing: #shrinkWrap; vResizing: #shrinkWrap. r addMorphBack: self rateControl; addMorphBack: (Morph newBounds: (0@0 extent: 20@0) color: Color transparent); addMorphBack: self volumeControl. self addMorphBack: r. self addMorphBack: self scrollControl. col _ AlignmentMorph newColumn color: color; inset: 0. self addMorphBack: col. 1 to: scorePlayer trackCount do: [:trackIndex | col addMorphBack: divider fullCopy. col addMorphBack: (self trackControlsFor: trackIndex)]. LastMIDIPort ifNotNil: [ "use the most recently set MIDI port" scorePlayer openMIDIPort: LastMIDIPort]. ! ! !ScorePlayerMorph methodsFor: 'initialization' stamp: 'di 10/14/1998 15:46'! openMIDIFile "Open a MIDI score and re-init controls..." | score fileName f player | fileName _ Utilities chooseFileWithSuffixFromList: #('.mid' '.midi') withCaption: 'Choose a MIDI file to open'. fileName ifNil: [^ self]. f _ FileStream readOnlyFileNamed: fileName. score _ (MIDIFileReader new readMIDIFrom: f binary) asScore. f close. player _ ScorePlayer onScore: score. self onScorePlayer: player title: fileName! ! !ScorePlayerMorph methodsFor: 'initialization' stamp: 'jm 10/12/1998 18:00'! openMIDIPort | portNum | portNum _ SimpleMIDIPort outputPortNumFromUser. portNum ifNil: [^ self]. scorePlayer openMIDIPort: portNum. LastMIDIPort _ portNum. ! ! !ScorePlayerMorph methodsFor: 'accessing' stamp: 'jm 6/1/1998 09:10'! scorePlayer ^ scorePlayer ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'di 10/14/1998 15:30'! makeControls | b r reverbSwitch repeatSwitch | b _ SimpleButtonMorph new target: self; borderColor: #raised; borderWidth: 2; color: color. r _ AlignmentMorph newRow. r color: b color; borderWidth: 0; inset: 0. r hResizing: #shrinkWrap; vResizing: #shrinkWrap; extent: 5@5. r addMorphBack: (b fullCopy label: '<>'; actWhen: #buttonDown; actionSelector: #invokeMenu). r addMorphBack: (b fullCopy label: 'Piano Roll'; actionSelector: #makePianoRoll). r addMorphBack: (b fullCopy label: 'Rewind'; actionSelector: #rewind). b target: scorePlayer. r addMorphBack: (b fullCopy label: 'Play'; actionSelector: #resumePlaying). r addMorphBack: (b fullCopy label: 'Pause'; actionSelector: #pause). reverbSwitch _ SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; label: 'Reverb Disable'; actionSelector: #disableReverb:; target: scorePlayer; setSwitchState: SoundPlayer isReverbOn not. r addMorphBack: reverbSwitch. scorePlayer ifNotNil: [repeatSwitch _ SimpleSwitchMorph new offColor: color; onColor: (Color r: 1.0 g: 0.6 b: 0.6); borderWidth: 2; label: 'Repeat'; actionSelector: #repeat:; target: scorePlayer; setSwitchState: scorePlayer repeat. r addMorphBack: repeatSwitch]. b target: self. ^ r ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 9/28/1998 23:05'! makeMIDIController: evt self world activeHand attachMorph: (MIDIControllerMorph new midiPort: scorePlayer midiPort). ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 10/11/2002 08:55'! makePianoRoll "Create a piano roll viewer for this score player." | pianoRoll hand | pianoRoll _ PianoRollScoreMorph new on: scorePlayer. hand _ self world activeHand. hand ifNil: [self world addMorph: pianoRoll] ifNotNil: [hand attachMorph: pianoRoll]. pianoRoll startStepping. ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'! panAndVolControlsFor: trackIndex | volSlider panSlider c r middleLine pianoRollColor | pianoRollColor _ (Color wheel: scorePlayer score tracks size) at: trackIndex. volSlider _ SimpleSliderMorph new color: color; sliderColor: pianoRollColor; extent: 101@2; target: scorePlayer; arguments: (Array with: trackIndex); actionSelector: #volumeForTrack:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (scorePlayer volumeForTrack: trackIndex). panSlider _ volSlider fullCopy actionSelector: #panForTrack:put:; minVal: 0.0; maxVal: 1.0; adjustToValue: (scorePlayer panForTrack: trackIndex). c _ AlignmentMorph newColumn color: color; inset: 0; centering: #center; hResizing: #spaceFill; vResizing: #shrinkWrap. middleLine _ Morph new "center indicator for pan slider" color: (Color r: 0.4 g: 0.4 b: 0.4); extent: 1@(panSlider height - 4); position: panSlider center x@(panSlider top + 2). panSlider addMorphBack: middleLine. r _ self makeRow. r addMorphBack: (StringMorph contents: '0'). r addMorphBack: volSlider. r addMorphBack: (StringMorph contents: '10'). c addMorphBack: r. r _ self makeRow. r addMorphBack: (StringMorph contents: 'L'). r addMorphBack: panSlider. r addMorphBack: (StringMorph contents: 'R'). c addMorphBack: r. ^ c ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'! rateControl | rateSlider middleLine r | rateSlider _ SimpleSliderMorph new color: color; sliderColor: Color gray; extent: 180@2; target: self; actionSelector: #setLogRate:; minVal: -1.0; maxVal: 1.0; adjustToValue: 0.0. middleLine _ Morph new "center indicator for pan slider" color: (Color r: 0.4 g: 0.4 b: 0.4); extent: 1@(rateSlider height - 4); position: rateSlider center x@(rateSlider top + 2). rateSlider addMorphBack: middleLine. r _ self makeRow hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: 'slow '). r addMorphBack: rateSlider. r addMorphBack: (StringMorph contents: ' fast'). ^ r ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'! scrollControl | r | scrollSlider _ SimpleSliderMorph new color: color; sliderColor: Color gray; extent: 360@2; target: scorePlayer; actionSelector: #positionInScore:; adjustToValue: scorePlayer positionInScore. r _ self makeRow hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: 'start '). r addMorphBack: scrollSlider. r addMorphBack: (StringMorph contents: ' end'). ^ r ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'jm 4/20/1999 10:59'! trackNumAndMuteButtonFor: trackIndex | muteButton instSelector pianoRollColor r | muteButton _ SimpleSwitchMorph new onColor: (Color r: 1.0 g: 0.6 b: 0.6); offColor: color; color: color; label: 'Mute'; target: scorePlayer; actionSelector: #mutedForTrack:put:; arguments: (Array with: trackIndex). instSelector _ PopUpChoiceMorph new extent: 95@14; contentsClipped: 'oboe1'; target: self; actionSelector: #atTrack:from:selectInstrument:; getItemsSelector: #instrumentChoicesForTrack:; getItemsArgs: (Array with: trackIndex). instSelector arguments: (Array with: trackIndex with: instSelector). instrumentSelector at: trackIndex put: instSelector. "select track color using same color list as PianoRollScoreMorph" pianoRollColor _ (Color wheel: scorePlayer score tracks size) at: trackIndex. r _ self makeRow hResizing: #rigid; vResizing: #spaceFill; extent: 70@10. r addMorphBack: ((StringMorph contents: trackIndex printString font: (TextStyle default fontOfSize: 24)) color: pianoRollColor). trackIndex < 10 ifTrue: [r addMorphBack: (Morph new color: color; extent: 19@8)] "spacer" ifFalse: [r addMorphBack: (Morph new color: color; extent: 8@8)]. "spacer" r addMorphBack: (StringMorph new extent: 140@14; contentsClipped: (scorePlayer infoForTrack: trackIndex)). r addMorphBack: (Morph new color: color; extent: 8@8). "spacer" r addMorphBack: instSelector. r addMorphBack: (AlignmentMorph newRow color: color). "spacer" r addMorphBack: muteButton. ^ r ! ! !ScorePlayerMorph methodsFor: 'layout' stamp: 'di 11/9/1999 13:30'! volumeControl | volumeSlider r | volumeSlider _ SimpleSliderMorph new color: color; sliderColor: Color gray; extent: 80@2; target: scorePlayer; actionSelector: #overallVolume:; adjustToValue: scorePlayer overallVolume. r _ self makeRow hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: 'soft '). r addMorphBack: volumeSlider. r addMorphBack: (StringMorph contents: ' loud'). ^ r ! ! !ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 10/9/2002 08:05'! atTrack: trackIndex from: aPopUpChoice selectInstrument: selection | snd | (selection beginsWith: 'edit ') ifTrue: [^ self]. snd _ nil. 1 to: instrumentSelector size do: [:i | ((trackIndex ~= i) and: [selection = (instrumentSelector at: i) contents]) ifTrue: [snd _ scorePlayer instrumentForTrack: i]]. "use existing instrument prototype" snd ifNil: [ selection = 'clink' ifTrue: [ snd _ (SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025) copy] ifFalse: [snd _ (AbstractSound soundNamed: selection) copy]]. scorePlayer instrumentForTrack: trackIndex put: snd. (instrumentSelector at: trackIndex) contentsClipped: selection. ! ! !ScorePlayerMorph methodsFor: 'controls' stamp: 'jm 10/12/1998 17:18'! rewind scorePlayer pause; reset. ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 10/9/2002 08:07'! instrumentChoicesForTrack: trackIndex | names inst | names _ AbstractSound soundNames asOrderedCollection. names _ names collect: [:n | inst _ AbstractSound soundNamed: n. (inst isKindOf: UnloadedSound) ifTrue: [n, '(out)'] ifFalse: [n]]. names add: 'clink'. ^ names asArray ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 10/31/2002 11:06'! invokeMenu "Invoke a menu of additonal functions for this ScorePlayer." | aMenu | aMenu _ CustomMenu new. aMenu add: 'open a MIDI file' action: #openMIDIFile. aMenu addList: #( - ('save as AIFF file' saveAsAIFF) ('save as WAV file' saveAsWAV) ('save as Sun AU file' saveAsSunAudio) -). aMenu addLine. scorePlayer midiPort ifNil: [ aMenu add: 'play via MIDI' action: #openMIDIPort] ifNotNil: [ aMenu add: 'play via built in synth' action: #closeMIDIPort. aMenu add: 'new MIDI controller' action: #makeMIDIController:]. aMenu invokeOn: self defaultSelection: nil. ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 12/17/2001 08:14'! saveAsAIFF "Create a stereo AIFF audio file with the result of performing my score." | fileName | fileName _ FillInTheBlank request: 'New file name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.aif') ifFalse: [ fileName _ fileName, '.aif']. scorePlayer storeAIFFOnFileNamed: fileName. ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 12/17/2001 08:16'! saveAsSunAudio "Create a stereo Sun audio file with the result of performing my score." | fileName | fileName _ FillInTheBlank request: 'New file name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.au') ifFalse: [ fileName _ fileName, '.au']. scorePlayer storeSunAudioOnFileNamed: fileName. ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 12/17/2001 08:14'! saveAsWAV "Create a stereo WAV audio file with the result of performing my score." | fileName | fileName _ FillInTheBlank request: 'New file name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.wav') ifFalse: [ fileName _ fileName, '.wav']. scorePlayer storeWAVOnFileNamed: fileName. ! ! !ScorePlayerMorph methodsFor: 'menu' stamp: 'jm 9/12/1998 22:14'! updateInstrumentsFromLibrary "The instrument library has been modified. Update my instruments with the new versions from the library. Use a single instrument prototype for all parts with the same name; this allows the envelope editor to edit all the parts by changing a single sound prototype." | unloadPostfix myInstruments name displaysAsUnloaded isUnloaded | unloadPostfix _ '(out)'. myInstruments _ Dictionary new. 1 to: instrumentSelector size do: [:i | name _ (instrumentSelector at: i) contents. displaysAsUnloaded _ name endsWith: unloadPostfix. displaysAsUnloaded ifTrue: [ name _ name copyFrom: 1 to: name size - unloadPostfix size]. (myInstruments includesKey: name) ifFalse: [ myInstruments at: name put: (name = 'clink' ifTrue: [ (SampledSound samples: SampledSound coffeeCupClink samplingRate: 11025) copy] ifFalse: [ (AbstractSound soundNamed: name ifAbsent: [ (instrumentSelector at: i) contentsClipped: 'default'. FMSound default]) copy])]. scorePlayer instrumentForTrack: i put: (myInstruments at: name). "update loaded/unloaded status in instrumentSelector if necessary" isUnloaded _ (myInstruments at: name) isKindOf: UnloadedSound. (displaysAsUnloaded and: [isUnloaded not]) ifTrue: [(instrumentSelector at: i) contentsClipped: name]. (displaysAsUnloaded not and: [isUnloaded]) ifTrue: [(instrumentSelector at: i) contentsClipped: name, unloadPostfix]]. ! ! !ScorePlayerMorph methodsFor: 'stepping' stamp: 'di 6/15/1999 11:48'! step scrollSlider adjustToValue: scorePlayer positionInScore. ! ! !ScorePlayerMorph class methodsFor: 'as yet unclassified' stamp: 'jm 10/12/1998 16:29'! openOn: aScore title: aString | player | player _ ScorePlayer onScore: aScore. (self new onScorePlayer: player title: aString) openInWorld. ! ! I am the controller for the parts of the display screen that have no view on them. I only provide a standard yellow button menu. I view (a FormView of) an infinite gray form. (ScheduledControllers screenController) is the way to find me.! !ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:21'! controlActivity "Any button opens the screen's menu. If the shift key is down, do find window." sensor leftShiftDown ifTrue: [^ self findWindow]. (self projectScreenMenu invokeOn: self) ifNil: [super controlActivity]! ! !ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:06'! isControlActive ^ self isControlWanted! ! !ScreenController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:05'! isControlWanted ^ self viewHasCursor and: [sensor anyButtonPressed]! ! !ScreenController methodsFor: 'menu messages' stamp: 'jm 5/31/2003 17:08'! aboutThisSystem Smalltalk aboutThisSystem. ! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:25'! bitCachingString ^ StandardSystemView cachingBits ifTrue: ['don''t save bits (compact)'] ifFalse: ['save bits (fast)']! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 8/5/1998 18:40'! browseChangedMessages Smalltalk browseChangedMessages! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:50'! changeWindowPolicy Preferences toggleWindowPolicy! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 12/10/1999 11:29'! configureFonts Preferences presentMvcFontConfigurationMenu! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 2/3/2000 16:23'! fileForRecentLog Smalltalk writeRecentToFile! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 2/15/1999 12:25'! fileOutChanges Utilities fileOutChanges! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 10/27/1998 14:27'! lookForSlips Smalltalk changes lookForSlips! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 9/4/1998 10:17'! newChangeSet ChangeSorter newChangeSet! ! !ScreenController methodsFor: 'menu messages' stamp: 'di 7/19/1999 14:56'! openMorphicProject Smalltalk verifyMorphicAvailability ifFalse: [^ self]. ProjectView open: Project newMorphic. ! ! !ScreenController methodsFor: 'menu messages' stamp: 'jm 10/7/2002 06:22'! openProject "Create and schedule a Project." Smalltalk at: #ProjectView ifPresent: [:c | c open: Project new]. ! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 7/6/1998 18:59'! openSimpleChangeSorter ChangeSorter new open! ! !ScreenController methodsFor: 'menu messages' stamp: 'sma 4/30/2000 10:13'! restoreDisplay "Clear the screen to gray and then redisplay all the scheduled views." Smalltalk isMorphic ifTrue: [^ World restoreDisplay]. Display extent = DisplayScreen actualScreenSize ifFalse: [DisplayScreen startUp. ScheduledControllers unCacheWindows]. ScheduledControllers restore! ! !ScreenController methodsFor: 'menu messages' stamp: 'bf 9/18/1999 20:01'! setDisplayDepth "Let the user choose a new depth for the display. " | result | (result _ (SelectionMenu selections: Display supportedDisplayDepths) startUpWithCaption: 'Choose a display depth (it is currently ' , Display depth printString , ')') == nil ifFalse: [Display newDepth: result]! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 6/11/1999 20:23'! staggerPolicyString ^ Preferences staggerPolicyString! ! !ScreenController methodsFor: 'menu messages' stamp: 'sw 7/13/1999 20:19'! windowSpecificationPanel Smalltalk hasMorphic ifFalse: [^ self inform: 'Sorry, this feature requires the presence of Morphic.']. Preferences windowSpecificationPanel! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 5/31/2003 19:03'! appearanceMenu "Answer the appearance menu to be put up as a screen submenu" "ScreenController new appearanceMenu startUp" ^ SelectionMenu labelList: #( 'set display depth...' 'set desktop color...' 'full screen on' 'full screen off' 'window colors...' 'system fonts...' ) lines: #(2 4) selections: #( setDisplayDepth setDesktopColor fullScreenOn fullScreenOff windowSpecificationPanel configureFonts) ! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 5/31/2003 15:47'! changesMenu "Answer a menu for changes-related items." "ScreenController new changesMenu startUp" ^ SelectionMenu labelList: #( 'simple change sorter' 'dual change sorter' 'file out current change set' 'create new change set...' 'browse changed methods' 'check change set for slips' 'recently logged changes...' 'recent log file...' ) lines: #(2 6) selections: #( openSimpleChangeSorter openChangeManager fileOutChanges newChangeSet browseChangedMessages lookForSlips browseRecentLog fileForRecentLog) ! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 5/31/2003 17:13'! helpMenu "Answer the help menu to be put up as a screen submenu" "ScreenController new helpMenu startUp" ^ SelectionMenu labelList: #( 'about this system' 'command-key help' 'edit preferences...' 'set author initials...' 'memory statistics' 'space left') lines: #(3) selections: #( aboutThisSystem openCommandKeyHelp editPreferences setAuthorInitials vmStatistics garbageCollect). ! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 8/3/2003 15:11'! openMenu "ScreenController new openMenu startUp" ^ SelectionMenu labelList: #( 'browser' 'workspace' 'file list' 'transcript' 'simple change sorter' 'dual change sorter' 'mvc project' 'morphic project') lines: #(5 7) selections: #( openBrowser openWorkspace openFileList openTranscript openSimpleChangeSorter openChangeManager openProject openMorphicProject) ! ! !ScreenController methodsFor: 'nested menus' stamp: 'sma 3/11/2000 12:23'! popUpMenuFor: aSymbol (self perform: aSymbol) invokeOn: self! ! !ScreenController methodsFor: 'nested menus' stamp: 'sw 7/13/1999 18:07'! presentAppearanceMenu self popUpMenuFor: #appearanceMenu! ! !ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:14'! presentChangesMenu self popUpMenuFor: #changesMenu! ! !ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'! presentHelpMenu self popUpMenuFor: #helpMenu! ! !ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:15'! presentOpenMenu self popUpMenuFor: #openMenu! ! !ScreenController methodsFor: 'nested menus' stamp: 'sw 7/6/1998 21:16'! presentWindowMenu self popUpMenuFor: #windowMenu! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 5/31/2003 19:08'! projectScreenMenu "Answer the project screen menu." ^ SelectionMenu labelList: #( 'previous project' 'jump to project...' 'restore display' 'open...' 'windows...' 'changes...' 'help...' 'appearance...' 'save' 'save as...' 'save and quit' 'quit') lines: #(2 3 8) selections: #( returnToPreviousProject jumpToProject restoreDisplay presentOpenMenu presentWindowMenu presentChangesMenu presentHelpMenu presentAppearanceMenu snapshot saveAs snapshotAndQuit quit). ! ! !ScreenController methodsFor: 'nested menus' stamp: 'jm 5/31/2003 16:01'! windowMenu "Answer a menu for windows-related items." "ScreenController new windowMenu startUp" ^ SelectionMenu labelList: #( 'find window...' 'find changed browsers...' 'find changed windows...' 'collapse all windows' 'expand all windows' 'close unchanged windows'), (Array with: self bitCachingString with: self staggerPolicyString) lines: #(3 6) selections: #( findWindow chooseDirtyBrowser chooseDirtyWindow collapseAll expandAll closeUnchangedWindows fastWindows changeWindowPolicy) ! ! Inspired by an oiginal design of Hans-Martin Mosner, this ScrollBar is intended to exercise the handling of input events in Morphic. With sufficient flexibility in this area, all particular behavior can be concentrated in this single class with no need to specialize any other morphs to achieve button, slider and menu-button behavior. Once we have this working, put in logic for horizontal operation as well.! !ScrollBar methodsFor: 'initialize' stamp: 'jm 10/13/2002 10:47'! initialize super initialize. scrollDelta _ 0.02. pageDelta _ 0.2. ! ! !ScrollBar methodsFor: 'initialize' stamp: 'jm 6/15/2003 10:28'! initializeDownButton downButton _ BorderedMorph newBounds: (self innerBounds bottomRight - self buttonExtent extent: self buttonExtent) color: Color lightGray. downButton addMorphCentered: (ImageMorph new form: (UpArrow rotateBy: (bounds isWide ifTrue: [#right] ifFalse: [#pi]) centerAt: 0@0)). downButton setBorderWidth: 1 borderColor: #raised. self addMorph: downButton. ! ! !ScrollBar methodsFor: 'initialize' stamp: 'jm 6/15/2003 10:41'! initializeMenuButton "Preferences disable: #scrollBarsWithoutMenuButton" "Preferences enable: #scrollBarsWithoutMenuButton" hasMenuButton ifNil: [ hasMenuButton _ (Preferences valueOfFlag: #scrollBarsWithoutMenuButton) not]. hasMenuButton ifFalse: [^ self]. menuButton _ BorderedMorph newBounds: (self innerBounds topLeft extent: self buttonExtent) color: Color lightGray. menuButton addMorphCentered: (BorderedMorph newBounds: (0@0 extent: 4@2) color: Color black). menuButton setBorderWidth: 1 borderColor: #raised. self addMorph: menuButton. ! ! !ScrollBar methodsFor: 'initialize' stamp: 'jm 6/15/2003 10:29'! initializePagingArea pagingArea _ BorderedMorph newBounds: self totalSliderArea color: (Color r: 0.6 g: 0.6 b: 0.8). pagingArea borderWidth: 0. self addMorph: pagingArea. ! ! !ScrollBar methodsFor: 'initialize' stamp: 'jm 10/13/2002 11:16'! initializeSlider "Note: we must initialize all the parts before initializing the slider itself." self initializeMenuButton; initializeUpButton; initializeDownButton; initializePagingArea. super initializeSlider. ! ! !ScrollBar methodsFor: 'initialize' stamp: 'jm 6/15/2003 10:29'! initializeUpButton | where | where _ menuButton ifNil: [self innerBounds topLeft] ifNotNil: [ bounds isWide ifTrue: [menuButton bounds topRight] ifFalse: [menuButton bounds bottomLeft]]. upButton _ BorderedMorph newBounds: (where extent: self buttonExtent) color: Color lightGray. upButton addMorphCentered: (ImageMorph new form: (bounds isWide ifTrue: [UpArrow rotateBy: #left centerAt: 0@0] ifFalse: [UpArrow])). upButton setBorderWidth: 1 borderColor: #raised. self addMorph: upButton. ! ! !ScrollBar methodsFor: 'access' stamp: 'jm 2/4/2003 11:49'! hasMenuButton: aBoolean hasMenuButton _ aBoolean. hasMenuButton ifFalse: [menuButton _ nil]. self removeAllMorphs; initializeSlider. ! ! !ScrollBar methodsFor: 'access' stamp: 'dew 2/21/1999 03:08'! interval: d "Supply an optional floating fraction so slider can expand to indicate range" interval _ d min: 1.0. self expandSlider. self computeSlider.! ! !ScrollBar methodsFor: 'access' stamp: 'dew 2/15/1999 18:25'! pagingArea ^pagingArea! ! !ScrollBar methodsFor: 'geometry' stamp: 'dew 6/9/1999 02:02'! buttonExtent ^ bounds isWide ifTrue: [11 @ self innerBounds height] ifFalse: [self innerBounds width @ 11]! ! !ScrollBar methodsFor: 'geometry' stamp: 'dew 2/27/1999 18:22'! expandSlider "Compute the new size of the slider (use the old sliderThickness as a minimum)." | r | r _ self totalSliderArea. slider extent: (bounds isWide ifTrue: [((r width * interval) asInteger max: self sliderThickness) @ slider height] ifFalse: [slider width @ ((r height * interval) asInteger max: self sliderThickness)])! ! !ScrollBar methodsFor: 'geometry' stamp: 'dew 7/22/1999 19:03'! extent: p p x > p y ifTrue: [super extent: (p max: 42@8)] ifFalse: [super extent: (p max: 8@42)]! ! !ScrollBar methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'! sliderExtent "The sliderExtent is now stored in the slider itself, not hardcoded as it is in the superclass." ^slider extent! ! !ScrollBar methodsFor: 'scrolling' stamp: 'di 8/17/1998 09:39'! scrollByPage: event nextPageDirection == nil ifTrue: [nextPageDirection _ event cursorPoint y >= slider center y]. (self waitForDelay1: 300 delay2: 100) ifFalse: [^ self]. nextPageDirection ifTrue: [self setValue: (value + pageDelta min: 1.0)] ifFalse: [self setValue: (value - pageDelta max: 0.0)] ! ! !ScrollBar methodsFor: 'scrolling' stamp: 'di 8/17/1998 09:40'! scrollDown (self waitForDelay1: 300 delay2: 50) ifFalse: [^ self]. self setValue: (value + scrollDelta + 0.000001 min: 1.0)! ! !ScrollBar methodsFor: 'scrolling' stamp: 'jm 10/13/2002 11:01'! scrollDown: count "Used to scroll down by the given number of scrollDeltas in response to arrow keys. A negative count scrolls up." self setValue: ((value + (count * scrollDelta) + 0.000001 min: 1.0) max: 0.0). ! ! !ScrollBar methodsFor: 'scrolling' stamp: 'di 8/17/1998 09:40'! scrollUp (self waitForDelay1: 300 delay2: 50) ifFalse: [^ self]. self setValue: (value - scrollDelta - 0.000001 max: 0.0)! ! !ScrollBar methodsFor: 'scrolling' stamp: 'dew 2/21/1999 03:08'! setValue: newValue "Using roundTo: instead of truncateTo: ensures that scrollUp will scroll the same distance as scrollDown." ^ super setValue: (newValue roundTo: scrollDelta)! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:21'! handlesMouseDown: evt ^ true ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:14'! mouseDown: evt | p | p _ evt cursorPoint. dragOffset _ slider position - p. mouseTarget _ nil. (slider containsPoint: p) ifTrue: [^ self mouseDownInSlider: evt]. (upButton containsPoint: p) ifTrue: [^ self mouseDownInUpButton: evt]. (downButton containsPoint: p) ifTrue: [^ self mouseDownInDownButton: evt]. (pagingArea containsPoint: p) ifTrue: [^ self mouseDownInPagingArea: evt]. (menuButton notNil and: [menuButton containsPoint: p]) ifTrue: [ ^ self mouseDownInMenu: evt]. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:52'! mouseDownInDownButton: evt mouseTarget _ downButton. downButton borderInset. self resetTimer. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:33'! mouseDownInMenu: evt "Send yellowButtonActivity: to my model, if I have one." model ifNil: [^ self]. model yellowButtonActivity: evt shiftPressed. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:10'! mouseDownInPagingArea: evt mouseTarget _ pagingArea. self resetTimer. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:48'! mouseDownInSlider: evt mouseTarget _ slider. super mouseDown: evt. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:53'! mouseDownInUpButton: evt mouseTarget _ upButton. upButton borderInset. self resetTimer. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 11:11'! mouseMove: evt mouseTarget == slider ifTrue: [^ super mouseMove: evt]. mouseTarget == upButton ifTrue: [^ self scrollUp]. mouseTarget == downButton ifTrue: [^ self scrollDown]. mouseTarget == pagingArea ifTrue: [^ self scrollByPage: evt]. ! ! !ScrollBar methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:51'! mouseUp: evt mouseTarget == slider ifTrue: [^ super mouseUp: evt]. mouseTarget == upButton ifTrue: [^ upButton borderRaised]. mouseTarget == downButton ifTrue: [^ downButton borderRaised]. ! ! !ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:22'! resetTimer timeOfMouseDown _ Time millisecondClockValue. timeOfLastScroll _ timeOfMouseDown - 1000 max: 0. nextPageDirection _ nil. currentScrollDelay _ nil! ! !ScrollBar methodsFor: 'scroll timing' stamp: 'di 8/17/1998 09:38'! waitForDelay1: delay1 delay2: delay2 "Return true if an appropriate delay has passed since the last scroll operation. The delay decreases exponentially from delay1 to delay2." | now scrollDelay | timeOfLastScroll == nil ifTrue: [self resetTimer]. "Only needed for old instances" now _ Time millisecondClockValue. now < timeOfLastScroll ifTrue: [self resetTimer "rare clock rollover"]. (scrollDelay _ currentScrollDelay) == nil ifTrue: [scrollDelay _ delay1 "initial delay"]. now > (timeOfLastScroll + scrollDelay) ifFalse: [^ false "not time yet"]. currentScrollDelay _ scrollDelay*9//10 max: delay2. "decrease the delay" timeOfLastScroll _ now. ^ true! ! I represent control for scrolling using a scrollBar. I am a MouseMenuController that creates a scrollBar, rather than menus. My subclasses add the button menus. I keep control as long as the cursor is inside the view or the scrollBar area. A scrollBar is a rectangular area representing the length of the information being viewed. It contains an inner rectangle whose top y-coordinate represents the relative position of the information visible on the screen with respect to all of the information, and whose size represents the relative amount of that information visible on the screen. The user controls which part of the information is visible by pressing the red button. If the cursor is to the right of the inner rectangle, the window onto the visible information moves upward, if the cursor is to the left, the window moves downward, and if the cursor is inside, the inner rectangle is grabbed and moved to a desired position.! !ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:17'! controlActivity self scrollByKeyboard ifTrue: [^ self]. self scrollBarContainsCursor ifTrue: [self scroll] ifFalse: [self normalActivity]! ! !ScrollController methodsFor: 'control defaults' stamp: 'ar 3/24/2000 00:45'! isControlActive super isControlActive ifTrue: [^ true]. sensor blueButtonPressed ifTrue: [^ false]. ^ (scrollBar inside merge: view insetDisplayBox) containsPoint: sensor cursorPoint! ! !ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:31'! isControlWanted ^ self viewHasCursor! ! !ScrollController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:16'! normalActivity super controlActivity! ! !ScrollController methodsFor: 'scrolling' stamp: 'ls 7/11/1998 06:33'! scroll "Check to see whether the user wishes to jump, scroll up, or scroll down." | savedCursor | savedCursor _ sensor currentCursor. [self scrollBarContainsCursor] whileTrue: [self interActivityPause. sensor cursorPoint x <= self downLine ifTrue: [self scrollDown] ifFalse: [sensor cursorPoint x <= self upLine ifTrue: [self scrollAbsolute] ifFalse: [sensor cursorPoint x <= self yellowLine ifTrue: [self scrollUp] ifFalse: [sensor cursorPoint x <= scrollBar right ifTrue: "Might not be, with touch pen" [self changeCursor: Cursor menu. sensor anyButtonPressed ifTrue: [self changeCursor: savedCursor. self anyButtonActivity]]]]]]. savedCursor show! ! !ScrollController methodsFor: 'scrolling' stamp: 'th 12/11/1999 16:57'! scrollByKeyboard | keyEvent | keyEvent _ sensor keyboardPeek. keyEvent ifNil: [^ false]. (sensor controlKeyPressed or:[sensor commandKeyPressed]) ifFalse: [^ false]. keyEvent asciiValue = 30 ifTrue: [sensor keyboard. self scrollViewDown ifTrue: [self moveMarker]. ^ true]. keyEvent asciiValue = 31 ifTrue: [sensor keyboard. self scrollViewUp ifTrue: [self moveMarker]. ^ true]. ^ false! ! The scroller (a transform) of a scrollPane is driven by the scrollBar. The scroll values vary from 0.0, meaning zero offset to 1.0 meaning sufficient offset such that the bottom of the scrollable material appears halfway down the pane. The total distance to achieve this range is called the totalScrollRange. ! !ScrollPane methodsFor: 'initialization' stamp: 'tk 8/13/1998 13:05'! fullCopy | copy | self mouseEnter: nil. "Make sure scrollBar is in morphic structure" copy _ super fullCopy. "So that references are updated properly" "Will fail of any Players with scripts are in the ScrollPane" self mouseLeave: nil. ^ copy mouseLeave: nil ! ! !ScrollPane methodsFor: 'initialization' stamp: 'jm 10/10/2002 20:10'! initialize super initialize. hasFocus _ false. borderWidth _ 2. borderColor _ Color black. retractableScrollBar _ (Preferences valueOfFlag: #inboardScrollbars) not. scrollBarOnLeft _ (Preferences valueOfFlag: #scrollBarsOnRight) not. scrollBar _ ScrollBar new model: self. scrollBar borderWidth: 1; borderColor: Color black. scroller _ TransformMorph new color: Color transparent. scroller offset: -3@0. self addMorph: scroller. retractableScrollBar ifFalse: [self addMorph: scrollBar]. self extent: 150@120. ! ! !ScrollPane methodsFor: 'initialization' stamp: 'dew 10/17/1999 19:41'! setScrollDeltas | range delta | self hideOrShowScrollBar. scroller hasSubmorphs ifFalse: [scrollBar interval: 1.0. ^ self]. range _ self leftoverScrollRange. delta _ self scrollDeltaHeight. range = 0 ifTrue: [^ scrollBar scrollDelta: 0.02 pageDelta: 0.2; interval: 1.0]. "Set up for one line (for arrow scrolling), or a full pane less one line (for paging)." scrollBar scrollDelta: (delta / range) asFloat pageDelta: ((self innerBounds height - delta) / range) asFloat. scrollBar interval: ((self innerBounds height - delta) / self totalScrollRange) asFloat. ! ! !ScrollPane methodsFor: 'access' stamp: 'jm 10/4/2002 17:35'! colorForInsets "My submorphs use the surrounding color." (owner color isKindOf: Color) ifTrue: [^ owner color] ifFalse: [^ Color white]. ! ! !ScrollPane methodsFor: 'access' stamp: 'dew 10/17/1999 19:40'! hasFocus "hasFocus is currently set by mouse enter/leave events. This inst var should probably be moved up to a higher superclass." ^ hasFocus ifNil: [false]! ! !ScrollPane methodsFor: 'access' stamp: 'jm 10/3/2002 17:57'! model ^ model ! ! !ScrollPane methodsFor: 'access' stamp: 'jm 10/8/2002 10:43'! model: anObject "Set my model and make me me a dependent of the given object." model ifNotNil: [model removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. model _ anObject. ! ! !ScrollPane methodsFor: 'geometry' stamp: 'go 4/26/1999 10:06'! extent: newExtent super extent: (newExtent max: (self scrollbarWidth + 20)@16). self resizeScrollBar; resizeScroller; setScrollDeltas! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'! innerBounds | inner w | inner _ super innerBounds. w _ self scrollbarWidth. retractableScrollBar | (submorphs includes: scrollBar) not ifTrue: [^ inner] ifFalse: [^ (scrollBarOnLeft ifTrue: [inner topLeft + ((w-1)@0) corner: inner bottomRight] ifFalse: [inner topLeft corner: inner bottomRight - ((w-2)@0)])]! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 18:46'! leftoverScrollRange "Return the entire scrolling range minus the currently viewed area." ^ self totalScrollRange - (bounds height * 3 // 4) max: 0 ! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'! resetExtent "Reset the extent. (may be overridden by subclasses which need to do more than this)" self resizeScroller! ! !ScrollPane methodsFor: 'geometry' stamp: 'di 11/11/1998 09:11'! resizeScrollBar | w topLeft | w _ self scrollbarWidth. topLeft _ scrollBarOnLeft ifTrue: [retractableScrollBar ifTrue: [bounds topLeft - ((w-1)@0)] ifFalse: [bounds topLeft]] ifFalse: [retractableScrollBar ifTrue: [bounds topRight] ifFalse: [bounds topRight - ((w-1)@0)]]. scrollBar bounds: (topLeft extent: w @ bounds height)! ! !ScrollPane methodsFor: 'geometry' stamp: 'di 11/11/1998 09:48'! resizeScroller scroller bounds: self innerBounds! ! !ScrollPane methodsFor: 'geometry' stamp: 'di 8/16/1998 01:09'! scrollBarFills: aRectangle "Return true if a flop-out scrollbar fills the rectangle" ^ (retractableScrollBar and: [submorphs includes: scrollBar]) and: [scrollBar bounds containsRect: aRectangle]! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 18:49'! scrollBy: delta "Move the contents in the direction delta." "For now, delta is assumed to have a zero x-component" | newYoffset r | newYoffset _ scroller offset y - delta y max: 0. scroller offset: scroller offset x @ newYoffset. (r _ self leftoverScrollRange) = 0 ifTrue: [scrollBar value: 0.0] ifFalse: [scrollBar value: newYoffset asFloat / r]! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 17:08'! scrollDeltaHeight "Return the increment in pixels which this pane should be scrolled (normally a subclass responsibility)." ^ 12 ! ! !ScrollPane methodsFor: 'geometry' stamp: 'di 12/6/1999 08:35'! scrollbarWidth "Includes border" (Preferences valueOfFlag: #scrollBarsNarrow) ifTrue: [^ 12] ifFalse: [^ 16]! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 2/19/1999 20:24'! totalScrollRange "Return the entire scrolling range." ^ (scroller submorphBounds encompass: 0@0) height ! ! !ScrollPane methodsFor: 'geometry' stamp: 'dew 10/17/1999 19:41'! unadjustedScrollRange "Return the difference between the height extent of the receiver's submorphs and its own height extent (plus an extra 1/2 line height)." scroller submorphBounds ifNil: [^ 0]. ^ self totalScrollRange - bounds height + (self scrollDeltaHeight / 2) max: 0! ! !ScrollPane methodsFor: 'event handling' stamp: 'jm 10/10/2002 20:08'! handlesMouseDown: evt ^ true ! ! !ScrollPane methodsFor: 'event handling' stamp: 'di 1/18/2000 15:29'! handlesMouseOver: evt "Could just ^ true, but this ensures that scroll bars won't flop out if you mouse-over appendages such as connecting pins." | cp | cp _ evt cursorPoint. (bounds containsPoint: cp) ifTrue: [^ true] ifFalse: [self submorphsDo: [:m | (m containsPoint: cp) ifTrue: [m == scrollBar ifTrue: [^ true] ifFalse: [^ false]]]. ^ false]! ! !ScrollPane methodsFor: 'event handling' stamp: 'jm 10/10/2002 20:09'! keyStroke: evt "If pane is not full, pass the event to the last submorph, assuming it is the most appropriate recipient (!!)" (self scrollByKeyboard: evt) ifTrue: [^ self]. scroller submorphs last keyStroke: evt. ! ! !ScrollPane methodsFor: 'event handling' stamp: 'di 6/30/1998 08:48'! mouseDown: evt evt yellowButtonPressed "First check for option (menu) click" ifTrue: [^ self yellowButtonActivity: evt shiftPressed]. "If pane is not full, pass the event to the last submorph, assuming it is the most appropriate recipient (!!)" scroller hasSubmorphs ifTrue: [scroller submorphs last mouseDown: (evt transformedBy: (scroller transformFrom: self))]! ! !ScrollPane methodsFor: 'event handling' stamp: 'dew 5/22/2000 15:55'! mouseEnter: event hasFocus _ true. (owner isKindOf: SystemWindow) ifTrue: [owner paneTransition: event]. self hideOrShowScrollBar. ! ! !ScrollPane methodsFor: 'event handling' stamp: 'dew 10/17/1999 19:41'! mouseLeave: event hasFocus _ false. retractableScrollBar ifTrue: [self hideScrollBar]. (owner isKindOf: SystemWindow) ifTrue: [owner paneTransition: event]! ! !ScrollPane methodsFor: 'event handling' stamp: 'jm 10/13/2002 10:58'! scrollByKeyboard: event "If event is ctrl+up/down then scroll and answer true." (event controlKeyPressed or: [event commandKeyPressed]) ifFalse: [^ false]. event keyValue = 30 ifTrue: [scrollBar scrollDown: -3. ^ true]. event keyValue = 31 ifTrue: [scrollBar scrollDown: 3. ^ true]. ^ false ! ! !ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'! scrollBarMenuButtonPressed: event ^ self yellowButtonActivity: event shiftPressed! ! !ScrollPane methodsFor: 'scroll bar events' stamp: 'dew 2/19/1999 18:48'! scrollBarValue: scrollValue scroller hasSubmorphs ifFalse: [^ self]. scroller offset: -3 @ (self leftoverScrollRange * scrollValue)! ! !ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:31'! shiftedYellowButtonActivity ^ self yellowButtonActivity: true! ! !ScrollPane methodsFor: 'scroll bar events' stamp: 'di 6/26/1998 13:32'! unshiftedYellowButtonActivity ^ self yellowButtonActivity: false! ! !ScrollPane methodsFor: 'scroll bar events' stamp: 'sma 6/5/2000 13:36'! yellowButtonActivity: shiftKeyState | menu | (menu _ self getMenu: shiftKeyState) ifNotNil: [menu setInvokingView: self. menu popUpEvent: self activeHand lastEvent]! ! !ScrollPane methodsFor: 'menu' stamp: 'jm 10/10/2002 20:07'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. retractableScrollBar ifTrue: [aCustomMenu add: 'make scrollbar permanent' action: #retractableOrNot] ifFalse: [aCustomMenu add: 'make scrollbar retractable' action: #retractableOrNot]. scrollBarOnLeft ifTrue: [aCustomMenu add: 'scroll bar on right' action: #toggleScrollBarOnLeft] ifFalse: [aCustomMenu add: 'scroll bar on left' action: #toggleScrollBarOnLeft]. ! ! !ScrollPane methodsFor: 'menu' stamp: 'sw 9/23/1998 08:47'! getMenu: shiftKeyState "Answer the menu for this text view, supplying an empty menu to be filled in. If the menu selector takes an extra argument, pass in the current state of the shift key." | menu aMenu aTitle | getMenuSelector == nil ifTrue: [^ nil]. menu _ MenuMorph new defaultTarget: model. aTitle _ getMenuTitleSelector ifNotNil: [model perform: getMenuTitleSelector]. getMenuSelector numArgs = 1 ifTrue: [aMenu _ model perform: getMenuSelector with: menu. aTitle ifNotNil: [aMenu addTitle: aTitle]. ^ aMenu]. getMenuSelector numArgs = 2 ifTrue: [aMenu _ model perform: getMenuSelector with: menu with: shiftKeyState. aTitle ifNotNil: [aMenu addTitle: aTitle]. ^ aMenu]. ^ self error: 'The getMenuSelector must be a 1- or 2-keyword symbol'! ! !ScrollPane methodsFor: 'menu' stamp: 'sw 8/18/1998 12:38'! menuTitleSelector: aSelector getMenuTitleSelector _ aSelector! ! !ScrollPane methodsFor: 'menu' stamp: 'sw 11/5/1998 14:14'! retractable: aBoolean retractableScrollBar == aBoolean ifFalse: [self retractableOrNot "toggles it"]! ! !ScrollPane methodsFor: 'menu' stamp: 'jm 10/10/2002 20:06'! toggleScrollBarOnLeft "Put the scroll bar ont the other side." scrollBarOnLeft _ scrollBarOnLeft not. self extent: self extent. ! ! !ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 15:18'! hideOrShowScrollBar "Hide or show the scrollbar depending on if the pane is scrolled/scrollable." "Don't do anything with the retractable scrollbar unless we have focus" retractableScrollBar & self hasFocus not ifTrue: [^self]. self isScrollable not & self isScrolledFromTop not ifTrue: [self hideScrollBar]. self isScrollable | self isScrolledFromTop ifTrue: [self showScrollBar]. ! ! !ScrollPane methodsFor: 'scrolling' stamp: 'RAA 6/8/2000 12:34'! hideScrollBar (submorphs includes: scrollBar) ifFalse: [^self]. self privateRemoveMorph: scrollBar. scrollBar privateOwner: nil. retractableScrollBar ifFalse: [self resetExtent].! ! !ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 16:28'! isScrollable (Preferences valueOfFlag: #hiddenScrollBars) ifFalse: [^ true]. "If the contents of the pane are too small to scroll, return false." ^ self unadjustedScrollRange > 0 "treat a single line as non-scrollable" and: [self totalScrollRange > (self scrollDeltaHeight * 3/2)]! ! !ScrollPane methodsFor: 'scrolling' stamp: 'dew 5/22/2000 15:17'! isScrolledFromTop "Have the contents of the pane been scrolled, so that the top of the contents are not visible?" ^scroller offset y > 0 ! ! !ScrollPane methodsFor: 'scrolling' stamp: 'RAA 6/8/2000 12:35'! showScrollBar (submorphs includes: scrollBar) ifTrue: [^self]. self privateAddMorph: scrollBar atIndex: 1. self resizeScrollBar. scrollBar changed. retractableScrollBar ifFalse: [self resetExtent].! ! !SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'! selections ^ selections! ! !SelectionMenu methodsFor: 'accessing' stamp: 'sma 5/28/2000 11:38'! selections: selectionArray selections _ selectionArray! ! !SelectionMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 15:28'! invokeOn: targetObject "Pop up this menu and return the result of sending to the target object the selector corresponding to the menu item selected by the user. Return nil if no item is selected." | sel | sel _ self startUp. sel = nil ifFalse: [^ targetObject perform: sel]. ^ nil "Example: (SelectionMenu labels: 'sin cos neg' lines: #() selections: #(sin cos negated)) invokeOn: 0.7"! ! !SelectionMenu methodsFor: 'basic control sequence' stamp: 'sma 5/28/2000 15:28'! startUpWithCaption: captionOrNil at: location "Overridden to return value returned by manageMarker." | index | index _ super startUpWithCaption: captionOrNil at: location. (selections = nil or: [(index between: 1 and: selections size) not]) ifTrue: [^ nil]. ^ selections at: index! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sw 11/8/1999 17:52'! fromArray: anArray "Construct a menu from anArray. The elements of anArray must be either: * A pair of the form: <label> <selector> or * The 'dash' (or 'minus sign') symbol Refer to the example at the bottom of the method" | labelList lines selections anIndex | labelList _ OrderedCollection new. lines _ OrderedCollection new. selections _ OrderedCollection new. anIndex _ 0. anArray do: [:anElement | anElement size == 1 ifTrue: [(anElement == #-) ifFalse: [self error: 'badly-formed menu constructor']. lines add: anIndex] ifFalse: [anElement size == 2 ifFalse: [self error: 'badly-formed menu constructor']. anIndex _ anIndex + 1. labelList add: anElement first. selections add: anElement second]]. ^ self labelList: labelList lines: lines selections: selections "(SelectionMenu fromArray: #( ('first label' moja) ('second label' mbili) - ('third label' tatu) - ('fourth label' nne) ('fifth label' tano))) startUp"! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! labelList: labelList ^ self labelArray: labelList! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! labelList: labelList lines: lines ^ self labelArray: lines lines: lines! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! labelList: labelList lines: lines selections: selections ^ (self labelArray: labelList lines: lines) selections: selections! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:04'! labelList: labelList selections: selections ^ self labelList: labelList lines: #() selections: selections! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:09'! labels: labels lines: linesArray "Answer an instance of me whose items are in labels, with lines drawn after each item indexed by linesArray. Labels can be either a string with embedded CRs, or a collection of strings." (labels isKindOf: String) ifTrue: [^ super labels: labels lines: linesArray] ifFalse: [^ super labelArray: labels lines: linesArray]! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:09'! labels: labels lines: linesArray selections: selectionsArray "Answer an instance of me whose items are in labels, with lines drawn after each item indexed by linesArray. Labels can be either a string with embedded CRs, or a collection of strings. Record the given array of selections corresponding to the items in labels." ^ (self labels: labels lines: linesArray) selections: selectionsArray! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! labels: labels selections: selectionsArray "Answer an instance of me whose items are in labels, recording the given array of selections corresponding to the items in labels." ^ self labels: labels lines: #() selections: selectionsArray! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! selections: selectionsArray "Answer an instance of me whose labels and selections are identical." ^ self selections: selectionsArray lines: nil! ! !SelectionMenu class methodsFor: 'instance creation' stamp: 'sma 5/28/2000 16:10'! selections: selectionsArray lines: linesArray "Answer an instance of me whose labels and selections are identical." ^ self labelList: (selectionsArray collect: [:each | each asString]) lines: linesArray selections: selectionsArray! ! I am a parse tree leaf representing a selector.! !SelectorNode methodsFor: 'code generation' stamp: 'di 1/7/2000 12:32'! size: encoder args: nArgs super: supered | index | self reserve: encoder. (supered not and: [code - Send < SendLimit and: [nArgs < 3]]) ifTrue: [^1]. "short send" (supered and: [code < Send]) ifTrue: ["super special:" code _ self code: (encoder sharableLitIndex: key) type: 5]. index _ code < 256 ifTrue: [code - Send] ifFalse: [code \\ 256]. (index <= 31 and: [nArgs <= 7]) ifTrue: [^ 2]. "medium send" (supered not and: [index <= 63 and: [nArgs <= 3]]) ifTrue: [^ 2]. "new medium send" ^ 3 "long send"! ! !SelectorNode methodsFor: 'printing' stamp: 'sw 11/17/1999 15:03'! printOn: aStream indent: level "nb: this method is seemingly never reached" aStream withAttributes: (Preferences syntaxAttributesFor: #keyword) do: [aStream nextPutAll: key]! ! I provide synchronized communication of a single bit of information (a "signal") between Processes. A signal is sent by sending the message signal and received by sending the message wait. If no signal has been sent when a wait message is sent, the sending Process will be suspended until a signal is sent.! !Semaphore methodsFor: 'mutual exclusion' stamp: 'ar 10/8/1998 11:16'! critical: mutuallyExcludedBlock ifError: errorBlock "Evaluate mutuallyExcludedBlock only if the receiver is not currently in the process of running the critical: message. If the receiver is, evaluate mutuallyExcludedBlock after the other critical: message is finished." | blockValue hasError errMsg errRcvr | self wait. hasError _ false. blockValue _ [mutuallyExcludedBlock value] ifError:[:msg :rcvr| hasError _ true. errMsg _ msg. errRcvr _ rcvr]. hasError ifTrue:[ self signal. ^errorBlock value: errMsg value: errRcvr]. self signal. ^blockValue! ! !Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'! = anObject ^ self == anObject! ! !Semaphore methodsFor: 'comparing' stamp: 'sma 4/22/2000 18:48'! hash ^ self identityHash! ! I am an abstract superclass for collections that have a well-defined order associated with their elements. Thus each element is externally-named by integers referred to as indices.! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:34'! allButFirst "Answer a copy of the receiver containing all but the first element. Raise an error if there are not enough elements." ^ self allButFirst: 1! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! allButFirst: n "Answer a copy of the receiver containing all but the first n elements. Raise an error if there are not enough elements." ^ self copyFrom: n + 1 to: self size! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! allButLast "Answer a copy of the receiver containing all but the last element. Raise an error if there are not enough elements." ^ self allButLast: 1! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:35'! allButLast: n "Answer a copy of the receiver containing all but the last n elements. Raise an error if there are not enough elements." ^ self copyFrom: 1 to: self size - n! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:11'! at: index ifAbsent: exceptionBlock "Answer the element at my position index. If I do not contain an element at index, answer the result of evaluating the argument, exceptionBlock." (index between: 1 and: self size) ifTrue: [^ self at: index]. ^ exceptionBlock value! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:14'! atAll: indexArray "Answer a new collection like the receiver which contains all elements of the receiver at the indices of indexArray." | newCollection | newCollection _ self species new: indexArray size. 1 to: indexArray size do: [:index | newCollection at: index put: (self at: (indexArray at: index))]. ^ newCollection! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:17'! atAll: aCollection put: anObject "Put anObject at every index specified by the elements of aCollection." aCollection do: [:index | self at: index put: anObject]. ^ anObject! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:45'! atAllPut: anObject "Put anObject at every one of the receiver's indices." | size | (size _ self size) > 26 "first method faster from 27 accesses and on" ifTrue: [self from: 1 to: size put: anObject] ifFalse: [1 to: size do: [:index | self at: index put: anObject]]! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'di 11/6/1998 14:32'! atPin: index "Return the index'th element of me if possible. Return the first or last element if index is out of bounds." index < 1 ifTrue: [^ self first]. index > self size ifTrue: [^ self last]. ^ self at: index! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:36'! atRandom "Answer a random element of the receiver. Uses a shared random number generator owned by class Collection. If you use this a lot, define your own instance of Random and use #atRandom:. Causes an error if self has no elements." ^ self atRandom: Collection randomForPicking "Examples: #('one' 'or' 'the' 'other') atRandom (1 to: 10) atRandom 'Just pick one of these letters at random' atRandom "! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 12:50'! atRandom: aGenerator "Answer a random element of the receiver. Uses aGenerator which should be kept by the user in a variable and used every time. Use this instead of #atRandom for better uniformity of random numbers because only you use the generator. Causes an error if self has no elements." ^ self at: (aGenerator nextInt: self size)! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:51'! atWrap: index "Answer the index'th element of the receiver. If index is out of bounds, let it wrap around from the end to the beginning until it is in bounds." ^ self at: index - 1 \\ self size + 1! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 13:52'! atWrap: index put: value "Store value into the index'th element of the receiver. If index is out of bounds, let it wrap around from the end to the beginning until it is in bounds. Answer value." ^ self at: index - 1 \\ self size + 1 put: value! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'jm 6/20/2003 10:01'! fifth "Answer the fifth element of the receiver." ^ self at: 5 ! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'jm 6/20/2003 10:01'! first "Answer the first element of the receiver." ^ self at: 1 ! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:31'! first: n "Answer the first n elements of the receiver. Raise an error if there are not enough elements." ^ self copyFrom: 1 to: n! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'jm 6/20/2003 10:01'! fourth "Answer the fourth element of the receiver." ^ self at: 4 ! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:52'! from: startIndex to: endIndex put: anObject "Put anObject in all indexes between startIndex and endIndex. Very fast. Faster than to:do: for more than 26 positions. No range checks are performed. Answer anObject." | written toWrite thisWrite | self at: startIndex put: anObject. written _ 1. toWrite _ endIndex - startIndex + 1. [written < toWrite] whileTrue: [thisWrite _ written min: toWrite - written. self replaceFrom: startIndex + written to: startIndex + written + thisWrite - 1 with: self startingAt: startIndex. written _ written + thisWrite]. ^ anObject! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ar 8/14/1998 21:21'! identityIndexOf: anElement ifAbsent: exceptionBlock "Answer the index of anElement within the receiver. If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock." 1 to: self size do: [:i | (self at: i) == anElement ifTrue: [^ i]]. ^ exceptionBlock value! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:46'! indexOf: anElement "Answer the index of the first occurence of anElement within the receiver. If the receiver does not contain anElement, answer 0." ^ self indexOf: anElement ifAbsent: [0]! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'! indexOf: anElement ifAbsent: exceptionBlock "Answer the index of the first occurence of anElement within the receiver. If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock." ^ self indexOf: anElement startingAt: 1 ifAbsent: exceptionBlock! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'sma 6/1/2000 15:47'! indexOf: anElement startingAt: start ifAbsent: exceptionBlock "Answer the index of the first occurence of anElement after start within the receiver. If the receiver does not contain anElement, answer the result of evaluating the argument, exceptionBlock." start to: self size do: [:index | (self at: index) = anElement ifTrue: [^ index]]. ^ exceptionBlock value! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'di 6/2/2000 09:15'! last "Answer the last element of the receiver. Raise an error if the collection is empty." | size | (size _ self size) = 0 ifTrue: [self errorEmptyCollection]. ^ self at: size! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'ar 1/20/98 16:22'! replaceAll: oldObject with: newObject "Replace all occurences of oldObject with newObject" | index | index _ self indexOf: oldObject startingAt: 1 ifAbsent: [0]. [index = 0] whileFalse: [self at: index put: newObject. index _ self indexOf: oldObject startingAt: index + 1 ifAbsent: [0]]! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'jm 6/20/2003 10:02'! second "Answer the second element of the receiver." ^ self at: 2 ! ! !SequenceableCollection methodsFor: 'accessing' stamp: 'jm 6/20/2003 10:02'! third "Answer the third element of the receiver." ^ self at: 3 ! ! !SequenceableCollection methodsFor: 'testing' stamp: 'sma 5/12/2000 14:08'! includes: anObject "Answer whether anObject is one of the receiver's elements." ^ (self indexOf: anObject) ~= 0! ! !SequenceableCollection methodsFor: 'comparing' stamp: 'sma 5/12/2000 14:04'! = otherCollection "Answer true if the receiver is equivalent to the otherCollection. First test for identity, then rule out different species and sizes of collections. As a last resort, examine each element of the receiver and the otherCollection." self == otherCollection ifTrue: [^ true]. self species == otherCollection species ifFalse: [^ false]. ^ self hasEqualElements: otherCollection! ! !SequenceableCollection methodsFor: 'comparing' stamp: 'sma 5/12/2000 14:04'! hasEqualElements: otherCollection "Answer whether the receiver's size is the same as otherCollection's size, and each of the receiver's elements equal the corresponding element of otherCollection. This should probably replace the current definition of #= ." | size | (size _ self size) = otherCollection size ifFalse: [^ false]. 1 to: size do: [:index | (self at: index) = (otherCollection at: index) ifFalse: [^ false]]. ^ true! ! !SequenceableCollection methodsFor: 'comparing' stamp: 'di 11/24/1999 20:30'! hash "Answer an integer hash value for the receiver such that, -- the hash value of an unchanged object is constant over time, and -- two equal objects have equal hash values." | size | (size _ self size) = 0 ifTrue: [^ 17171]. ^ size + (self at: 1) hash + (self at: size) hash! ! !SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer an Array whose elements are the elements of the receiver." ^ Array withAll: self! ! !SequenceableCollection methodsFor: 'converting' stamp: 'sma 5/12/2000 17:36'! asByteArray "Answer a ByteArray whose elements are the elements of the receiver." ^ ByteArray withAll: self! ! !SequenceableCollection methodsFor: 'converting' stamp: 'ar 9/14/1998 23:47'! asFloatArray "Answer a FloatArray whose elements are the elements of the receiver, in the same order." | floatArray | floatArray _ FloatArray new: self size. 1 to: self size do:[:i| floatArray at: i put: (self at: i) asFloat ]. ^floatArray! ! !SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:19'! asIntegerArray "Answer an IntegerArray whose elements are the elements of the receiver, in the same order." | intArray | intArray _ IntegerArray new: self size. 1 to: self size do:[:i| intArray at: i put: (self at: i)]. ^intArray! ! !SequenceableCollection methodsFor: 'converting' stamp: 'djm 11/20/1998 05:44'! asStringWithCr "Convert to a string with returns between items. Elements are usually strings. Useful for labels for PopUpMenus." | labelStream | labelStream _ WriteStream on: (String new: 200). self do: [:each | (each isKindOf: String) ifTrue: [labelStream nextPutAll: each; cr] ifFalse: [each printOn: labelStream. labelStream cr]]. self size > 0 ifTrue: [labelStream skip: -1]. ^ labelStream contents! ! !SequenceableCollection methodsFor: 'converting' stamp: 'ar 10/10/1998 16:20'! asWordArray "Answer a WordArray whose elements are the elements of the receiver, in the same order." | wordArray | wordArray _ WordArray new: self size. 1 to: self size do:[:i| wordArray at: i put: (self at: i)]. ^wordArray! ! !SequenceableCollection methodsFor: 'converting' stamp: 'jm 4/27/98 04:09'! reversed "Answer a copy of the receiver with element order reversed." "Example: 'frog' reversed" | n result src | n _ self size. result _ self species new: n. src _ n + 1. 1 to: n do: [:i | result at: i put: (self at: (src _ src - 1))]. ^ result ! ! !SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:07'! copyEmpty ^ self species new: 0! ! !SequenceableCollection methodsFor: 'copying' stamp: 'sma 6/1/2000 16:00'! copyUpTo: anElement "Answer all elements up to but not including anObject. If there is no such object, answer a copy of the receiver." ^ self first: (self indexOf: anElement ifAbsent: [^ self copy]) - 1! ! !SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/22/2000 18:01'! forceTo: length paddingWith: elem "Force the length of the collection to length, padding if necessary with elem. Note that this makes a copy." | newCollection copyLen | newCollection _ self species new: length. copyLen _ self size min: length. newCollection replaceFrom: 1 to: copyLen with: self startingAt: 1. newCollection from: copyLen + 1 to: length put: elem. ^ newCollection! ! !SequenceableCollection methodsFor: 'copying' stamp: 'sma 5/12/2000 12:36'! shuffled ^ self shuffledBy: Collection randomForPicking "Examples: ($A to: $Z) shuffled "! ! !SequenceableCollection methodsFor: 'copying' stamp: 'djp 10/23/1999 22:12'! shuffledBy: aRandom | copy | copy _ self shallowCopy. copy size to: 1 by: -1 do: [:i | copy swap: i with: ((1 to: i) atRandom: aRandom)]. ^ copy! ! !SequenceableCollection methodsFor: 'copying' stamp: 'sma 4/28/2000 18:34'! sortBy: aBlock "Create a copy that is sorted. Sort criteria is the block that accepts two arguments. When the block is true, the first arg goes first ([:a :b | a > b] sorts in descending order)." ^ (self asSortedCollection: aBlock) asOrderedCollection! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:46'! 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 size. 1 to: self size do: [:index | newCollection at: index put: (aBlock value: (self at: index))]. ^ newCollection! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 11:47'! collect: aBlock from: firstIndex to: lastIndex "Refer to the comment in Collection|collect:." | size result j | size _ lastIndex - firstIndex + 1. result _ self species new: size. j _ firstIndex. 1 to: size do: [:i | result at: i put: (aBlock value: (self at: j)). j _ j + 1]. ^ result! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'! findBinaryIndex: aBlock "Search for an element in the receiver using binary search. The argument aBlock is a one-element block returning 0 - if the element is the one searched for <0 - if the search should continue in the first half >0 - if the search should continue in the second half If no matching element is found, raise an error. Examples: #(1 3 5 7 11 15 23) findBinaryIndex:[:arg| 11 - arg] " ^self findBinaryIndex: aBlock ifNone: [self errorNotFound: aBlock]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'ar 6/3/2000 15:54'! findBinaryIndex: aBlock ifNone: exceptionBlock "Search for an element in the receiver using binary search. The argument aBlock is a one-element block returning 0 - if the element is the one searched for <0 - if the search should continue in the first half >0 - if the search should continue in the second half If no matching element is found, evaluate exceptionBlock." | index low high test | low _ 1. high _ self size. [index _ high + low // 2. low > high] whileFalse:[ test _ aBlock value: (self at: index). test = 0 ifTrue:[^index] ifFalse:[test > 0 ifTrue: [low _ index + 1] ifFalse: [high _ index - 1]]]. ^exceptionBlock value! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 5/12/2000 18:13'! keysAndValuesDo: aBlock "Enumerate the receiver with all the keys (aka indices) and values." 1 to: self size do: [:index | aBlock value: index value: (self at: index)]! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'di 11/12/1998 15:01'! pairsDo: aBlock "Evaluate aBlock with my elements taken two at a time. If there's an odd number of items, ignore the last one. Allows use of a flattened array for things that naturally group into pairs. See also pairsCollect:" 1 to: self size // 2 do: [:index | aBlock value: (self at: 2 * index - 1) value: (self at: 2 * index)] " #(1 'fred' 2 'charlie' 3 'elmer') pairsDo: [:a :b | Transcript cr; show: b, ' is number ', a printString] "! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'sma 6/1/2000 16:00'! upTo: anObject "Deprecated. Use copyUpTo:" ^ self copyUpTo: anObject! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/31/1999 13:13'! with: otherCollection collect: twoArgBlock "Collect and return the result of evaluating twoArgBlock with corresponding elements from this collection and otherCollection." | result | otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. result _ self species new: self size. 1 to: self size do: [:index | result at: index put: (twoArgBlock value: (self at: index) value: (otherCollection at: index))]. ^ result! ! !SequenceableCollection methodsFor: 'enumerating' stamp: 'di 8/3/1999 15:26'! with: otherCollection do: twoArgBlock "Evaluate twoArgBlock with corresponding elements from this collection and otherCollection." otherCollection size = self size ifFalse: [self error: 'otherCollection must be the same size']. 1 to: self size do: [:index | twoArgBlock value: (self at: index) value: (otherCollection at: index)]! ! !SequenceableCollection methodsFor: 'private' stamp: 'sma 5/12/2000 11:33'! anyOne ^ self first! ! !SequentialSound methodsFor: 'accessing' stamp: 'jm 8/17/1998 14:04'! duration "Answer the duration of this sound in seconds." | dur | dur _ 0. sounds do: [:snd | dur _ dur + snd duration]. ^ dur ! ! !SequentialSound methodsFor: 'composition' stamp: 'jm 4/14/1999 10:05'! pruneFinishedSounds "Remove any sounds that have been completely played." | newSnds | (currentIndex > 1 and: [currentIndex < sounds size]) ifFalse: [^ self]. newSnds _ sounds copyFrom: currentIndex to: sounds size. currentIndex _ 1. sounds _ newSnds. ! ! !SerialPort methodsFor: 'open/close' stamp: 'jm 10/21/2002 15:55'! isOpen "Return true iff the serial port is open." "Details: Try to read zero bytes. If the read primitive fails because the port is not open, it will return nil. If the port is open, the primitive will return 0." | buf n | port ifNil: [^ false]. buf _ ByteArray new: 1. n _ self primNoErrorReadPort: port into: buf startingAt: 1 count: 0. ^ n notNil ! ! !SerialPort methodsFor: 'open/close' stamp: 'jm 1/8/2003 17:28'! openPort: portNumber "Open the given serial port, using the settings specified by my instance variables." self openPort: portNumber ifFail: [self error: 'could not open serial port ', portNumber printString]. ! ! !SerialPort methodsFor: 'open/close' stamp: 'jm 1/8/2003 17:28'! openPort: portNumber ifFail: failBlock "Open the given serial port, using the settings specified by my instance variables. If the port cannot be opened, such as when it is alreay in use, return the result of evaluating failBlock." self close. self primClosePort: portNumber. (self primOpenPort: portNumber baudRate: baudRate stopBitsType: stopBitsType parityType: parityType dataBits: dataBits inFlowControlType: inputFlowControlType outFlowControlType: outputFlowControlType xOnByte: xOnByte xOffByte: xOffByte) isNil ifTrue: [^ failBlock value]. port _ portNumber. ! ! !SerialPort methodsFor: 'input/output' stamp: 'jm 1/8/2003 12:55'! flushInputBuffer "Read and discard bytes until there are no more bytes in the input buffer." | buf | buf _ ByteArray new: 1000. [(self primReadPort: port into: buf startingAt: 1 count: buf size) > 0] whileTrue: ["keep reading"]. ! ! !SerialPort methodsFor: 'input/output' stamp: 'jm 1/8/2003 12:58'! next: byteCount "Answer a ByteArray of length byteCount with the next byteCount bytes read from this port. Wait indefinitely until enough bytes arrive." | buf i count | buf _ ByteArray new: byteCount. i _ 1. [i <= byteCount] whileTrue: [ count _ self readInto: buf startingAt: i. i _ i + count]. ^ buf ! ! !SerialPort methodsFor: 'input/output' stamp: 'jm 9/23/2000 21:12'! nextPutAll: aStringOrByteArray "Send the given bytes out this serial port. The port must be open." ^ self primWritePort: port from: aStringOrByteArray startingAt: 1 count: aStringOrByteArray size. ! ! !SerialPort methodsFor: 'input/output' stamp: 'jm 1/8/2003 12:51'! readBytes: byteCount "Answer a ByteArray of length byteCount with the next byteCount bytes read from this port. Wait indefinitely until byteCount bytes arrive." | buf i count | buf _ ByteArray new: byteCount. i _ 1. [i <= byteCount] whileTrue: [ count _ self readInto: buf startingAt: i. i _ i + count]. ^ buf ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 10/24/2000 17:53'! primClosePort: portNumber "Try to close the given port. Do nothing if the primitive fails." <primitive: 239> ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 11/1/2003 12:27'! primNewClosePort: portNumber "Try to close the given port. Do nothing if the primitive fails." <primitive: 'primClose' module: 'SerialPort2'> ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 11/1/2003 12:27'! primNewOpenPort: portNumber baudRate: baud stopBitsType: stop parityType: parity dataBits: numDataBits inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl xOnByte: xOn xOffByte: xOff <primitive: 'primOpen' module: 'SerialPort2'> ^ nil ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 10/21/2002 15:43'! primNoErrorReadPort: portNumber into: byteArray startingAt: startIndex count: count <primitive: 'primitiveSerialPortRead' module: 'SerialPlugin'> ^ nil ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 1/8/2003 17:25'! primOpenPort: portNumber baudRate: baud stopBitsType: stop parityType: parity dataBits: numDataBits inFlowControlType: inFlowCtrl outFlowControlType: outFlowCtrl xOnByte: xOn xOffByte: xOff <primitive: 238> ^ nil ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 10/24/2000 22:37'! primReadPort: portNumber into: byteArray startingAt: startIndex count: count <primitive: 241> ^ 0 ! ! !SerialPort methodsFor: 'primitives' stamp: 'jm 10/24/2000 22:37'! primWritePort: portNumber from: byteArray startingAt: startIndex count: count <primitive: 240> ^ 0 ! ! !SerialPort class methodsFor: 'as yet unclassified' stamp: 'jm 11/1/2003 12:29'! primPortCount "Answer the number of available serial ports. Answer 0 if this primitive is not implemented." "self primPortCount" <primitive: 'primPortCount' module: 'SerialPort2'> ^ 0 ! ! !SerialPort class methodsFor: 'as yet unclassified' stamp: 'jm 11/1/2003 19:55'! primPortName: portNum "Answer the number of available serial ports. Answer nil if the port number is out of range or if this primitive is not implemented." "self primPortName: 3" <primitive: 'primPortName' module: 'SerialPort2'> ^ nil ! ! !Set methodsFor: 'adding' stamp: 'sma 5/12/2000 17:28'! add: newObject "Include newObject as one of the receiver's elements, but only if not already present. Answer newObject." | index | newObject ifNil: [self error: 'Sets cannot meaningfully contain nil as an element']. index _ self findElementOrNil: newObject. (array at: index) ifNil: [self atNewIndex: index put: newObject]. ^ newObject! ! !Set methodsFor: 'converting' stamp: 'ar 11/20/1998 16:34'! asSet ^self! ! !Set methodsFor: 'copying' stamp: 'sma 5/12/2000 14:54'! copy ^ self shallowCopy withArray: array shallowCopy! ! !Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 11:49'! 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." | newSet | newSet _ Set new: self size. array do: [:each | each ifNotNil: [newSet add: (aBlock value: each)]]. ^ newSet! ! !Set methodsFor: 'enumerating' stamp: 'sma 5/12/2000 14:36'! do: aBlock tally = 0 ifTrue: [^ self]. 1 to: array size do: [:index | | each | (each _ array at: index) ifNotNil: [aBlock value: each]]! ! !Set methodsFor: 'removing' stamp: 'sma 5/12/2000 14:45'! copyWithout: oldElement "Answer a copy of the receiver that does not contain any elements equal to oldElement." ^ self copy remove: oldElement ifAbsent: []; yourself! ! !Set methodsFor: 'testing' stamp: 'bf 3/16/2000 18:06'! hasContentsInExplorer ^self isEmpty not! ! !Set methodsFor: 'testing' stamp: 'sma 5/12/2000 14:46'! occurrencesOf: anObject ^ (self includes: anObject) ifTrue: [1] ifFalse: [0]! ! I provide synchronized communication of arbitrary objects between Processes. An object is sent by sending the message nextPut: and received by sending the message next. If no object has been sent when a next message is sent, the Process requesting the object will be suspended until one is sent.! !SharedQueue methodsFor: 'private' stamp: 'sma 4/22/2000 18:04'! makeRoomAtEnd | contentsSize | readPosition = 1 ifTrue: [contentsArray _ contentsArray , (Array new: 10)] ifFalse: [contentsSize _ writePosition - readPosition. "BLT direction ok for this. Lots faster!!!!!!!!!!!! SqR!!!! 4/10/2000 10:47" contentsArray replaceFrom: 1 to: contentsSize with: contentsArray startingAt: readPosition. readPosition _ 1. writePosition _ contentsSize + 1]! ! I am a simple button with a string label. I can have a target object, selector, and optional argument list so that when I'm activated I can send the target a specific message. I can act either on mouse-down or mouse-up. ! !SimpleButtonMorph methodsFor: 'initialization' stamp: 'jm 10/4/2002 08:40'! adaptToWorld: aWorld super adaptToWorld: aWorld. target isMorph ifTrue: [ target isWorldMorph ifTrue: [self target: aWorld]. target isHandMorph ifTrue: [self target: aWorld primaryHand]]. ! ! !SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:08'! initialize self initializeAllButLabel; setDefaultLabel! ! !SimpleButtonMorph methodsFor: 'initialization' stamp: 'jm 10/13/2002 17:37'! initializeAllButLabel super initialize. self borderWidth: 1. self cornerStyle: #rounded. self color: (Color r: 0.4 g: 0.8 b: 0.6). self borderColor: self color darker. target _ nil. actionSelector _ #flash. arguments _ Array empty. actWhen _ #buttonUp ! ! !SimpleButtonMorph methodsFor: 'initialization' stamp: 'di 6/5/2000 09:09'! initializeWithLabel: labelString self initializeAllButLabel; label: labelString ! ! !SimpleButtonMorph methodsFor: 'initialization' stamp: 'sw 9/28/1999 14:05'! setDefaultLabel self label: 'Flash'. ! ! !SimpleButtonMorph methodsFor: 'menu' stamp: 'sw 9/28/1999 20:42'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. self addLabelItemsTo: aCustomMenu hand: aHandMorph. (target isKindOf: BookMorph) ifTrue: [aCustomMenu add: 'set page sound' action: #setPageSound:. aCustomMenu add: 'set page visual' action: #setPageVisual:] ifFalse: [aCustomMenu add: 'change action selector' action: #setActionSelector. aCustomMenu add: 'change arguments' action: #setArguments. aCustomMenu add: 'change when to act' action: #setActWhen. ((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [aCustomMenu add: 'set target' action: #setTarget:]]. ! ! !SimpleButtonMorph methodsFor: 'menu' stamp: 'sw 9/28/1999 20:41'! addLabelItemsTo: aCustomMenu hand: aHandMorph aCustomMenu add: 'change label' action: #setLabel ! ! !SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageSound: event ^ target menuPageSoundFor: self event: event! ! !SimpleButtonMorph methodsFor: 'menu' stamp: 'di 12/20/1998 16:55'! setPageVisual: event ^ target menuPageVisualFor: self event: event! ! !SimpleButtonMorph methodsFor: 'accessing' stamp: 'jm 11/6/2003 08:23'! fitContents | oldCenter m | submorphs size = 0 ifTrue: [^ self]. oldCenter _ self center. m _ submorphs first. self extent: m extent + (borderWidth + 6). self center: oldCenter. m position: oldCenter - (m extent // 2). ! ! !SimpleButtonMorph methodsFor: 'accessing' stamp: 'jm 11/6/2003 08:21'! label: aString self label: aString font: TextStyle defaultFont. ! ! !SimpleButtonMorph methodsFor: 'accessing' stamp: 'jm 11/6/2003 08:26'! label: aString font: aFont | oldLabel m | (oldLabel _ self findA: StringMorph) ifNotNil: [oldLabel delete]. m _ StringMorph contents: aString font: (aFont ifNil: [Preferences standardButtonFont]). self extent: m extent + (borderWidth + 6). m position: self center - (m extent // 2). self addMorph: m. m lock. ! ! !SimpleButtonMorph methodsFor: 'accessing' stamp: 'sw 6/11/1999 18:40'! labelString: aString | existingLabel | (existingLabel _ self findA: StringMorph) ifNil: [self label: aString] ifNotNil: [existingLabel contents: aString. self fitContents] ! ! !SimpleButtonMorph methodsFor: 'events' stamp: 'di 5/23/2000 16:17'! mouseDown: evt | now dt | oldColor _ color. now _ Time millisecondClockValue. actWhen == #buttonDown ifTrue: [self doButtonAction]. dt _ Time millisecondClockValue - now max: 0. "Time it took to do" dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait] ! ! !SimpleButtonMorph methodsFor: 'events' stamp: 'jm 8/11/2003 20:57'! mouseMove: evt actWhen == #buttonDown ifTrue: [^ self]. (self containsPoint: evt cursorPoint) ifTrue: [ oldColor ifNotNil: [ self color: (oldColor mixed: 1/2 with: Color white)]. (actWhen == #whilePressed and: [evt anyButtonPressed]) ifTrue: [self doButtonAction]] ifFalse: [oldColor ifNotNil: [self color: oldColor]]. ! ! !SimpleButtonMorph methodsFor: 'events' stamp: 'sma 4/22/2000 17:29'! mouseUp: evt oldColor ifNotNil: ["if oldColor nil, it signals that mouse had not gone DOWN inside me, e.g. because of a cmd-drag; in this case we want to avoid triggering the action!!" self color: oldColor. oldColor _ nil. (actWhen == #buttonUp and: [self containsPoint: evt cursorPoint]) ifTrue: [self doButtonAction]]! ! !SimpleButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:01'! includeInNewMorphMenu ^ true ! ! !SimpleButtonMorph class methodsFor: 'instance creation' stamp: 'di 6/5/2000 08:42'! newWithLabel: labelString ^ self basicNew initializeWithLabel: labelString ! ! This class supports client for simple network protocols based on sending textual commands and responses. Examples of such protocols include POP3 (mail retrieval), SMTP (mail posting), HTTP (web browsing), and NTTP (network news). Some simple examples are presented as class methods, but a full-service client of some service should be implemented as a subclass. The basic services provided by this class are: sendCommand: -- sends a command line terminate with <CR><LF> getResponse -- gets a single-line response to a command getMultilineResponse -- gets a multiple line response terminated by a period -- on a line by itself There are variants of the getResponse commands that display lines on the screen as they are being received. Linefeeds are stripped out of all responses. The 'get' commands above make use of an internal buffer. So intermixing these two commands and regular Socket recieve commands can cause problems.! !SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'di 4/13/1999 14:43'! displayString: aString "Display the given string on the Display. Used for testing." | s | aString isEmpty ifTrue: [^ self]. aString size > 60 ifTrue: [s _ aString copyFrom: 1 to: 60] "limit to 60 characters" ifFalse: [s _ aString]. s displayOn: Display. ! ! !SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:34'! getMultilineResponseShowing: showFlag "Get a multiple line response to the last command. A multiple line response ends with a line containing only a single period (.) character. Linefeed characters are filtered out. If showFlag is true, each line is shown in the upper-left corner of the Display as it is received." | response done chunk | response _ WriteStream on: ''. done _ false. [done] whileFalse: [ showFlag ifTrue: [chunk _ self getResponseShowing: true] ifFalse: [chunk _ self getResponse]. (chunk beginsWith: '.') ifTrue: [ response nextPutAll: (chunk copyFrom: 2 to: chunk size) ] ifFalse: [ response nextPutAll: chunk ]. done _ (chunk = ('.', String cr)) ]. ^ response contents ! ! !SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 02:10'! getResponse "Get a one-line response from the server. The final LF is removed from the line, but the CR is left, so that the line is in Squeak's text format" ^ self getResponseShowing: false ! ! !SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'ls 9/11/1998 03:27'! getResponseShowing: showFlag | line idx | line _ WriteStream on: String new. buffer ifNil: [ buffer _ String new. bufferPos _ 0 ]. [ "look for a LF in the buffer" idx _ buffer indexOf: Character lf startingAt: bufferPos+1 ifAbsent: [ 0 ]. idx > 0 ifTrue: [ "found it!! we have a line" line nextPutAll: (buffer copyFrom: bufferPos+1 to: idx-1). bufferPos _ idx. ^line contents ]. "didn't find it. add the whole buffer to the line, and retrieve some more data" line nextPutAll: (buffer copyFrom: bufferPos+1 to: buffer size). bufferPos _ 0. buffer _ String new. self waitForDataQueryingUserEvery: 30. buffer _ self getData. true ] whileTrue.! ! !SimpleClientSocket methodsFor: 'as yet unclassified' stamp: 'jm 9/16/1998 14:37'! waitForDataQueryingUserEvery: seconds "Wait for data to arrive, asking the user periodically if they wish to keep waiting. If they don't wish to keep waiting, destroy the socket and raise an error." | gotData | gotData _ false. [gotData] whileFalse: [ gotData _ self waitForDataUntil: (Socket deadlineSecs: seconds). gotData ifFalse: [ self isConnected ifFalse: [ self destroy. self error: 'server closed connection']. (self confirm: 'server not responding; keep trying?') ifFalse: [ self destroy. self error: 'no response from server']]]. ! ! !SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'di 4/13/1999 14:42'! remoteCursorReceiver "Wait for a connection, then display data sent by the client until the client closes the stream. This server process is usually started first (optionally in a forked process), then the sender process is started (optionally on another machine). Note this machine's address, which is printed in the transcript, since the sender process will ask for it." "[SimpleClientSocket remoteCursorReceiver] fork" | sock response | Transcript show: 'starting remote cursor receiver'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. Transcript show: 'my address is ', NetNameResolver localAddressString; cr. Transcript show: 'opening connection'; cr. sock _ SimpleClientSocket new. sock listenOn: 54323. sock waitForConnectionUntil: (Socket deadlineSecs: 60). sock isConnected ifFalse: [ sock destroy. Transcript show: 'remote cursor receiver did not receive a connection in 60 seconds; aborting.'. ^ self]. Transcript show: 'connection established'; cr. [sock isConnected] whileTrue: [ sock dataAvailable ifTrue: [ response _ sock getResponse. response displayOn: Display at: 10@10] ifFalse: [ "if no data available, let other processes run for a while" (Delay forMilliseconds: 20) wait]]. sock destroy. Transcript show: 'remote cursor receiver done'; cr. ! ! !SimpleClientSocket class methodsFor: 'remote cursor example' stamp: 'di 4/13/1999 14:43'! remoteCursorTest "This version of the remote cursor test runs both the client and the server code in the same loop." "SimpleClientSocket remoteCursorTest" | sock1 sock2 samplesToSend samplesSent done t | Transcript show: 'starting remote cursor test'; cr. Transcript show: 'initializing network'; cr. Socket initializeNetwork. Transcript show: 'opening connection'; cr. sock1 _ SimpleClientSocket new. sock2 _ SimpleClientSocket new. sock1 listenOn: 54321. sock2 connectTo: (NetNameResolver localHostAddress) port: 54321. sock1 waitForConnectionUntil: self standardDeadline. sock2 waitForConnectionUntil: self standardDeadline. (sock1 isConnected) ifFalse: [self error: 'sock1 not connected']. (sock2 isConnected) ifFalse: [self error: 'sock2 not connected']. Transcript show: 'connection established'; cr. samplesToSend _ 100. t _ Time millisecondsToRun: [ samplesSent _ 0. done _ false. [done] whileFalse: [ (sock1 sendDone and: [samplesSent < samplesToSend]) ifTrue: [ sock1 sendCommand: self sensorStateString. samplesSent _ samplesSent + 1]. sock2 dataAvailable ifTrue: [ sock2 getResponse displayOn: Display at: 10@10]. done _ samplesSent = samplesToSend]]. sock1 destroy. sock2 destroy. Transcript show: 'remote cursor test done'; cr. Transcript show: samplesSent printString, ' samples sent in ', t printString, ' milliseconds'; cr. Transcript show: ((samplesSent * 1000) // t) printString, ' samples/sec'; cr. ! ! !SimpleClientSocket class methodsFor: 'other examples' stamp: 'jm 6/8/1998 16:05'! httpTestHost: hostName port: port url: url "This test fetches a URL from the given host and port." "SimpleClientSocket httpTestHost: 'www.disney.com' port: 80 url: '/'" "Tests URL fetch through a local HTTP proxie server: (SimpleClientSocket httpTestHost: '127.0.0.1' port: 8080 url: 'HTTP://www.exploratorium.edu/index.html')" | hostAddr s result buf bytes totalBytes t | Transcript cr; show: 'starting http test'; cr. Socket initializeNetwork. hostAddr _ NetNameResolver addressForName: hostName timeout: 10. hostAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', hostName]. s _ SimpleClientSocket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: hostAddr port: port. s waitForConnectionUntil: "self standardDeadline" (Socket deadlineSecs: 10). (s isConnected) ifFalse: [ s destroy. ^ self inform: 'could not connect']. Transcript show: 'connection open; waiting for data'; cr. s sendCommand: 'GET ', url, ' HTTP/1.0'. s sendCommand: 'User-Agent: Squeak 1.19'. s sendCommand: 'ACCEPT: text/html'. "always accept plain text" s sendCommand: 'ACCEPT: application/octet-stream'. "also accept binary data" s sendCommand: ''. "blank line" result _ WriteStream on: (String new: 10000). buf _ String new: 10000. totalBytes _ 0. t _ Time millisecondsToRun: [ [s isConnected] whileTrue: [ s waitForDataUntil: (Socket deadlineSecs: 5). bytes _ s receiveDataInto: buf. 1 to: bytes do: [:i | result nextPut: (buf at: i)]. totalBytes _ totalBytes + bytes. Transcript show: totalBytes printString, ' bytes received'; cr]]. s destroy. Transcript show: '---------- Connection Closed ----------'; cr; endEntry. Transcript show: 'http test done; ', totalBytes printString, ' bytes read in '. Transcript show: ((t / 1000.0) roundTo: 0.01) printString, ' seconds'; cr. Transcript show: ((totalBytes asFloat / t) roundTo: 0.01) printString, ' kBytes/sec'; cr. Transcript endEntry. (StringHolder new contents: (result contents)) openLabel: 'HTTP Test Result: URL Contents'. ! ! This is a first cut at a simple MIDI output port. ! !SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:10'! close "Close this MIDI port." portNumber ifNotNil: [self primMIDIClosePort: portNumber]. accessSema _ nil. lastCommandByteOut _ nil. ! ! !SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:23'! ensureOpen "Make sure this MIDI port is open. It is good to call this before starting to use a port in case an intervening image save/restore has caused the underlying hardware port to get closed." portNumber ifNil: [^ self error: 'Use "openOn:" to open a MIDI port initially']. self primMIDIClosePort: portNumber. self primMIDIOpenPort: portNumber readSemaIndex: 0 interfaceClockRate: InterfaceClockRate. accessSema _ Semaphore forMutualExclusion. lastCommandByteOut _ Array new: 16 withAll: 0. "clear running status" ! ! !SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 1/13/1999 08:09'! openOnPortNumber: portNum "Open this MIDI port on the given port number." self close. portNumber _ portNum. accessSema _ Semaphore forMutualExclusion. self ensureOpen. ! ! !SimpleMIDIPort methodsFor: 'open/close' stamp: 'jm 10/12/1998 15:48'! portNumber "Answer my port number." ^ portNumber ! ! !SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'! midiCmd: cmd channel: channel byte: dataByte "Immediately output the given MIDI command with the given channel and argument byte to this MIDI port. Assume that the port is open." accessSema critical: [ self primMIDIWritePort: portNumber from: (ByteArray with: (cmd bitOr: channel) with: dataByte) at: 0]. ! ! !SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'! midiCmd: cmd channel: channel byte: dataByte1 byte: dataByte2 "Immediately output the given MIDI command with the given channel and argument bytes to this MIDI port. Assume that the port is open." accessSema critical: [ self primMIDIWritePort: portNumber from: (ByteArray with: (cmd bitOr: channel) with: dataByte1 with: dataByte2) at: 0]. ! ! !SimpleMIDIPort methodsFor: 'output' stamp: 'jm 9/28/1998 22:00'! midiOutput: aByteArray "Output the given bytes to this MIDI port immediately. Assume that the port is open." accessSema critical: [ self primMIDIWritePort: portNumber from: aByteArray at: 0]. ! ! !SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/8/1998 19:47'! bufferTimeStampFrom: aByteArray "Return the timestamp from the given MIDI input buffer. Assume the given buffer is at least 4 bytes long." ^ ((aByteArray at: 1) bitShift: 24) + ((aByteArray at: 2) bitShift: 16) + ((aByteArray at: 3) bitShift: 8) + (aByteArray at: 4) ! ! !SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/8/1998 19:53'! flushInput "Read any lingering MIDI data from this port's input buffer." | buf | buf _ ByteArray new: 1000. [(self readInto: buf) > 0] whileTrue. ! ! !SimpleMIDIPort methodsFor: 'input' stamp: 'jm 10/12/1998 15:49'! readInto: aByteArray "Read any data from this port into the given buffer." ^ self primMIDIReadPort: portNumber into: aByteArray ! ! !SimpleMIDIPort methodsFor: 'primitives' stamp: 'jm 10/12/1998 16:04'! primMIDIClosePort: portNum "Close the given MIDI port. Don't fail if port is already closed." <primitive: 521> ! ! !SimpleMIDIPort methodsFor: 'primitives' stamp: 'jm 9/10/1998 15:11'! primMIDIOpenPort: portNum readSemaIndex: readSemaIndex interfaceClockRate: interfaceClockRate "Open the given MIDI port. If non-zero, readSemaIndex specifies the index in the external objects array of a semaphore to be signalled when incoming MIDI data is available. Not all platforms support signalling the read semaphore. InterfaceClockRate specifies the clock rate of the external MIDI interface adaptor on Macintosh computers; it is ignored on other platforms." <primitive: 526> self primitiveFailed. ! ! !SimpleMIDIPort methodsFor: 'primitives' stamp: 'jm 10/8/1998 19:48'! primMIDIReadPort: portNum into: byteArray "Read any available MIDI data into the given buffer (up to the size of the buffer) and answer the number of bytes read." <primitive: 528> self primitiveFailed. ! ! !SimpleMIDIPort methodsFor: 'primitives' stamp: 'jm 10/8/1998 19:49'! primMIDIWritePort: portNum from: byteArray at: midiClockValue "Queue the given data to be sent through the given MIDI port at the given time. If midiClockValue is zero, send the data immediately." <primitive: 529> self primitiveFailed. ! ! !SimpleMIDIPort class methodsFor: 'class initialization' stamp: 'jm 9/10/1998 15:33'! initialize "SimpleMIDIPort initialize" InterfaceClockRate _ 1000000. DefaultPortNumber _ 0. ! ! !SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'jm 9/10/1998 18:36'! openDefault "Answer a new instance of me opened on the default MIDI port." ^ self openOnPortNumber: DefaultPortNumber ! ! !SimpleMIDIPort class methodsFor: 'instance creation' stamp: 'tk 6/24/1999 11:42'! openOnPortNumber: portNum "Answer a new instance of me for the given MIDI port number." "Details: All clients of a particular MIDI port should share the same instance of me. This allows accesses to the port to be serialized and shared port-related state state to be maintained." SimpleMIDIPort allSubInstancesDo: [:p | p portNumber = portNum ifTrue: [ "share the existing port object for this port number" ^ p]]. ^ super new openOnPortNumber: portNum ! ! !SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 1/13/1999 08:11'! closeAllPorts "Close all MIDI ports." "SimpleMIDIPort closeAllPorts" | lastPortNum | lastPortNum _ self primPortCount - 1. 0 to: lastPortNum do: [:portNum | self basicNew primMIDIClosePort: portNum]. ! ! !SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:57'! inputPortNumFromUser "Prompt the user for a MIDI input port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform." "SimpleMIDIPort inputPortNumFromUser" | portCount aMenu dir | portCount _ self primPortCount. portCount = 0 ifTrue: [^ nil]. aMenu _ CustomMenu new title: 'MIDI port for input:'. 0 to: portCount - 1 do:[:i | dir _ self primPortDirectionalityOf: i. (dir = 1) | (dir = 3) ifTrue:[ aMenu add: (self portDescription: i) action: i]]. ^ aMenu startUp ! ! !SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 18:10'! midiIsSupported "Answer true if this platform supports MIDI." ^ self primPortCount > 0 ! ! !SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:58'! outputPortNumFromUser "Prompt the user for a MIDI output port. Answer a port number, or nil if the user does not select a port or if MIDI is not supported on this platform." "SimpleMIDIPort outputPortNumFromUser" | portCount aMenu dir | portCount _ self primPortCount. portCount = 0 ifTrue: [^ nil]. aMenu _ CustomMenu new title: 'MIDI port for output:'. 0 to: portCount - 1 do:[:i | dir _ self primPortDirectionalityOf: i. (dir = 2) | (dir = 3) ifTrue:[ aMenu add: (self portDescription: i) action: i]]. ^ aMenu startUp ! ! !SimpleMIDIPort class methodsFor: 'utilities' stamp: 'jm 10/12/1998 17:46'! portDescription: portNum "Answer a string indicating the directionality of the given MIDI port." "(0 to: SimpleMIDIPort primPortCount - 1) collect: [:i | SimpleMIDIPort portDescription: i]" | portName dir | portName _ self primPortNameOf: portNum. dir _ self primPortDirectionalityOf: portNum. dir = 1 ifTrue: [^ portName, ' (in)']. dir = 2 ifTrue: [^ portName, ' (out)']. dir = 3 ifTrue: [^ portName, ' (in/out)']. ^ self error: 'unknown MIDI port directionality' ! ! !SimpleMIDIPort class methodsFor: 'primitives' stamp: 'jm 10/12/1998 17:22'! primPortCount "Answer the number of MIDI ports supported by this platform, or zero if this primitive is not implemented." <primitive: 523> ^ 0 ! ! !SimpleMIDIPort class methodsFor: 'primitives' stamp: 'jm 10/12/1998 17:27'! primPortDirectionalityOf: portNum "Answer the platform-specific name for the given MIDI port." <primitive: 524> self primitiveFailed. ! ! !SimpleMIDIPort class methodsFor: 'primitives' stamp: 'jm 10/12/1998 17:23'! primPortNameOf: portNum "Answer the platform-specific name for the given MIDI port." <primitive: 525> self primitiveFailed. ! ! I'm a simple slider. I can be either vertical or horizontal, depending on which dimensions is larger. I know my max and min values and I can optionally truncate the values I provide to my target. I have a target object, selector, and optional argument list so that as I'm dragged I can send my target a specific message with the new slider value. ! !SimpleSliderMorph methodsFor: 'initialization' stamp: 'jm 8/4/2003 14:36'! initialize sliderThickness _ 7. super initialize. target _ nil. arguments _ Array empty. minVal _ 0.0. maxVal _ 1.0. truncate _ false. ! ! !SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 8/4/2003 11:47'! sliderThickness ^ sliderThickness ! ! !SimpleSliderMorph methodsFor: 'accessing' stamp: 'jm 8/4/2003 11:47'! sliderThickness: aNumber sliderThickness _ aNumber asFloat truncated. ! ! !SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:39'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'set action selector' action: #setActionSelector. aCustomMenu add: 'change arguments' action: #setArguments. aCustomMenu add: 'set minimum value' action: #setMinVal. aCustomMenu add: 'set maximum value' action: #setMaxVal. aCustomMenu addUpdating: #descendingString action: #toggleDescending. aCustomMenu addUpdating: #truncateString action: #toggleTruncate. ((self world rootMorphsAt: aHandMorph targetOffset) size > 1) ifTrue: [ aCustomMenu add: 'set target' action: #setTarget:]. target ifNotNil: [ aCustomMenu add: 'clear target' action: #clearTarget]. ! ! !SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:38'! descendingString ^ self descending ifTrue: ['switch to ascending'] ifFalse: ['switch to descending']! ! !SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/6/2000 17:13'! setMinVal: newMinVal minVal _ newMinVal asNumber. maxVal _ maxVal max: minVal ! ! !SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 11:40'! toggleDescending descending _ self descending not ! ! !SimpleSliderMorph methodsFor: 'menu' stamp: 'sw 3/12/2000 18:37'! truncateString ^ truncate ifTrue: ['turn off truncation'] ifFalse: ['turn on truncation']! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'TIS 7/11/2003 08:53'! adjustToValue: aNumber | divisor | "Adjust the position of this slider to correspond to the given value in the range minVal..maxVal." "Details: Internal values are normalized to the range 0..1." maxVal = minVal ifTrue: [divisor _ 0.0001] "handles division by 0" ifFalse: [divisor _ maxVal - minVal]. self value: (aNumber - minVal) asFloat / divisor. ! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:48'! getScaledValue | aValue | aValue _ (value * (maxVal - minVal)) + minVal. ^ truncate ifTrue: [aValue truncated] ifFalse: [aValue]! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/6/2000 17:19'! setMaxVal: newMaxVal maxVal _ newMaxVal asNumber. minVal _ maxVal min: minVal ! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/8/2000 16:22'! setScaledValue: aNumber | denom | (denom _ maxVal - minVal) > 0 ifTrue: [self setValue: (aNumber - minVal) / denom] ifFalse: [self setValue: maxVal] "If minVal = maxVal, that value is the only one this (rather unuseful!!) slider can bear"! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:54'! truncate ^ truncate == true! ! !SimpleSliderMorph methodsFor: 'private' stamp: 'sw 3/12/2000 11:53'! truncate: aBoolean truncate _ aBoolean! ! !SimpleSliderMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:04'! includeInNewMorphMenu ^ true ! ! I should perhaps be called 'ToggleButton' morph because I can be used to toggle some target setting between on and off. ! !SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:44'! initialize ^ self initializeWithLabel: 'Toggle' ! ! !SimpleSwitchMorph methodsFor: 'as yet unclassified' stamp: 'di 6/5/2000 08:43'! initializeWithLabel: labelString super initializeWithLabel: labelString. self borderWidth: 3. self extent: self extent + 2. onColor _ Color r: 1.0 g: 0.6 b: 0.6. offColor _ Color lightGray. ! ! !SimpleSwitchMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:05'! includeInNewMorphMenu ^ true ! ! I am a subclass of WaveEditor with fewer buttons and menu commands. ! !SimpleWaveEditor methodsFor: 'all' stamp: 'jm 6/15/2003 19:44'! addControls | slider b r m | b _ SimpleButtonMorph new target: self; borderColor: Color black; useSquareCorners. 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: 'X'; actionSelector: #delete). r addMorphBack: (b fullCopy label: 'Menu'; actWhen: #buttonDown; actionSelector: #invokeMenu). r addMorphBack: (b fullCopy label: 'Play'; actionSelector: #play). r addMorphBack: (b fullCopy label: 'Play Before Cursor'; actionSelector: #playBeforeCursor). r addMorphBack: (b fullCopy label: 'Play After Cursor'; actionSelector: #playAfterCursor). r addMorphBack: (b fullCopy label: 'Save to File'; actionSelector: #saveToFile). self addMorphBack: r. r _ AlignmentMorph newRow. r color: self color; borderWidth: 0; inset: 0. r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; centering: #center. m _ StringMorph new contents: 'Cursor: '. r addMorphBack: m. m _ UpdatingStringMorph new target: graph; getSelector: #cursor; putSelector: #cursor:; growable: false; width: 50; step. r addMorphBack: m. m _ Morph new color: r color; extent: 15@5. "spacer" r addMorphBack: m. m _ StringMorph new contents: 'Value: '. r addMorphBack: m. m _ UpdatingStringMorph new target: graph; getSelector: #valueAtCursor; putSelector: #valueAtCursor:; growable: false; width: 50; step. r addMorphBack: m. m _ Morph new color: r color; extent: 15@5. "spacer" r addMorphBack: m. slider _ SimpleSliderMorph new color: color; extent: 200@2; target: self; actionSelector: #scrollTime:. r addMorphBack: slider. self addMorphBack: r. ! ! !SimpleWaveEditor methodsFor: 'all' stamp: 'jm 6/15/2003 19:30'! addLoopPointControls "Do nothing..." ! ! !SimpleWaveEditor methodsFor: 'all' stamp: 'jm 6/15/2003 20:32'! invokeMenu "Invoke a menu of additonal functions for this WaveEditor." | aMenu | aMenu _ CustomMenu new. aMenu addList: #( ('show envelope' showEnvelope) - ('trim before cursor' trimBeforeCursor) ('trim after cursor' trimAfterCursor) - ('add to instrument library' saveInstrument) ('delete instrument' deleteInstrument) - ('save to file' saveToFile) ('read from file' readFromFile)). aMenu invokeOn: self defaultSelection: nil. ! ! !SimpleWaveEditor class methodsFor: 'instance creation' stamp: 'jm 6/15/2003 19:23'! includeInNewMorphMenu ^ true ! ! Inst vars (converting to morphic events) hostView -- SketchMorph we are working on. stampForm -- Stamp is stored here. canvasRectangle -- later use bounds palette -- the PaintBox interface Morph dirty -- not used currentColor ticksToDwell rotationCenter registrationPoint newPicBlock -- do this after painting action -- selector of painting action paintingForm -- our copy composite -- now paintArea origin. world relative. stop using it. dimForm -- SketchMorph of the dimmed background. Opaque. installed behind the editor morph. buff brush -- 1-bit Form of the brush, paintingFormPen formCanvas -- Aim it at paintingForm to allow it to draw ovals, rectangles, lines, etc. picToComp dimToComp compToDisplay -- used to composite -- obsolete picToBuff brushToBuff buffToBuff buffToPic strokeOrigin -- During Pickup, origin of rect. cumRot cumMag -- cumulative for multiple operations from same original undoBuffer lastEvent currentNib -- 1 bit deep form. For now, we do not carry the SketchMorph's registration point, rotation center, or ticksToDwell. New -- using transform morphs to rotate the finished player. How get it rotated back and the rotationDegrees to be right? We cancel out rotationDegrees, so how remember it? Registration point convention: The registration point is relative to the image's origin, but during painting, it is relative to canvasRectangle origin. ! !SketchEditorMorph methodsFor: 'initialization' stamp: 'jm 10/5/2002 06:47'! initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph | aPaintBox worldBounds requiredWidth aPosition newOrigin newPaintBoxBounds | aPaintBox _ self world paintBox. worldBounds _ self world bounds. requiredWidth _ aPaintBox width. aPosition _ boundsToUse topRight. newOrigin _ ((aPosition x + requiredWidth <= worldBounds right) or: [Preferences unlimitedPaintArea]) ifTrue: "will fit to right of aPasteUpMorph" [aPosition] ifFalse: "won't fit to right, try left" [boundsToUse topLeft - (requiredWidth @ 0)]. newPaintBoxBounds _ (newOrigin extent: aPaintBox extent) translatedToBeWithin: worldBounds. self initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: newPaintBoxBounds origin. ! ! !SketchEditorMorph methodsFor: 'initialization' stamp: 'jm 6/16/2003 23:20'! initializeFor: aSketchMorph inBounds: boundsToUse pasteUpMorph: aPasteUpMorph paintBoxPosition: aPosition "Note: If aPosition is nil, then it's assumed that the paintbox is obtained from a flap or some such, so do nothing special regarding a palette in this case. The palette needs already to be in the world for this to work." | w | (w _ aPasteUpMorph world) addMorphFront: self. hostView _ aSketchMorph. "may be ownerless" self bounds: boundsToUse. canvasRectangle _ bounds. palette _ w paintBox focusMorph: self. aPosition ifNotNil: [w addMorphFront: palette. "bring to front" palette position: aPosition]. paintingForm _ Form extent: bounds extent depth: w assuredCanvas depth. self dimTheWindow. aSketchMorph ifNotNil: [aSketchMorph rotationDegrees: 0. aSketchMorph form displayOn: paintingForm at: (hostView boundsInWorld origin - bounds origin) clippingBox: (0@0 extent: paintingForm extent) rule: Form over fillColor: nil. "assume they are the same depth" rotationCenter _ aSketchMorph rotationCenter]! ! !SketchEditorMorph methodsFor: 'morphic' stamp: 'ar 2/12/2000 18:07'! drawOn: aCanvas "Put the painting on the display" paintingForm ifNotNil: [ aCanvas paintImage: paintingForm at: bounds origin]. ! ! !SketchEditorMorph methodsFor: 'morphic' stamp: 'tk 3/8/1999 23:04'! mouseDown: evt "Start a new stroke. Check if any palette setting have changed. 6/11/97 20:30 tk" | cur | "verify that we are in a good state" self verifyState. "includes prepareToPaint and #scalingOrRotate" undoBuffer _ paintingForm deepCopy. "know we will draw something" paintingFormPen place: (evt cursorPoint - bounds origin). strokeOrigin _ evt cursorPoint. "origin point for pickup: rect: ellispe: polygon: line: star:. Always take it." action == #pickup: ifTrue: [ cur _ Cursor corner clone. cur offset: 0@0 "cur offset abs". evt hand showTemporaryCursor: cur]. action == #polygon: ifTrue: [self polyNew: evt]. "a mode lets you drag vertices" ! ! !SketchEditorMorph methodsFor: 'morphic' stamp: 'kfr 4/26/2000 22:25'! mouseEnter: evt "Set the cursor. Reread colors if embedded editable polygon needs it." | curs poly top | super mouseEnter: evt. top _ evt hand recipientForMouseDown: evt. top == self ifTrue: ["none of my buttons in the way" curs _ palette actionCursor. evt hand showTemporaryCursor: curs. palette getSpecial == #polygon: ifTrue: [(poly _ self valueOfProperty: #polygon) ifNil: [^ self]. currentColor _ palette getColor. poly color: currentColor; borderWidth: 1. poly changed]].! ! !SketchEditorMorph methodsFor: 'morphic' stamp: 'di 9/14/1998 08:07'! mouseEnterDragging: evt "Test button state elsewhere if at all" ^ self mouseEnter: evt! ! !SketchEditorMorph methodsFor: 'morphic' stamp: 'di 9/14/1998 08:08'! mouseLeaveDragging: evt "Test button state elsewhere if at all" ^ self mouseLeave: evt! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'sw 9/2/1999 12:54'! cancelOutOfPainting self deleteSelfAndSubordinates. emptyPicBlock ifNotNil: [emptyPicBlock value]. "note no args to block!!" hostView ifNotNil: [hostView changed]. ^ nil! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'jm 7/4/2003 10:55'! deleteSelfAndSubordinates "Delete the receiver and, if it has one, its subordinate dimForm" self delete. dimForm ifNotNil: [dimForm delete]. palette delete. ! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'jm 6/16/2003 23:11'! deliverPainting: result "Done painting. May come from resume, or from original call. Execute user's post painting instructions in the block. Always use this standard one. 4/21/97 tk" | newBox newForm | palette ifNotNil: "nil happens" [palette setAction: #paint:]. "Get out of odd modes" "rot _ palette getRotations." "rotate with heading, or turn to and fro" "palette setRotation: #normal." result == #cancel ifTrue: [^ self cancelOutOfPainting]. "for Morphic" "hostView rotationStyle: rot." "rotate with heading, or turn to and fro" newBox _ paintingForm rectangleEnclosingPixelsNotOfColor: Color transparent. registrationPoint ifNotNil: [registrationPoint _ registrationPoint - newBox origin]. "relative to newForm origin" newForm _ Form extent: newBox extent depth: paintingForm depth. newForm copyBits: newBox from: paintingForm at: 0@0 clippingBox: newForm boundingBox rule: Form over fillColor: nil. newForm isAllWhite ifTrue: [ (self valueOfProperty: #background) == true ifFalse: [^ self cancelOutOfPainting]]. self delete. "so won't find me again" dimForm delete. palette delete. newPicBlock value: newForm value: (newBox copy translateBy: bounds origin). ! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'di 9/14/1998 07:51'! handlesMouseOverDragging: evt ^true! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 5/25/2000 18:01'! prepareToPaint "Figure out what the current brush, fill, etc is. Return an action to take every mouseMove. Set up instance variable and pens. Prep for normal painting is inlined here. tk 6/14/97 21:11" | specialMode | "Install the brush, color, (replace mode), and cursor." specialMode _ palette getSpecial. currentColor _ palette getColor. brush _ currentNib _ palette getNib. paintingFormPen _ Pen newOnForm: paintingForm. stampForm _ nil. "let go of stamp" formCanvas _ paintingForm getCanvas. "remember to change when undo" formCanvas _ formCanvas copyOrigin: self topLeft negated clipRect: (0@0 extent: bounds extent). specialMode == #paint: ifTrue: [ "get it to one bit depth. For speed, instead of going through a colorMap every time ." brush _ Form extent: brush extent depth: 1. brush offset: (0@0) - (brush extent // 2). currentNib displayOn: brush at: (0@0 - currentNib offset). paintingFormPen sourceForm: brush. paintingFormPen combinationRule: Form paint. paintingFormPen color: currentColor. currentColor isTransparent ifTrue: [ paintingFormPen combinationRule: Form erase1bitShape. paintingFormPen color: Color black]. ^ #paint:]. specialMode == #erase: ifTrue: [ self erasePrep. ^ #erase:]. specialMode == #stamp: ifTrue: [ stampForm _ palette stampForm. "keep it" ^ #stamp:]. (self respondsTo: specialMode) ifTrue: [^ specialMode] "fill: areaFill: pickup: (in mouseUp:) rect: ellipse: line: polygon: star:" ifFalse: ["Don't recognise the command" palette setAction: #paint:. "set it to Paint" ^ self prepareToPaint].! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'ar 5/25/2000 18:01'! undo "revert to a previous state. " | temp poly | undoBuffer ifNil: [^ self beep]. "nothing to go back to" (poly _ self valueOfProperty: #polygon) ifNotNil: [poly delete. self setProperty: #polygon toValue: nil. ^ self]. temp _ paintingForm. paintingForm _ undoBuffer. undoBuffer _ temp. "can get back to what you had by undoing again" paintingFormPen setDestForm: paintingForm. formCanvas _ paintingForm getCanvas. "used for lines, ovals, etc." formCanvas _ formCanvas copyOrigin: self topLeft negated clipRect: (0@0 extent: bounds extent). self render: bounds.! ! !SketchEditorMorph methodsFor: 'start & finish' stamp: 'jm 10/10/2002 15:39'! verifyState "We are sure we will make a mark now. Make sure the palette has not changed state while we were away. If so, end this action and start another one. 6/11/97 19:52 tk action, currentColor, brush" "Install the brush, color, (replace mode), and cursor." palette isInWorld ifFalse: [self world addMorphFront: palette]. "It happens. might want to position it also" action == palette getSpecial ifFalse: [ action == #polygon: ifTrue: [self polyFreeze]. "end polygon mode" ^ action _ self prepareToPaint]. action == #paint: ifTrue: [ currentNib = palette getNib ifFalse: [ currentNib _ palette getNib. "Change the nib on the cursor (Hand)" "get it to one bit depth. For speed, instead of going through a colorMap every time ." brush _ Form extent: currentNib extent depth: 1. brush offset: (0@0) - (brush extent // 2). currentNib displayOn: brush at: (0@0 - currentNib offset). paintingFormPen sourceForm: brush]]. action == #erase: ifFalse: [ currentColor = palette getColor ifFalse: [ currentColor _ palette getColor. "Change the color of the nib on the cursor (Hand)" paintingFormPen color: currentColor. currentColor isTransparent ifTrue: [ paintingFormPen combinationRule: Form erase1bitShape. paintingFormPen color: Color black] ifFalse: [paintingFormPen combinationRule: Form paint]]] ifTrue: [palette getNib width = brush width ifFalse: [self erasePrep]]. "it changed" action == #stamp: ifTrue: [ stampForm _ palette stampForm. "get the current form" stampForm ifNil: [self error: 'no stamp']]. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'jm 5/24/2003 21:22'! clear "Wipe out all the paint." self polyFreeze. "end polygon mode" paintingForm fillColor: Color transparent. self invalidRect: bounds. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'kfr 4/25/2000 17:50'! ellipse: evt "Draw an ellipse from the center. " | rect oldRect ww ext oldExt | ext _ (strokeOrigin - evt cursorPoint) abs * 2. evt shiftPressed ifTrue: [ext _ ext r]. rect _ Rectangle center: strokeOrigin extent: ext. ww _ palette getNib width. lastEvent ifNotNil: [ oldExt _ (strokeOrigin - lastEvent cursorPoint) abs + ww * 2. lastEvent shiftPressed ifTrue: [oldExt _ oldExt r]. (oldExt < ext) ifFalse: ["Last draw sticks out, must erase the area" oldRect _ Rectangle center: strokeOrigin extent: oldExt. self restoreRect: oldRect]]. currentColor == Color transparent ifFalse:[ formCanvas fillOval: rect color: currentColor borderWidth: 0 borderColor: Color transparent.] ifTrue:[ formCanvas fillOval: rect color: currentColor borderWidth: ww borderColor: Color black]. self invalidRect: rect. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'jm 5/24/2003 21:22'! erasePrep "Transparent paint, square brush. Be careful not to let this be undone by asking palette for brush and color." | size | size _ palette getNib width. brush _ Form extent: size@size depth: 1. brush offset: (0@0) - (brush extent // 2). brush fillColor: Color black. paintingFormPen sourceForm: brush. "transparent" paintingFormPen combinationRule: Form erase1bitShape. paintingFormPen color: Color black. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'tk 3/8/1999 23:01'! pickup: evt "Grab a part of the picture (or screen) and store it in a known place. Note where we started. Use a rubberband rectangle to show what is being selected." | rect oldRect | rect _ strokeOrigin rect: evt cursorPoint + (14@14). lastEvent == nil ifFalse: [ "Last draw will stick out, must erase the area" oldRect _ strokeOrigin rect: lastEvent cursorPoint + (14@14). self restoreRect: (oldRect insetBy: -2)]. formCanvas frameAndFillRectangle: (rect insetBy: -2) fillColor: Color transparent borderWidth: 2 borderColor: Color gray. self invalidRect: (rect insetBy: -2).! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'bf 1/5/2000 19:36'! pickupMouseUp: evt "Grab a part of the picture (or screen) and store it in a known place. Like Copy on the Mac menu. Then switch to the stamp tool." | rr pForm ii oldRect curs | lastEvent == nil ifFalse: [ "Last draw will stick out, must erase the area" oldRect _ strokeOrigin rect: lastEvent cursorPoint + (14@14). self restoreRect: (oldRect insetBy: -2)]. self primaryHand showTemporaryCursor: nil. "later get rid of this" rr _ strokeOrigin rect: evt cursorPoint + (14@14). ii _ rr translateBy: (0@0) - bounds origin. (rr intersects: bounds) ifTrue: [ pForm _ paintingForm copy: ii. pForm isAllWhite "means transparent" ifFalse: [] "normal case. Can be transparent in parts" ifTrue: [pForm _ nil. "Get an un-dimmed picture of other objects on the playfield" "don't know how yet"]]. pForm ifNil: [pForm _ Form fromDisplay: rr]. "Anywhere on the screen" palette pickupForm: pForm. curs _ palette actionCursor. evt hand showTemporaryCursor: curs. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'kfr 4/25/2000 17:51'! polyNew: evt "Create a new polygon. Add it to the sketch, and let the user drag its vertices around!! Freeze it into the painting when the user chooses another tool." | poly | self polyFreeze. "any old one we were working on" poly _ PolygonMorph new addHandles. currentColor == Color transparent ifFalse:[ poly color: currentColor; borderWidth: 0; borderColor: Color transparent] ifTrue:[ poly color: currentColor; borderWidth: 1; "still some problems with brushsize !!!!" borderColor: Color black]. poly position: evt cursorPoint. self addMorph: poly. poly changed. self setProperty: #polygon toValue: poly.! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'kfr 4/25/2000 17:52'! rect: evt "While moving corner, just write on the canvas. When done, write on the paintingForm" | rect within oldRect now diff cor | rect _ strokeOrigin rect: (now _ evt cursorPoint). evt shiftPressed ifTrue: [diff _ evt cursorPoint - strokeOrigin. now _ strokeOrigin + (Point r: (diff x abs min: diff y abs)*2 degrees: (diff degrees // 90 * 90 + 45)). rect _ strokeOrigin rect: now]. lastEvent == nil ifFalse: [oldRect _ strokeOrigin rect: lastEvent cursorPoint. lastEvent shiftPressed ifTrue: [diff _ lastEvent cursorPoint - strokeOrigin. cor _ strokeOrigin + (Point r: (diff x abs min: diff y abs)*2 degrees: (diff degrees // 90 * 90 + 45)). oldRect _ strokeOrigin rect: cor]. within _ (rect containsRect: oldRect). within & (currentColor isTransparent not) ifFalse: ["Last draw will stick out, must erase the area" self restoreRect: oldRect]]. currentColor == Color transparent ifFalse:[ formCanvas frameAndFillRectangle: rect fillColor: currentColor borderWidth: 0 borderColor: Color transparent.] ifTrue:[ formCanvas frameAndFillRectangle: rect fillColor: currentColor borderWidth: (palette getNib width) borderColor: Color black]. self invalidRect: rect.! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'ar 2/12/2000 18:35'! restoreRect: oldRect "Restore the given rectangular area of the painting Form from the undo buffer." formCanvas drawImage: undoBuffer at: oldRect origin sourceRect: (oldRect translateBy: self topLeft negated). self invalidRect: oldRect. ! ! !SketchEditorMorph methodsFor: 'actions & preps' stamp: 'kfr 4/25/2000 17:54'! star: evt "Draw an star from the center. " | poly ext ww rect oldExt oldRect oldR verts pt | ww _ palette getNib width. ext _ (pt _ strokeOrigin - evt cursorPoint) r + ww * 2. rect _ Rectangle center: strokeOrigin extent: ext. ww _ palette getNib width. lastEvent ifNotNil: [ oldExt _ (strokeOrigin - lastEvent cursorPoint) r + ww * 2. "Last draw sticks out, must erase the area" oldRect _ Rectangle center: strokeOrigin extent: oldExt. self restoreRect: oldRect]. ext _ pt r. oldR _ ext. verts _ (0 to: 350 by: 36) collect: [:angle | (Point r: (oldR _ oldR = ext ifTrue: [ext*5//12] ifFalse: [ext]) degrees: angle + pt degrees) + strokeOrigin]. poly _ PolygonMorph new addHandles. currentColor == Color transparent ifFalse:[ poly color: currentColor; borderWidth: 0; borderColor: Color transparent.] ifTrue:[ poly color: currentColor; borderWidth: 1; borderColor: Color black ]. " can't handle thick brushes" self invalidRect: rect. "self addMorph: poly." poly privateOwner: self. poly bounds: (strokeOrigin extent: ext). poly setVertices: verts. poly drawOn: formCanvas. "poly delete." self invalidRect: rect. ! ! !SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:24'! cancelPainting: aPaintBoxMorph "Undo the operation after user issued #cancel in aPaintBoxMorph" ^self cancel! ! !SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:25'! clearPainting: aPaintBoxMorph "Clear the image after user issued #clear in aPaintBoxMorph" ^self clear! ! !SketchEditorMorph methodsFor: 'palette handling' stamp: 'jm 6/15/2003 10:39'! dimTheWindow "Updated to use TranslucentColor by kfr 10/5 00" "Do not call twice!! Installs a morph with an 'onion-skinned' copy of the pixels behind me." "create an 'onion-skinned' version of the stuff on the screen" owner outermostMorphThat: [:morph | morph resumeAfterDrawError. false]. dimForm _ (BorderedMorph new color: (TranslucentColor r:1.0 g:1.0 b:1.0 alpha:0.5); bounds: self bounds; borderWidth: 0). dimForm position: self position. owner privateAddMorph: dimForm atIndex: (owner submorphs indexOf: self) + 1. ! ! !SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:37'! savePainting: aPaintBoxMorph "Save the image after user issued #keep in aPaintBoxMorph" ^self save! ! !SketchEditorMorph methodsFor: 'palette handling' stamp: 'ar 3/23/2000 14:24'! undoPainting: aPaintBoxMorph "Undo the operation after user issued #undo in aPaintBoxMorph" ^self undo! ! I represent a color bitmapped image that can be rotated, scaled, and edited using the PaintBox (SketchEditorMorph and PaintBoxMorph). originalForm holds the original bitmap, before any rotation or scaling. rotatedForm is cache of the rotated and scaled version of originalForm. rotationCenter is the center of rotation in originalForm. When the rotation or scaling is changed, the system keeps the location of the rotation center on the screen fixed. Thus, rotation centers can be used as the registration points for a sequence of instance of me representing animation frames. rotationStyle has several possible values: normal continuous rotation leftRight rotatation with an x component < 0, flip bitmap around the y-axis, otherwise it is not rotated upDown rotatation with an y component < 0, flip bitmap around the x-axis, otherwise it is not rotated none never rotate ! !SketchMorph methodsFor: 'initialization' stamp: 'jm 1/11/2003 09:42'! initialize ^ self initializeWith: PaintingForm ! ! !SketchMorph methodsFor: 'initialization' stamp: 'jm 1/11/2003 09:46'! initializeWith: aForm super initialize. originalForm _ aForm. rotationCenter _ aForm extent // 2. "relative to the top-left corner of the Form" rotationDegrees _ 0.0. "clockwise angle of rotation" rotationStyle _ #normal. "#normal, #leftRight, #upDown, or #none" scalePoint _ 1.0@1.0. rotatedForm _ originalForm. "cached rotated/scaled copy of originalForm" offsetWhenRotated _ 0@0. "offset for rotated form" self extent: originalForm extent. ! ! !SketchMorph methodsFor: 'accessing' stamp: 'jm 8/22/2003 20:42'! rotationDegrees: angleInDegrees rotationDegrees ~= angleInDegrees ifTrue: [ rotationDegrees _ angleInDegrees \\ 360.0. self layoutChanged]. ! ! !SketchMorph methodsFor: 'accessing' stamp: 'jm 8/22/2003 20:42'! rotationDegrees: newRotationDegrees scalePoint: newScalePoint ((newRotationDegrees ~= rotationDegrees) or: [scalePoint ~= newScalePoint]) ifTrue: [ rotationDegrees _ newRotationDegrees \\ 360.0. scalePoint _ newScalePoint. self layoutChanged]. ! ! !SketchMorph methodsFor: 'accessing' stamp: 'jm 10/15/2002 16:08'! rotationStyle: aSymbol "Set my rotation style to #normal, #leftRight, #upDown, or #none. Styles mean: #normal -- continuous 360 degree rotation #leftRight -- quantize angle to left or right facing #upDown -- quantize angle to up or down facing #none -- do not rotate" | oldStyle | oldStyle _ rotationStyle. rotationStyle _ aSymbol. ((aSymbol = #normal) and: [oldStyle ~= #normal]) ifTrue: [self rotationDegrees: 0.0]. self layoutChanged. ! ! !SketchMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:07'! drawOn: aCanvas aCanvas paintImage: self rotatedForm at: bounds origin. ! ! !SketchMorph methodsFor: 'drawing' stamp: 'jm 5/29/2003 18:03'! generateRotatedForm "Compute my rotatedForm and offsetWhenRotated." | adjustedAngle smoothPix pair | (rotationStyle = #normal) ifTrue: [adjustedAngle _ rotationDegrees] "smooth rotation" ifFalse: [adjustedAngle _ 0.0]. "leftRight, upDown, none" ((adjustedAngle = 0.0) and: [1.0@1.0 = scalePoint]) ifTrue: [ "no rotation or scaling; use original" rotatedForm _ originalForm. offsetWhenRotated _ 0@0] ifFalse: [ "generated rotated and/or scaled form" ((scalePoint x < 1.0) or: [scalePoint y < 1.0]) ifTrue: [smoothPix _ 2] ifFalse: [smoothPix _ 1]. pair _ WarpBlt rotate: originalForm degrees: adjustedAngle negated center: rotationCenter scaleBy: self scalePoint smoothing: smoothPix. rotatedForm _ pair first. offsetWhenRotated _ pair last]. ((rotationStyle = #leftRight) and: [rotationDegrees < 0.0]) ifTrue: [ "headed left; use flipped" rotatedForm _ rotatedForm flipBy: #horizontal centerAt: 0@0. offsetWhenRotated _ offsetWhenRotated + (((2 * (rotationCenter x - (originalForm width // 2)))@0) * scalePoint). ^ self]. ((rotationStyle = #upDown) and: [(rotationDegrees > 90.0) or: [rotationDegrees < -90.0]]) ifTrue: [ "headed down; use flipped" rotatedForm _ rotatedForm flipBy: #vertical centerAt: 0@0. offsetWhenRotated _ offsetWhenRotated + ((0@(2 * (rotationCenter y - (originalForm height // 2)))) * scalePoint). ^ self].! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 10/1/2003 20:18'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'grab from screen' action: #grabFromScreen. aCustomMenu add: 'read from file' action: #readFromFile. aCustomMenu addLine. aCustomMenu add: 'save as BMP' action: #saveAsBMP. aCustomMenu add: 'save as GIF' action: #saveAsGIF. aCustomMenu add: 'save as JPEG' action: #saveAsJPEG. aCustomMenu addLine. aCustomMenu add: 'set rotation center' action: #setRotationCenter. aCustomMenu add: 'set rotation style' action: #setRotationStyle. aCustomMenu add: 'erase pixels of color' action: #erasePixelsOfColor:. aCustomMenu add: 'recolor of pixels of color' action: #recolorPixelsOfColor:. aCustomMenu addLine. aCustomMenu add: 'repaint' action: #editDrawing. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 1/11/2003 09:29'! editDrawing self editDrawingIn: self pasteUpMorph forBackground: false. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 10/15/2002 17:22'! editDrawingIn: aPasteUpMorph forBackground: forBackground | w oldRotation bnds sketchEditor | self world assureNotPaintingElse: [^ self]. w _ aPasteUpMorph world. w abandonAllHalos. w displayWorld. oldRotation _ rotationDegrees. forBackground ifTrue: [bnds _ aPasteUpMorph boundsInWorld] ifFalse: [bnds _ (self boundsInWorld expandBy: (60 @ 60)) intersect: self world bounds. bnds _ (aPasteUpMorph paintingBoundsAround: bnds center) merge: bnds]. sketchEditor _ SketchEditorMorph new. forBackground ifTrue: [sketchEditor setProperty: #background toValue: true]. w addMorphFront: sketchEditor. sketchEditor initializeFor: self inBounds: bnds pasteUpMorph: aPasteUpMorph. "self rotationDegrees: 0. inside the init" self rotationDegrees: oldRotation. "restore old rotation so that cancel leaves it right" sketchEditor afterNewPicDo: [:aForm :aRect | self form: aForm. self position: aRect origin. self rotationStyle: sketchEditor rotationStyle. forBackground ifTrue: [self goBehind]] "shouldn't be necessary" ifNoBits: ["If no bits drawn. Must keep old pic. Can't have no picture"] ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 6/18/1999 17:00'! erasePixelsOfColor: evt | c r | c _ evt hand chooseColor. originalForm mapColor: c to: Color transparent. r _ originalForm rectangleEnclosingPixelsNotOfColor: Color transparent. self form: (originalForm copy: r). ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 11/13/2002 10:55'! grabFromScreen self form: Form fromUser. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 8/3/2003 16:06'! readFromFile | result fileName | result _ StandardFileMenu oldFileExtensions: #(jpg jpeg gif bmp png). result ifNil: [^ self]. fileName _ result directory pathName, FileDirectory slash, result name. self form: (Form fromFileNamed: fileName). ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 10/1/2003 20:19'! saveAsBMP | formToSave fileName | formToSave _ originalForm asFormOfDepth: 32. fileName _ FillInTheBlank request: 'File name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.bmp') ifFalse: [ fileName _ fileName, '.bmp']. formToSave writeBMPfileNamed: fileName. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 6/5/2003 22:29'! saveAsGIF | formToSave fileName | formToSave _ originalForm. formToSave depth > 8 ifTrue: [ formToSave _ originalForm colorReduced. formToSave depth > 8 ifTrue: [ (self confirm: 'Saving as GIF will reduce to 8-bit color with some loss of quality. Continue?') ifFalse: [^ self]. formToSave _ originalForm asFormOfDepth: 8]]. fileName _ FillInTheBlank request: 'File name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.gif') ifFalse: [ fileName _ fileName, '.gif']. GIFReadWriter putForm: formToSave onFileNamed: fileName. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 6/5/2003 22:39'! saveAsJPEG "Save my originalForm in JPEG format. Convert to 16-bit color if necessary." | formToSave quality fileName bytes f | formToSave _ originalForm. formToSave depth < 16 ifTrue: [ formToSave _ originalForm asFormOfDepth: 16]. quality _ FillInTheBlank request: 'JPEG Quality (1-100):' initialAnswer: '50'. ((quality size = 0) or: [quality first isDigit not]) ifTrue: [^ self]. fileName _ FillInTheBlank request: 'File name?'. fileName size = 0 ifTrue: [^ self]. (fileName asLowercase endsWith: '.jpg') ifFalse: [ fileName _ fileName, '.jpg']. bytes _ FastJPEG compress: formToSave quality: quality asNumber. f _ (FileStream newFileNamed: fileName) binary. f nextPutAll: bytes; close. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 1/11/2003 09:24'! setRotationCenter "Interactively set the rotation center in my original form." | w p oldRotation oldScale | (w _ self world) ifNil: [^ self]. "undo current rotation and scale..." oldRotation _ rotationDegrees. oldScale _ scalePoint. self rotationDegrees: 0.0 scalePoint: 1.0@1.0. w displayWorldSafely. Cursor crossHair showWhile: [p _ Sensor waitButton]. Sensor waitNoButton. self rotationCenter: (self transformFromWorld globalPointToLocal: p) - bounds origin. "restore old rotation and scale:" self rotationDegrees: oldRotation scalePoint: oldScale. ! ! !SketchMorph methodsFor: 'menu' stamp: 'jm 6/15/2003 10:44'! setRotationStyle | menu newStyle | menu _ CustomMenu new. #('rotate smoothly' 'left-right flip only' 'up-down flip only' 'don''t rotate') with: #(normal leftRight upDown none) do: [:name :action | menu add: name action: action]. newStyle _ menu startUp. newStyle ifNotNil: [self rotationStyle: newStyle]. ! ! !SketchMorph methodsFor: 'change reporting' stamp: 'jm 1/11/2003 08:58'! layoutChanged "Update rotatedForm and offsetWhenRotated and compute new bounds." | unrotatedOrigin | self changed. unrotatedOrigin _ bounds origin - offsetWhenRotated. (rotationStyle == #none and: [scalePoint = (1.0@1.0)]) ifTrue: [ "zero rotation and scale; use original Form" rotatedForm _ originalForm. offsetWhenRotated _ 0@0] ifFalse: [self generateRotatedForm]. "changes offsetWhenRotated" bounds _ (unrotatedOrigin + offsetWhenRotated) extent: rotatedForm extent. super layoutChanged. self changed. ! ! !SketchMorph methodsFor: 'other' stamp: 'jm 10/14/2002 09:15'! isColorable ^ false ! ! !SketchMorph methodsFor: 'other' stamp: 'jm 10/15/2002 15:56'! releaseCachedState "Clear cache of rotated, scaled Form." super releaseCachedState. rotatedForm _ nil. originalForm hibernate. ! ! !SketchMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! !SketchMorph class methodsFor: 'instance creation' stamp: 'jm 1/11/2003 09:41'! withForm: aForm "Note: 'SketchMorph withForm: f' is faster than 'SketchMorph new form: f'." ^ self basicNew initializeWith: aForm ! ! !SketchMorph class methodsFor: 'handy images' stamp: 'jm 10/16/2002 07:08'! paintingForm ^ PaintingForm ! ! !Slider methodsFor: 'initialize' stamp: 'sw 3/10/2000 13:05'! initialize super initialize. bounds := 0@0 corner: 16@100. color := Color gray. borderWidth := 1. borderColor := #inset. value _ 0.0. descending _ false. self initializeSlider! ! !Slider methodsFor: 'initialize' stamp: 'jm 6/15/2003 10:38'! initializeSlider slider _ BorderedMorph newBounds: self totalSliderArea color: self sliderColor. sliderShadow _ BorderedMorph newBounds: self totalSliderArea color: self pagingArea color. slider setBorderWidth: 1 borderColor: #raised. sliderShadow setBorderWidth: 1 borderColor: #inset. "Note: shadow must have the pagingArea as its owner to highlight properly." self pagingArea addMorph: sliderShadow. sliderShadow isHidden: true. self addMorph: slider. self computeSlider. ! ! !Slider methodsFor: 'initialize' stamp: 'jm 10/14/2003 10:40'! slider ^ slider ! ! !Slider methodsFor: 'access' stamp: 'sw 3/10/2000 13:05'! descending ^ descending == true! ! !Slider methodsFor: 'access' stamp: 'sw 3/12/2000 11:57'! descending: aBoolean descending _ aBoolean. self value: value! ! !Slider methodsFor: 'access' stamp: 'jm 10/3/2002 18:01'! model ^ model ! ! !Slider methodsFor: 'access' stamp: 'jm 10/3/2002 18:01'! model: anObject model _ anObject. ! ! !Slider methodsFor: 'access' stamp: 'dew 2/15/1999 18:24'! pagingArea ^self! ! !Slider methodsFor: 'access' stamp: 'jm 2/4/2003 11:32'! setValueSelector ^ setValueSelector ! ! !Slider methodsFor: 'access' stamp: 'jm 2/4/2003 11:34'! setValueSelector: aStringOrSymbolOrNil setValueSelector _ aStringOrSymbolOrNil. (setValueSelector isKindOf: String) ifTrue: [setValueSelector _ setValueSelector asSymbol]. ! ! !Slider methodsFor: 'access' stamp: 'di 11/9/1999 13:25'! sliderColor sliderColor ifNil: [^ Color veryLightGray]. ^ sliderColor! ! !Slider methodsFor: 'access' stamp: 'sw 3/7/2000 15:39'! sliderColor: newColor sliderColor _ newColor. slider ifNotNil: [slider color: sliderColor]! ! !Slider methodsFor: 'geometry' stamp: 'sw 3/10/2000 13:44'! computeSlider | r | r _ self roomToMove. self descending ifFalse: [slider position: (bounds isWide ifTrue: [r topLeft + ((r width * value) asInteger @ 0)] ifFalse: [r topLeft + (0 @ (r height * value) asInteger)])] ifTrue: [slider position: (bounds isWide ifTrue: [r bottomRight - ((r width * value) asInteger @ 0)] ifFalse: [r bottomRight - ((0 @ (r height * value) asInteger))])]. slider extent: self sliderExtent! ! !Slider methodsFor: 'geometry' stamp: 'dew 2/21/1999 03:08'! extent: newExtent newExtent = bounds extent ifTrue: [^ self]. bounds isWide ifTrue: [super extent: (newExtent x max: self sliderThickness * 2) @ newExtent y] ifFalse: [super extent: newExtent x @ (newExtent y max: self sliderThickness * 2)]. self removeAllMorphs; initializeSlider! ! !Slider methodsFor: 'scrolling' stamp: 'jm 10/13/2002 09:58'! scrollAbsolute: event | r p | r _ self roomToMove. bounds isWide ifTrue: [r width = 0 ifTrue: [^ self]] ifFalse: [r height = 0 ifTrue: [^ self]]. p _ event cursorPoint + dragOffset adhereTo: r. self descending ifFalse: [self setValue: (bounds isWide ifTrue: [(p x - r left) asFloat / r width] ifFalse: [(p y - r top) asFloat / r height])] ifTrue: [self setValue: (bounds isWide ifTrue: [(r right - p x) asFloat / r width] ifFalse: [(r bottom - p y) asFloat / r height])]! ! !Slider methodsFor: 'model access' stamp: 'jm 10/11/2002 19:28'! setValue: newValue "Called internally for propagation to model" self value: newValue. setValueSelector ifNil: [setValueSelector _ #scrollBarValue:]. model ifNotNil: [model perform: setValueSelector with: value]. ! ! !Slider methodsFor: 'event handling' stamp: 'jm 10/13/2002 09:49'! handlesMouseDown: evt ^ slider containsPoint: evt cursorPoint ! ! !Slider methodsFor: 'event handling' stamp: 'jm 10/14/2002 08:58'! mouseDown: evt slider color: self sliderColor lighter lighter. sliderShadow bounds: slider bounds. sliderShadow isHidden: false. dragOffset _ slider position - evt cursorPoint. ! ! !Slider methodsFor: 'event handling' stamp: 'jm 10/13/2002 09:52'! mouseMove: evt self scrollAbsolute: evt. ! ! !Slider methodsFor: 'event handling' stamp: 'jm 10/13/2002 18:14'! mouseUp: evt slider color: self sliderColor. sliderShadow isHidden: true. ! ! My instances are 30-bit numbers, stored in twos complement form. The allowable range is approximately +- 1 billion (see SmallInteger minVal, maxVal).! !SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:29'! * aNumber "Primitive. Multiply the receiver by the argument and answer with the result if it is a SmallInteger. Fail if the argument or the result is not a SmallInteger. Essential. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 9> ^ super * aNumber! ! !SmallInteger methodsFor: 'arithmetic' stamp: 'di 2/1/1999 21:31'! + aNumber "Primitive. Add the receiver to the argument and answer with the result if it is a SmallInteger. Fail if the argument or the result is not a SmallInteger Essential No Lookup. See Object documentation whatIsAPrimitive." <primitive: 1> ^ super + aNumber! ! !SmallInteger methodsFor: 'arithmetic' stamp: 'jm 5/22/2003 19:58'! / aNumber "Primitive. This primitive (for /) divides the receiver by the argument and returns the result if the division is exact. Fail if the result is not a whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. No Lookup. See Object documentation whatIsAPrimitive." <primitive: 10> aNumber = 0 ifTrue: [^ self error: 'division by 0']. (aNumber isMemberOf: SmallInteger) ifTrue: [^(Fraction numerator: self denominator: aNumber) reduced] ifFalse: [^super / aNumber]! ! !SmallInteger methodsFor: 'arithmetic' stamp: 'jm 5/22/2003 19:59'! quo: aNumber "Primitive. Divide the receiver by the argument and answer with the result. Round the result down towards zero to make it a whole integer. Fail if the argument is 0 or is not a SmallInteger. Optional. See Object documentation whatIsAPrimitive." <primitive: 13> aNumber = 0 ifTrue: [^ self error: 'division by 0']. (aNumber isMemberOf: SmallInteger) ifFalse: [^ super quo: aNumber]. (aNumber == -1 and: [self == self class minVal]) ifTrue: ["result is aLargeInteger" ^ self negated]. self primitiveFailed! ! !SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:07'! highBit "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Raise an error if the receiver is negative, since negative integers are defined to have an infinite number of leading 1's in 2's-complement arithmetic. Use >>highBitOfMagnitude if you want to get the highest bit of the magnitude." self < 0 ifTrue: [^ self error: 'highBit is not defined for negative integers']. ^ self highBitOfPositiveReceiver! ! !SmallInteger methodsFor: 'bit manipulation' stamp: 'sr 6/8/2000 02:08'! highBitOfMagnitude "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. This method is used for negative SmallIntegers as well, since Squeak's LargeIntegers are sign/magnitude." ^ self abs highBitOfPositiveReceiver! ! !SmallInteger methodsFor: 'testing' stamp: 'jm 10/27/2003 07:35'! isSmallInteger ^ true ! ! !SmallInteger methodsFor: 'copying' stamp: 'tk 6/26/1998 11:34'! clone ! ! !SmallInteger methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:15'! destinationBuffer:digitLength ^ LargePositiveInteger new: digitLength.! ! !SmallInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'! digitAt: n "Answer the value of an indexable field in the receiver. LargePositiveInteger uses bytes of base two number, and each is a 'digit' base 256. Fail if the argument (the index) is not an Integer or is out of bounds." n>4 ifTrue: [^ 0]. self < 0 ifTrue: [self = SmallInteger minVal ifTrue: ["Can't negate minVal -- treat specially" ^ #(0 0 0 64) at: n]. ^ ((0-self) bitShift: (1-n)*8) bitAnd: 16rFF] ifFalse: [^ (self bitShift: (1-n)*8) bitAnd: 16rFF]! ! !SmallInteger methodsFor: 'system primitives' stamp: 'tk 5/14/1999 20:54'! nextInstance "SmallIntegers can't be enumerated this way. There are a finite number of them from from (SmallInteger minVal) to (SmallInteger maxVal), but you'll have to enumerate them yourself with: (SmallInteger minVal) to: (SmallInteger maxVal) do: [:integer | <your code here>]. " self shouldNotImplement ! ! !SmallInteger methodsFor: 'private' stamp: 'sr 6/8/2000 01:14'! highBitOfPositiveReceiver | shifted bitNo | "Answer the index of the high order bit of the receiver, or zero if the receiver is zero. Receiver has to be positive!!" shifted _ self. bitNo _ 0. [shifted < 16] whileFalse: [shifted _ shifted bitShift: -4. bitNo _ bitNo + 4]. [shifted = 0] whileFalse: [shifted _ shifted bitShift: -1. bitNo _ bitNo + 1]. ^ bitNo! ! !SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:17'! basicNew self error: 'SmallIntegers can only be created by performing arithmetic'! ! !SmallInteger class methodsFor: 'instance creation' stamp: 'tk 4/20/1999 14:18'! new self basicNew "generates an error"! ! A Socket represents a network connection point. Current sockets are designed to support the TCP/IP and UDP protocols Subclasses of socket provide support for network protocols such as POP, NNTP, HTTP, and FTP. Sockets also allow you to implement your own custom services and may be used to support Remote Procedure Call or Remote Method Invocation some day. JMM June 2nd 2000 Macintosh UDP support was added if you run open transport. ! ]style[(196 4 6 3 228)f1,f1LHTTPSocket Comment;,f1,f1LFTPSocket Comment;,f1! !Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:47'! acceptFrom: aSocket "Initialize a new socket handle from an accept call" | semaIndex readSemaIndex writeSemaIndex | primitiveOnlySupportsOneSemaphore _ false. semaphore _ Semaphore new. readSemaphore _ Semaphore new. writeSemaphore _ Semaphore new. semaIndex _ Smalltalk registerExternalObject: semaphore. readSemaIndex _ Smalltalk registerExternalObject: readSemaphore. writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore. socketHandle _ self primAcceptFrom: aSocket socketHandle receiveBufferSize: 8000 sendBufSize: 8000 semaIndex: semaIndex readSemaIndex: readSemaIndex writeSemaIndex: writeSemaIndex. socketHandle = nil ifTrue: [ "socket creation failed" Smalltalk unregisterExternalObject: semaphore. Smalltalk unregisterExternalObject: readSemaphore. Smalltalk unregisterExternalObject: writeSemaphore. readSemaphore _ writeSemaphore _ semaphore _ nil ] ifFalse:[self register]. ! ! !Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 22:54'! destroy "Destroy this socket. Its connection, if any, is aborted and its resources are freed. Do nothing if the socket has already been destroyed (i.e., if its socketHandle is nil)." socketHandle = nil ifFalse: [self isValid ifTrue: [self primSocketDestroy: socketHandle]. Smalltalk unregisterExternalObject: semaphore. Smalltalk unregisterExternalObject: readSemaphore. Smalltalk unregisterExternalObject: writeSemaphore. socketHandle _ nil. readSemaphore _ writeSemaphore _ semaphore _ nil. self unregister]. ! ! !Socket methodsFor: 'initialize-destroy' stamp: 'JMM 5/22/2000 23:04'! initialize: socketType "Initialize a new socket handle. If socket creation fails, socketHandle will be set to nil." | semaIndex readSemaIndex writeSemaIndex | primitiveOnlySupportsOneSemaphore _ false. semaphore _ Semaphore new. readSemaphore _ Semaphore new. writeSemaphore _ Semaphore new. semaIndex _ Smalltalk registerExternalObject: semaphore. readSemaIndex _ Smalltalk registerExternalObject: readSemaphore. writeSemaIndex _ Smalltalk registerExternalObject: writeSemaphore. socketHandle _ self primSocketCreateNetwork: 0 type: socketType receiveBufferSize: 8000 sendBufSize: 8000 semaIndex: semaIndex readSemaIndex: readSemaIndex writeSemaIndex: writeSemaIndex. socketHandle = nil ifTrue: [ "socket creation failed" Smalltalk unregisterExternalObject: semaphore. Smalltalk unregisterExternalObject: readSemaphore. Smalltalk unregisterExternalObject: writeSemaphore. readSemaphore _ writeSemaphore _ semaphore _ nil ] ifFalse:[self register]. ! ! !Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'! address "Shortcut" ^self localAddress! ! !Socket methodsFor: 'accessing' stamp: 'JMM 5/10/2000 14:37'! localAddress self waitForConnectionUntil: Socket standardDeadline. self isConnected ifFalse: [^ByteArray new: 4]. ^ self primSocketLocalAddress: socketHandle ! ! !Socket methodsFor: 'accessing' stamp: 'JMM 5/10/2000 14:31'! localPort self waitForConnectionUntil: Socket standardDeadline. self isConnected ifFalse: [^0 ]. ^ self primSocketLocalPort: socketHandle ! ! !Socket methodsFor: 'accessing' stamp: 'ar 4/30/1999 04:25'! port "Shortcut" ^self localPort! ! !Socket methodsFor: 'accessing' stamp: 'JMM 6/5/2000 10:12'! primitiveOnlySupportsOneSemaphore ^primitiveOnlySupportsOneSemaphore! ! !Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'! readSemaphore primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore]. ^readSemaphore! ! !Socket methodsFor: 'accessing' stamp: 'JMM 5/9/2000 15:32'! semaphore ^semaphore! ! !Socket methodsFor: 'accessing' stamp: 'ar 7/16/1999 17:22'! socketHandle ^socketHandle! ! !Socket methodsFor: 'accessing' stamp: 'JMM 5/22/2000 22:49'! writeSemaphore primitiveOnlySupportsOneSemaphore ifTrue: [^semaphore]. ^writeSemaphore! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'! dataAvailable "Return true if this socket has unread received data." socketHandle == nil ifTrue: [^ false]. ^ self primSocketReceiveDataAvailable: socketHandle ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:52'! isConnected "Return true if this socket is connected." socketHandle == nil ifTrue: [^ false]. ^ (self primSocketConnectionStatus: socketHandle) == Connected ! ! !Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:15'! isOtherEndClosed "Return true if this socket had the other end closed." socketHandle == nil ifTrue: [^ false]. ^ (self primSocketConnectionStatus: socketHandle) == OtherEndClosed ! ! !Socket methodsFor: 'queries' stamp: 'JMM 5/5/2000 12:17'! isThisEndClosed "Return true if this socket had the this end closed." socketHandle == nil ifTrue: [^ false]. ^ (self primSocketConnectionStatus: socketHandle) == ThisEndClosed ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! isUnconnected "Return true if this socket's state is Unconnected." socketHandle == nil ifTrue: [^ false]. ^ (self primSocketConnectionStatus: socketHandle) == Unconnected ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! isUnconnectedOrInvalid "Return true if this socket is completely disconnected or is invalid." | status | socketHandle == nil ifTrue: [^ true]. status _ self primSocketConnectionStatus: socketHandle. ^ (status = Unconnected) | (status = InvalidSocket) ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:51'! isValid "Return true if this socket contains a valid, non-nil socket handle." | status | socketHandle == nil ifTrue: [^ false]. status _ self primSocketConnectionStatus: socketHandle. ^ status ~= InvalidSocket ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! isWaitingForConnection "Return true if this socket is waiting for a connection." socketHandle == nil ifTrue: [^ false]. ^ (self primSocketConnectionStatus: socketHandle) == WaitingForConnection ! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:54'! sendDone "Return true if the most recent send operation on this socket has completed." socketHandle == nil ifTrue: [^ false]. ^ self primSocketSendDone: socketHandle ! ! !Socket methodsFor: 'queries' stamp: 'JMM 5/8/2000 23:24'! socketError ^self primSocketError: socketHandle! ! !Socket methodsFor: 'queries' stamp: 'jm 2/25/1999 13:56'! statusString "Return a string describing the status of this socket." | status | socketHandle == nil ifTrue: [^ 'destroyed']. status _ self primSocketConnectionStatus: socketHandle. status = InvalidSocket ifTrue: [^ 'invalidSocketHandle']. status = Unconnected ifTrue: [^ 'unconnected']. status = WaitingForConnection ifTrue: [^ 'waitingForConnection']. status = Connected ifTrue: [^ 'connected']. status = OtherEndClosed ifTrue: [^ 'otherEndClosedButNotThisEnd']. status = ThisEndClosed ifTrue: [^ 'thisEndClosedButNotOtherEnd']. ^ 'unknown socket status' ! ! !Socket methodsFor: 'connection open/close' stamp: 'bolot 7/16/1999 14:36'! accept "Accept a connection from the receiver socket. Return a new socket that is connected to the client" ^Socket acceptFrom: self.! ! !Socket methodsFor: 'connection open/close' stamp: 'ar 7/16/1999 18:26'! listenOn: portNumber backlogSize: backlog "Listen for a connection on the given port. If this method succeeds, #accept may be used to establish a new connection" | status | status _ self primSocketConnectionStatus: socketHandle. (status == Unconnected) ifFalse: [self error: 'Socket status must Unconnected before listening for a new connection']. self primSocket: socketHandle listenOn: portNumber backlogSize: backlog. ! ! !Socket methodsFor: 'sending-receiving' stamp: 'JMM 6/3/2000 21:48'! getData "Get some data" | buf bytesRead | (self waitForDataUntil: Socket standardDeadline) ifFalse: [self error: 'getData timeout']. buf _ String new: 4000. bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. ^ buf copyFrom: 1 to: bytesRead! ! !Socket methodsFor: 'sending-receiving' stamp: 'jm 7/31/2001 07:30'! readInto: aStringOrByteArray startingAt: aNumber "Read data into the given buffer starting at the given index and return the number of bytes received. Note the given buffer may be only partially filled by the received data. If no data is available, do nothing and return zero." ^ self primSocket: socketHandle receiveDataInto: aStringOrByteArray startingAt: aNumber count: aStringOrByteArray size - aNumber + 1 ! ! !Socket methodsFor: 'sending-receiving' stamp: 'ar 7/20/1999 17:23'! sendData: buffer count: n "Send the amount of data from the given buffer" | sent | sent _ 0. [sent < n] whileTrue:[ sent _ sent + (self sendSomeData: buffer startIndex: sent+1 count: (n-sent))].! ! !Socket methodsFor: 'sending-receiving' stamp: 'jm 7/31/2001 07:30'! sendDataNoWait: aStringOrByteArray startIndex: startIndex "Send zero or more bytes of data from the given array starting at the given index, and return the number of bytes sent. Do not wait; if the socket is not ready to accept more data, just do nothing and return zero." ^ self primSocket: socketHandle sendData: aStringOrByteArray startIndex: startIndex count: aStringOrByteArray size + 1 - startIndex ! ! !Socket methodsFor: 'sending-receiving' stamp: 'ls 1/5/1999 15:05'! sendSomeData: aStringOrByteArray "Send as much of the given data as possible and answer the number of bytes actually sent." "Note: This operation may have to be repeated multiple times to send a large amount of data." ^ self sendSomeData: aStringOrByteArray startIndex: 1 count: aStringOrByteArray size! ! !Socket methodsFor: 'sending-receiving' stamp: 'ls 3/3/1999 18:59'! sendSomeData: aStringOrByteArray startIndex: startIndex "Send as much of the given data as possible starting at the given index. Answer the number of bytes actually sent." "Note: This operation may have to be repeated multiple times to send a large amount of data." ^ self sendSomeData: aStringOrByteArray startIndex: startIndex count: (aStringOrByteArray size - startIndex + 1)! ! !Socket methodsFor: 'sending-receiving' stamp: 'ls 1/5/1999 15:05'! sendSomeData: aStringOrByteArray startIndex: startIndex count: count "Send up to count bytes of the given data starting at the given index. Answer the number of bytes actually sent." "Note: This operation may have to be repeated multiple times to send a large amount of data." | bytesSent | (self waitForSendDoneUntil: (Socket deadlineSecs: 20)) ifTrue: [ bytesSent _ self primSocket: socketHandle sendData: aStringOrByteArray startIndex: startIndex count: count] ifFalse: [self error: 'send data timeout; data not sent']. ^ bytesSent ! ! !Socket methodsFor: 'waiting' stamp: 'ar 7/20/1999 17:21'! waitForAcceptUntil: deadLine "Wait and accept an incoming connection" self waitForConnectionUntil: deadLine. ^self isConnected ifTrue:[self accept] ifFalse:[nil]! ! !Socket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:04'! waitForDataUntil: deadline "Wait up until the given deadline for data to arrive. Return true if data arrives by the deadline, false if not." | dataArrived | [self isConnected & (dataArrived _ self primSocketReceiveDataAvailable: socketHandle) not "Connection end and final data can happen fast, so test in this order" and: [Time millisecondClockValue < deadline]] whileTrue: [ self readSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)]. ^ dataArrived ! ! !Socket methodsFor: 'waiting' stamp: 'JMM 5/17/2000 14:52'! waitForDisconnectionUntil: deadline "Wait up until the given deadline for the the connection to be broken. Return true if it is broken by the deadline, false if not." "Note: The client should know the the connect is really going to be closed (e.g., because he has called 'close' to send a close request to the other end) before calling this method. JMM 00/5/17 note that other end can close which will terminate wait" | extraBytes status | extraBytes _ 0. status _ self primSocketConnectionStatus: socketHandle. [((status = Connected) or: [(status = ThisEndClosed)]) and: [Time millisecondClockValue < deadline]] whileTrue: [ self dataAvailable ifTrue: [extraBytes _ extraBytes + self discardReceivedData]. semaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue). status _ self primSocketConnectionStatus: socketHandle]. extraBytes > 0 ifTrue: [self inform: 'Discarded ', extraBytes printString, ' bytes while closing connection.']. ^ status ~= Connected ! ! !Socket methodsFor: 'waiting' stamp: 'JMM 5/22/2000 22:05'! waitForSendDoneUntil: deadline "Wait up until the given deadline for the current send operation to complete. Return true if it completes by the deadline, false if not." | sendDone | [self isConnected & (sendDone _ self primSocketSendDone: socketHandle) not "Connection end and final data can happen fast, so test in this order" and: [Time millisecondClockValue < deadline]] whileTrue: [ self writeSemaphore waitTimeoutMSecs: (deadline - Time millisecondClockValue)]. ^ sendDone! ! !Socket methodsFor: 'primitives' stamp: 'ar 7/16/1999 17:14'! primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex "Create and return a new socket handle based on accepting the connection from the given listening socket" <primitive: 225> ^self primitiveFailed! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:55'! primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema "Create and return a new socket handle based on accepting the connection from the given listening socket" <primitive: 'primitiveSocketAccept3Semaphores' module: 'SocketPlugin'> primitiveOnlySupportsOneSemaphore _ true. ^self primAcceptFrom: aHandle receiveBufferSize: rcvBufSize sendBufSize: sndBufSize semaIndex: semaIndex ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 21:48'! primSocket: socketID getOption: aString "Get some option information on this socket. Refer to the UNIX man pages for valid SO, TCP, IP, UDP options. In case of doubt refer to the source code. TCP_NODELAY, SO_KEEPALIVE are valid options for example returns an array containing the error code and the option value" <primitive: 'primitiveSocketGetOptions' module: 'SocketPlugin'> self primitiveFailed ! ! !Socket methodsFor: 'primitives' stamp: 'ar 7/16/1999 18:25'! primSocket: aHandle listenOn: portNumber backlogSize: backlog "Primitive. Set up the socket to listen on the given port. Will be used in conjunction with #accept only." <primitive: 218> self destroy. "Accept not supported so clean up"! ! !Socket methodsFor: 'primitives' stamp: 'jm 6/16/2002 12:35'! primSocket: socketID receiveDataInto: aStringOrByteArray startingAt: startIndex count: count "Receive data from the given socket into the given array starting at the given index. Return the number of bytes read or zero if no data is available." <primitive: 221> ^ 0 ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/24/2000 17:19'! primSocket: socketID receiveUDPDataInto: aStringOrByteArray startingAt: startIndex count: count "Receive data from the given socket into the given array starting at the given index. Return an Array containing the amount read, the host address byte array, the host port, and the more flag" <primitive: 'primitiveSocketReceiveUDPDataBufCount' module: 'SocketPlugin'> self primitiveFailed ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 00:08'! primSocket: socketID sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: startIndex count: count "Send data to the remote host through the given socket starting with the given byte index of the given byte array. The data sent is 'pushed' immediately. Return the number of bytes of data actually sent; any remaining data should be re-submitted for sending after the current send operation has completed." "Note: In general, it many take several sendData calls to transmit a large data array since the data is sent in send-buffer-sized chunks. The size of the send buffer is determined when the socket is created." <primitive: 'primitiveSocketSendUDPDataBufCount' module: 'SocketPlugin'> self primitiveFailed ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/25/2000 20:12'! primSocket: socketID setOption: aString value: aStringValue "Set some option information on this socket. Refer to the UNIX man pages for valid SO, TCP, IP, UDP options. In case of doubt refer to the source code. TCP_NODELAY, SO_KEEPALIVE are valid options for example returns an array containing the error code and the negotiated value" <primitive: 'primitiveSocketSetOptions' module: 'SocketPlugin'> self primitiveFailed ! ! !Socket methodsFor: 'primitives' stamp: 'ar 4/30/1999 04:31'! primSocket: socketID setPort: port "Set the local port associated with a UDP socket. Note: this primitive is overloaded. The primitive will not fail on a TCP socket, but the effects will not be what was desired. Best solution would be to split Socket into two subclasses, TCPSocket and UDPSocket." <primitive: 218> self primitiveFailed ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 6/3/2000 21:53'! primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex "Return a new socket handle for a socket of the given type and buffer sizes. Return nil if socket creation fails. The netType parameter is platform dependent and can be used to encode both the protocol type (IP, Xerox XNS, etc.) and/or the physical network interface to use if this host is connected to multiple networks. A zero netType means to use IP protocols and the primary (or only) network interface. The socketType parameter specifies: 0 reliable stream socket (TCP if the protocol is IP) 1 unreliable datagram socket (UDP if the protocol is IP) The buffer size parameters allow performance to be tuned to the application. For example, a larger receive buffer should be used when the application expects to be receiving large amounts of data, especially from a host that is far away. These values are considered requests only; the underlying implementation will ensure that the buffer sizes actually used are within allowable bounds. Note that memory may be limited, so an application that keeps many sockets open should use smaller buffer sizes. Note the macintosh implementation ignores this buffer size. Also see setOption to get/set socket buffer sizes which allows you to set/get the current buffer sizes for reading and writing. If semaIndex is > 0, it is taken to be the index of a Semaphore in the external objects array to be associated with this socket. This semaphore will be signalled when the socket status changes, such as when data arrives or a send completes. All processes waiting on the semaphore will be awoken for each such event; each process must then query the socket state to figure out if the conditions they are waiting for have been met. For example, a process waiting to send some data can see if the last send has completed." <primitive: 209> ^ nil "socket creation failed" ! ! !Socket methodsFor: 'primitives' stamp: 'JMM 5/22/2000 22:48'! primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex readSemaIndex: aReadSema writeSemaIndex: aWriteSema "See comment in primSocketCreateNetwork: with one semaIndex. However you should know that some implementations ignore the buffer size and this interface supports three semaphores, one for open/close/listen and the other two for reading and writing" <primitive: 'primitiveSocketCreate3Semaphores' module: 'SocketPlugin'> primitiveOnlySupportsOneSemaphore _ true. ^ self primSocketCreateNetwork: netType type: socketType receiveBufferSize: rcvBufSize sendBufSize: sendBufSize semaIndex: semaIndex! ! !Socket methodsFor: 'primitives' stamp: 'ar 3/21/98 17:43'! primSocketDestroyGently: socketID "Release the resources associated with this socket. If a connection is open, it is aborted. Do not fail if the receiver is already closed." <primitive: 210> ! ! !Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:40'! register ^self class register: self! ! !Socket methodsFor: 'registry' stamp: 'ar 3/21/98 17:41'! unregister ^self class unregister: self! ! !Socket methodsFor: 'finalization' stamp: 'JMM 5/22/2000 22:52'! finalize self primSocketDestroyGently: socketHandle. Smalltalk unregisterExternalObject: semaphore. Smalltalk unregisterExternalObject: readSemaphore. Smalltalk unregisterExternalObject: writeSemaphore. ! ! !Socket methodsFor: 'printing' stamp: 'jm 11/23/1998 11:57'! printOn: aStream super printOn: aStream. aStream nextPutAll: '[', self statusString, ']'. ! ! !Socket methodsFor: 'datagrams' stamp: 'JMM 6/7/2000 14:58'! receiveDataInto: aStringOrByteArray fromHost: hostAddress port: portNumber | datagram | "Receive a UDP packet from the given hostAddress/portNumber, storing the data in the given buffer, and return the number of bytes received. Note the given buffer may be only partially filled by the received data." primitiveOnlySupportsOneSemaphore ifTrue: [self setPeer: hostAddress port: portNumber. ^self receiveDataInto: aStringOrByteArray]. [true] whileTrue: [datagram _ self receiveUDPDataInto: aStringOrByteArray. ((datagram at: 2) = hostAddress and: [(datagram at: 3) = portNumber]) ifTrue: [^datagram at: 1] ifFalse: [^0]]! ! !Socket methodsFor: 'datagrams' stamp: 'JMM 6/3/2000 21:54'! receiveUDPDataInto: aStringOrByteArray "Receive UDP data into the given buffer and return the number of bytes received. Note the given buffer may be only partially filled by the received data. What is returned is an array, the first element is the bytes read, the second the sending bytearray address, the third the senders port, the fourth, true if more of the datagram awaits reading" ^ self primSocket: socketHandle receiveUDPDataInto: aStringOrByteArray startingAt: 1 count: aStringOrByteArray size ! ! !Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:05'! sendData: aStringOrByteArray toHost: hostAddress port: portNumber "Send a UDP packet containing the given data to the specified host/port." primitiveOnlySupportsOneSemaphore ifTrue: [self setPeer: hostAddress port: portNumber. ^self sendData: aStringOrByteArray]. ^self sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber! ! !Socket methodsFor: 'datagrams' stamp: 'JMM 5/25/2000 00:07'! sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber "Send a UDP packet containing the given data to the specified host/port." | bytesToSend bytesSent count | bytesToSend _ aStringOrByteArray size. bytesSent _ 0. [bytesSent < bytesToSend] whileTrue: [ (self waitForSendDoneUntil: (Socket deadlineSecs: 20)) ifFalse: [self error: 'send data timeout; data not sent']. count _ self primSocket: socketHandle sendUDPData: aStringOrByteArray toHost: hostAddress port: portNumber startIndex: bytesSent + 1 count: bytesToSend - bytesSent. bytesSent _ bytesSent + count]. ^ bytesSent ! ! !Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'! setPeer: hostAddress port: port "Set the default send/recv address." self primSocket: socketHandle connectTo: hostAddress port: port. ! ! !Socket methodsFor: 'datagrams' stamp: 'ar 4/30/1999 04:29'! setPort: port "Associate a local port number with a UDP socket. Not applicable to TCP sockets." self primSocket: socketHandle setPort: port. ! ! !Socket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'! getOption: aName "Get options on this socket, see Unix man pages for values for sockets, IP, TCP, UDP. IE SO_KEEPALIVE returns an array, element one is an status number (0 ok, -1 read only option) element two is the resulting of the requested option" (socketHandle == nil or: [self isValid not]) ifTrue: [self error: 'Socket status must valid before getting an option']. ^self primSocket: socketHandle getOption: aName "| foo options | Socket initializeNetwork. foo _ Socket newTCP. foo connectTo: (NetNameResolver addressFromString: '192.168.1.1') port: 80. foo waitForConnectionUntil: (Socket standardDeadline). options _ { 'SO_DEBUG'. 'SO_REUSEADDR'. 'SO_REUSEPORT'. 'SO_DONTROUTE'. 'SO_BROADCAST'. 'SO_SNDBUF'. 'SO_RCVBUF'. 'SO_KEEPALIVE'. 'SO_OOBINLINE'. 'SO_PRIORITY'. 'SO_LINGER'. 'SO_RCVLOWAT'. 'SO_SNDLOWAT'. 'IP_TTL'. 'IP_HDRINCL'. 'IP_RCVOPTS'. 'IP_RCVDSTADDR'. 'IP_MULTICAST_IF'. 'IP_MULTICAST_TTL'. 'IP_MULTICAST_LOOP'. 'UDP_CHECKSUM'. 'TCP_MAXSEG'. 'TCP_NODELAY'. 'TCP_ABORT_THRESHOLD'. 'TCP_CONN_NOTIFY_THRESHOLD'. 'TCP_CONN_ABORT_THRESHOLD'. 'TCP_NOTIFY_THRESHOLD'. 'TCP_URGENT_PTR_TYPE'}. 1 to: options size do: [:i | | fum | fum _foo getOption: (options at: i). Transcript show: (options at: i),fum printString;cr]. foo _ Socket newUDP. foo setPeer: (NetNameResolver addressFromString: '192.168.1.9') port: 7. foo waitForConnectionUntil: (Socket standardDeadline). 1 to: options size do: [:i | | fum | fum _foo getOption: (options at: i). Transcript show: (options at: i),fum printString;cr]. "! ! !Socket methodsFor: 'other' stamp: 'ar 4/30/1999 06:00'! getResponseNoLF "Get the response to the last command." | buf response bytesRead c lf | (self waitForDataUntil: (Socket deadlineSecs: 20)) ifFalse: [ self error: 'getResponse timeout']. lf _ Character lf. buf _ String new: 1000. response _ WriteStream on: ''. [self dataAvailable] whileTrue: [ bytesRead _ self primSocket: socketHandle receiveDataInto: buf startingAt: 1 count: buf size. 1 to: bytesRead do: [ :i | (c _ buf at: i) ~= lf ifTrue: [response nextPut: c]]]. ^ response contents ! ! !Socket methodsFor: 'other' stamp: 'JMM 6/3/2000 19:39'! setOption: aName value: aValue | value | "setup options on this socket, see Unix man pages for values for sockets, IP, TCP, UDP. IE SO_KEEPALIVE returns an array, element one is the error number element two is the resulting of the negotiated value. See getOption for list of keys" (socketHandle == nil or: [self isValid not]) ifTrue: [self error: 'Socket status must valid before setting an option']. value _ aValue asString. aValue == true ifTrue: [value _ '1']. aValue == false ifTrue: [value _ '0']. ^ self primSocket: socketHandle setOption: aName value: value! ! !Socket class methodsFor: 'class initialization' stamp: 'ar 4/30/1999 04:12'! initialize "Socket initialize" "Socket Types" TCPSocketType _ 0. UDPSocketType _ 1. "Socket Status Values" InvalidSocket _ -1. Unconnected _ 0. WaitingForConnection _ 1. Connected _ 2. OtherEndClosed _ 3. ThisEndClosed _ 4. ! ! !Socket class methodsFor: 'instance creation' stamp: 'jm 5/23/2003 12:25'! acceptFrom: aSocket | sock | sock _ super new acceptFrom: aSocket. sock isValid ifFalse: [ "try to reclaim a socket by doing a GC" Smalltalk garbageCollect. sock _ super new acceptFrom: aSocket]. ^ sock ! ! !Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:15'! createIfFail: failBlock "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." "Note: The default creates a TCP socket" ^self tcpCreateIfFail: failBlock! ! !Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:13'! new "Return a new, unconnected Socket. Note that since socket creation may fail, it is safer to use the method createIfFail: to handle such failures gracefully; this method is primarily for backward compatibility and may be disallowed in a future release." "Note: The default creates a TCP socket - this is also backward compatibility." ^self newTCP! ! !Socket class methodsFor: 'instance creation' stamp: 'jm 5/23/2003 12:26'! newTCP "Create a new socket and initialise it for TCP." | sock | sock _ super new initialize: TCPSocketType. sock isValid ifFalse: [ "try to reclaim a socket by doing a GC" Smalltalk garbageCollect. sock _ super new initialize: TCPSocketType]. ^ sock ! ! !Socket class methodsFor: 'instance creation' stamp: 'jm 5/23/2003 12:27'! newUDP "Create a new socket and initialise it for TCP." | sock | sock _ super new initialize: UDPSocketType. sock isValid ifFalse: [ "try to reclaim a socket by doing a GC" Smalltalk garbageCollect. sock _ super new initialize: UDPSocketType]. ^ sock ! ! !Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'! tcpCreateIfFail: failBlock "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." | sock | sock _ super new initialize: TCPSocketType. sock isValid ifFalse: [^ failBlock value]. ^ sock ! ! !Socket class methodsFor: 'instance creation' stamp: 'ar 4/30/1999 04:14'! udpCreateIfFail: failBlock "Attempt to create a new socket. If successful, return the new socket. Otherwise, return the result of evaluating the given block. Socket creation can fail if the network isn't available or if there are not sufficient resources available to create another socket." | sock | sock _ super new initialize: UDPSocketType. sock isValid ifFalse: [^ failBlock value]. ^ sock ! ! !Socket class methodsFor: 'tests' stamp: 'JMM 5/19/2000 22:13'! loopbackTest "Send data from one socket to another on the local machine. Tests most of the socket primitives." "100 timesRepeat: [Socket loopbackTest]" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived t extraBytes packetsSent packetsRead | Transcript cr; show: 'starting loopback test'; cr. Transcript show: '---------- Connecting ----------'; cr. Socket initializeNetwork. sock1 _ Socket new. sock2 _ Socket new. sock1 listenOn: 54321. sock2 connectTo: (NetNameResolver localHostAddress) port: 54321. sock1 waitForConnectionUntil: self standardDeadline. sock2 waitForConnectionUntil: self standardDeadline. (sock1 isConnected) ifFalse: [self error: 'sock1 not connected']. (sock2 isConnected) ifFalse: [self error: 'sock2 not connected']. Transcript show: 'connection established'; cr. bytesToSend _ 5000000. sendBuf _ String new: 5000 withAll: $x. receiveBuf _ String new: 50000. done _ false. packetsSent _ packetsRead _ bytesSent _ bytesReceived _ 0. t _ Time millisecondsToRun: [ [done] whileFalse: [ (sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [ packetsSent _ packetsSent + 1. bytesSent _ bytesSent + (sock1 sendSomeData: sendBuf)]. sock2 dataAvailable ifTrue: [ packetsRead _ packetsRead + 1. bytesReceived _ bytesReceived + (sock2 receiveDataInto: receiveBuf)]. done _ (bytesSent >= bytesToSend) and: [bytesReceived = bytesSent]]]. Transcript show: 'closing connection'; cr. sock1 waitForSendDoneUntil: self standardDeadline. sock1 close. sock2 waitForDisconnectionUntil: self standardDeadline. extraBytes _ sock2 discardReceivedData. extraBytes > 0 ifTrue: [ Transcript show: ' *** received ', extraBytes size printString, ' extra bytes ***'; cr. ]. sock2 close. sock1 waitForDisconnectionUntil: self standardDeadline. (sock1 isUnconnectedOrInvalid) ifFalse: [self error: 'sock1 not closed']. (sock2 isUnconnectedOrInvalid) ifFalse: [self error: 'sock2 not closed']. Transcript show: '---------- Connection Closed ----------'; cr. sock1 destroy. sock2 destroy. Transcript show: 'loopback test done; time = ', t printString; cr. Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' 1000Bytes/sec'; cr. Transcript endEntry. ! ! !Socket class methodsFor: 'tests' stamp: 'JMM 5/22/2000 23:06'! sendTest "Send data to the 'discard' socket of the given host. Tests the speed of one-way data transfers across the network to the given host. Note that many host hosts do not run a discard server." "Socket sendTest" | sock bytesToSend sendBuf bytesSent t serverName serverAddr | Transcript cr; show: 'starting send test'; cr. Socket initializeNetwork. serverName _ FillInTheBlank request: 'What is the destination server?' initialAnswer: 'create.ucsb.edu'. serverAddr _ NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [^ self inform: 'Could not find an address for ', serverName]. sock _ Socket new. Transcript show: '---------- Connecting ----------'; cr. sock connectTo: serverAddr port: 9. sock waitForConnectionUntil: self standardDeadline. (sock isConnected) ifFalse: [ sock destroy. ^ self inform: 'could not connect']. Transcript show: 'connection established; sending data'; cr. bytesToSend _ 1000000. sendBuf _ String new: 64*1024 withAll: $x. bytesSent _ 0. t _ Time millisecondsToRun: [ [bytesSent < bytesToSend] whileTrue: [ sock sendDone ifTrue: [ bytesSent _ bytesSent + (sock sendSomeData: sendBuf)]]]. sock waitForSendDoneUntil: self standardDeadline. sock destroy. Transcript show: '---------- Connection Closed ----------'; cr. Transcript show: 'send test done; time = ', t printString; cr. Transcript show: ((bytesToSend asFloat / t) roundTo: 0.01) printString, ' 1000Bytes/sec'; cr. Transcript endEntry. ! ! !Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 12:13'! nameForWellKnownTCPPort: portNum "Answer the name for the given well-known TCP port number. Answer a string containing the port number if it isn't well-known." | portList entry | portList _ #( (7 'echo') (9 'discard') (13 'time') (19 'characterGenerator') (21 'ftp') (23 'telnet') (25 'smtp') (80 'http') (110 'pop3') (119 'nntp')). entry _ portList detect: [:pair | pair first = portNum] ifNone: [^ 'port-', portNum printString]. ^ entry last ! ! !Socket class methodsFor: 'utilities' stamp: 'jm 11/23/1998 17:19'! ping: hostName "Ping the given host. Useful for checking network connectivity. The host must be running a TCP echo server." "Socket ping: 'squeak.cs.uiuc.edu'" | tcpPort sock serverAddr startTime echoTime | tcpPort _ 7. "7 = echo port, 13 = time port, 19 = character generator port" Socket initializeNetwork. serverAddr _ NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [ ^ self inform: 'Could not find an address for ', hostName]. sock _ Socket new. sock connectTo: serverAddr port: tcpPort. [sock waitForConnectionUntil: (Socket deadlineSecs: 10). sock isConnected] whileFalse: [ (self confirm: 'Continue to wait for connection to ', hostName, '?') ifFalse: [ sock destroy. ^ self]]. sock sendData: 'echo!!'. startTime _ Time millisecondClockValue. [sock waitForDataUntil: (Socket deadlineSecs: 15). sock dataAvailable] whileFalse: [ (self confirm: 'Packet sent but no echo yet; keep waiting?') ifFalse: [ sock destroy. ^ self]]. echoTime _ Time millisecondClockValue - startTime. sock destroy. self inform: hostName, ' responded in ', echoTime printString, ' milliseconds'. ! ! !Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:24'! pingPorts: portList on: hostName timeOutSecs: timeOutSecs "Attempt to connect to each of the given sockets on the given host. Wait at most timeOutSecs for the connections to be established. Answer an array of strings indicating the available ports." "Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: 'squeak.cs.uiuc.edu' timeOutSecs: 15" | serverAddr sockets sock deadline done unconnectedCount connectedCount waitingCount result | Socket initializeNetwork. serverAddr _ NetNameResolver addressForName: hostName timeout: 10. serverAddr = nil ifTrue: [ self inform: 'Could not find an address for ', hostName. ^ #()]. sockets _ portList collect: [:portNum | sock _ Socket new. sock connectTo: serverAddr port: portNum]. deadline _ self deadlineSecs: timeOutSecs. done _ false. [done] whileFalse: [ unconnectedCount _ 0. connectedCount _ 0. waitingCount _ 0. sockets do: [:s | s isUnconnectedOrInvalid ifTrue: [unconnectedCount _ unconnectedCount + 1] ifFalse: [ s isConnected ifTrue: [connectedCount _ connectedCount + 1]. s isWaitingForConnection ifTrue: [waitingCount _ waitingCount + 1]]]. waitingCount = 0 ifTrue: [done _ true]. connectedCount = sockets size ifTrue: [done _ true]. Time millisecondClockValue > deadline ifTrue: [done _ true]]. result _ (sockets select: [:s | s isConnected]) collect: [:s | self nameForWellKnownTCPPort: s remotePort]. sockets do: [:s | s destroy]. ^ result ! ! !Socket class methodsFor: 'utilities' stamp: 'jm 1/14/1999 17:25'! pingPortsOn: hostName "Attempt to connect to a set of well-known sockets on the given host, and answer the names of the available ports." "Socket pingPortsOn: 'www.disney.com'" ^ Socket pingPorts: #(7 13 19 21 23 25 80 110 119) on: hostName timeOutSecs: 20 ! ! !Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'! wildcardAddress "Answer a don't-care address for use with UDP sockets." ^ByteArray new: 4 "0.0.0.0"! ! !Socket class methodsFor: 'utilities' stamp: 'ar 4/30/1999 04:21'! wildcardPort "Answer a don't-care port for use with UDP sockets. (The system will allocate an unused port number to the socket.)" ^0! ! !Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'! register: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry add: anObject! ! !Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:40'! registry WeakArray isFinalizationSupported ifFalse:[^nil]. ^Registry isNil ifTrue:[Registry := WeakRegistry new] ifFalse:[Registry].! ! !Socket class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:22'! unregister: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry remove: anObject ifAbsent:[]! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 21:38'! clientServerTestUDP "Socket clientServerTestUDP" "Performa 6400/200, Linux-PPC 2.1.24: client/server UDP test done; time = 2820 2500 packets, 10000000 bytes sent (3546 kBytes/sec) 2500 packets, 10000000 bytes received (3546 kBytes/sec) 4000 bytes/packet, 886 packets/sec, 0 packets dropped" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. Transcript show: 'creating endpoints'; cr. sock1 _ Socket newUDP. "the sender" sock2 _ Socket newUDP. "the recipient" sock2 setPort: 54321. sock1 setPeer: (NetNameResolver localHostAddress) port: (sock2 port). Transcript show: 'endpoints created'; cr. bytesToSend _ 10000000. sendBuf _ String new: 4000 withAll: $x. receiveBuf _ String new: 50000. done _ false. bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0. t _ Time millisecondsToRun: [ [done] whileFalse: [ (sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [ packetsSent _ packetsSent + 1. bytesSent _ bytesSent + (sock1 sendData: sendBuf)]. sock2 dataAvailable ifTrue: [ packetsReceived _ packetsReceived + 1. bytesReceived _ bytesReceived + (sock2 receiveDataInto: receiveBuf)]. done _ (bytesSent >= bytesToSend)]. sock1 waitForSendDoneUntil: self standardDeadline. bytesReceived _ bytesReceived + sock2 discardReceivedData]. Transcript show: 'closing endpoints'; cr. sock1 close. sock2 close. sock1 destroy. sock2 destroy. Transcript show: 'client/server UDP test done; time = ', t printString; cr. Transcript show: packetsSent printString, ' packets, ', bytesSent printString, ' bytes sent (', (bytesSent * 1000 // t) printString, ' Bytes/sec)'; cr. Transcript show: packetsReceived printString, ' packets, ', bytesReceived printString, ' bytes received (', (bytesReceived * 1000 // t) printString, ' Bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ', (packetsReceived * 1000 // t) printString, ' packets/sec, ', (packetsSent - packetsReceived) printString, ' packets dropped'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/28/2000 23:18'! clientServerTestUDP2 "Socket clientServerTestUDP2" | sock1 sock2 bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t datagramInfo | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. Transcript show: 'creating endpoints'; cr. sock1 _ Socket newUDP. "the sender" sock2 _ Socket newUDP. "the recipient" sock2 setPort: 54321. Transcript show: 'endpoints created'; cr. bytesToSend _ 100000000. sendBuf _ String new: 4000 withAll: $x. receiveBuf _ String new: 2000. done _ false. bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0. t _ Time millisecondsToRun: [ [done] whileFalse: [ (sock1 sendDone and: [bytesSent < bytesToSend]) ifTrue: [ packetsSent _ packetsSent + 1. bytesSent _ bytesSent + (sock1 sendData: sendBuf toHost: (NetNameResolver localHostAddress) port: (sock2 port))]. sock2 dataAvailable ifTrue: [ packetsReceived _ packetsReceived + 1. datagramInfo _ sock2 receiveUDPDataInto: receiveBuf. bytesReceived _ bytesReceived + (datagramInfo at: 1)]. done _ (bytesSent >= bytesToSend)]. sock1 waitForSendDoneUntil: self standardDeadline. bytesReceived _ bytesReceived + sock2 discardReceivedData]. Transcript show: 'closing endpoints'; cr. sock1 close. sock2 close. sock1 destroy. sock2 destroy. Transcript show: 'client/server UDP test done; time = ', t printString; cr. Transcript show: packetsSent printString, ' packets, ', bytesSent printString, ' bytes sent (', (bytesSent * 1000 // t) printString, ' Bytes/sec)'; cr. Transcript show: packetsReceived printString, ' packets, ', bytesReceived printString, ' bytes received (', (bytesReceived * 1000 // t) printString, ' Bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ', (packetsReceived * 1000 // t) printString, ' packets/sec, ', (packetsSent - packetsReceived) printString, ' packets dropped'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 21:41'! remoteTestClientTCP "FIRST start up another image, and execute: Socket remoteTestServerTCP. THEN come back to this image and execute:" "Socket remoteTestClientTCP" "Performa 6400/200, Linux-PPC 2.1.24, both images on same CPU: remoteClient TCP test done; time = 5680 250 packets, 1000000 bytes sent (176 kBytes/sec) 60 packets, 1000000 bytes received (176 kBytes/sec)" | socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. socket _ Socket newTCP. serverName _ FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: Socket standardDeadline. Transcript show: 'client endpoint created'; cr. bytesToSend _ 1000000. sendBuf _ String new: 4000 withAll: $x. receiveBuf _ String new: 50000. done _ false. bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0. t _ Time millisecondsToRun: [ [done] whileFalse: [(socket sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent _ packetsSent + 1. bytesSent _ bytesSent + (socket sendData: sendBuf)]. socket dataAvailable ifTrue: [packetsReceived _ packetsReceived + 1. bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]. done _ (bytesSent >= bytesToSend)]. [bytesReceived < bytesToSend] whileTrue: [socket dataAvailable ifTrue: [packetsReceived _ packetsReceived + 1. bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]]]. socket closeAndDestroy. Transcript show: 'remoteClient TCP test done; time = ', t printString; cr. Transcript show: packetsSent printString, ' packets, ', bytesSent printString, ' bytes sent (', (bytesSent * 1000 // t) printString, ' bytes/sec)'; cr. Transcript show: packetsReceived printString, ' packets, ', bytesReceived printString, ' bytes received (', (bytesReceived * 1000 // t) printString, ' bytes/sec)'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:08'! remoteTestClientTCPOpenClose1000 "Socket remoteTestClientTCPOpenClose1000" | number t1 socket serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. number _ 1000. serverName _ FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. t1 _ Time millisecondsToRun: [number timesRepeat: [socket _ Socket newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: Socket standardDeadline. socket closeAndDestroy]]. Transcript cr;show: 'connects/close per second ', ((number/t1*1000.0) printString); cr. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/21/2000 14:13'! remoteTestClientTCPOpenClosePutGet "Socket remoteTestClientTCPOpenClosePutGet" | checkLength number bytesExpected sendBuf receiveBuf t1 socket bytesReceived serverName | Transcript show: 'starting client/server TCP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. number _ 1000. bytesExpected _ 20000. sendBuf _ String new: 80 withAll: $x. receiveBuf _ String new: 50000. t1 _ Time millisecondsToRun: [number timesRepeat: [socket _ Socket newTCP. socket connectTo: (NetNameResolver addressFromString: serverName) port: 54321. socket waitForConnectionUntil: Socket standardDeadline. socket sendData: sendBuf. socket waitForSendDoneUntil: (Socket deadlineSecs: 5). socket waitForDataUntil: (Socket deadlineSecs: 5). bytesReceived _ 0. [bytesReceived < bytesExpected] whileTrue: [checkLength _ socket receiveDataInto: receiveBuf. bytesReceived _ bytesReceived + checkLength]. socket closeAndDestroy]]. Transcript cr;show: 'connects/get/put/close per second ', ((number/t1*1000.0) printString); cr. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 14:38'! remoteTestClientUDP "FIRST start up another image, and execute: Socket remoteTestServerUDP. THEN come back to this image and execute:" "Socket remoteTestClientUDP" "Performa 6400/200, Linux-PPC 2.1.24: remoteClient UDP test done; time = 4580 2500 packets, 10000000 bytes sent (2183 kBytes/sec) 180 packets, 720000 bytes received (157 kBytes/sec) 4000 bytes/packet, 39 packets/sec, 2320 packets dropped" | socket bytesToSend sendBuf receiveBuf done bytesSent bytesReceived packetsSent packetsReceived t serverName | Transcript show: 'starting client/server UDP test'; cr. Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your remote Test Server?' initialAnswer: ''. socket _ Socket newUDP. socket setPeer: (NetNameResolver addressFromString: serverName) port: 54321. Transcript show: 'client endpoint created'; cr. bytesToSend _ 10000000. sendBuf _ String new: 4000 withAll: $x. receiveBuf _ String new: 4000. done _ false. bytesSent _ bytesReceived _ packetsSent _ packetsReceived _ 0. t _ Time millisecondsToRun: [ [done] whileFalse: [(socket sendDone and: [bytesSent < bytesToSend]) ifTrue: [packetsSent _ packetsSent + 1. bytesSent _ bytesSent + (socket sendData: sendBuf)]. socket dataAvailable ifTrue: [packetsReceived _ packetsReceived + 1. bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]. done _ (bytesSent >= bytesToSend)]. [socket waitForDataUntil: (Socket deadlineSecs: 1). socket dataAvailable] whileTrue: [packetsReceived _ packetsReceived + 1. bytesReceived _ bytesReceived + (socket receiveDataInto: receiveBuf)]]. socket closeAndDestroy. Transcript show: 'remoteClient UDP test done; time = ', t printString; cr. Transcript show: packetsSent printString, ' packets, ', bytesSent printString, ' bytes sent (', (bytesSent * 1000 // t) printString, ' bytes/sec)'; cr. Transcript show: packetsReceived printString, ' packets, ', bytesReceived printString, ' bytes received (', (bytesReceived * 1000 // t) printString, ' bytes/sec)'; cr. Transcript show: (bytesSent // packetsSent) printString, ' bytes/packet, ', (packetsReceived * 1000 // t) printString, ' packets/sec, ', (packetsSent - packetsReceived) printString, ' packets dropped'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:04'! remoteTestServerTCP "See remoteTestClientTCP for instructions on running this method." "Socket remoteTestServerTCP" | socket buffer n | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. socket _ Socket newTCP. socket listenOn: 54321. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer _ String new: 4000. socket waitForConnectionUntil: self standardDeadline. [socket isConnected] whileTrue: [ socket dataAvailable ifTrue: [n _ socket receiveDataInto: buffer. socket sendData: buffer count: n]]. socket closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:12'! remoteTestServerTCPOpenClose1000 "The version of #remoteTestServerTCPOpenClose1000 using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClose1000" | socket server | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. server _ Socket newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse:[self error:'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. 1000 timesRepeat: [socket _ server waitForAcceptUntil: (Socket deadlineSecs: 300). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/19/2000 22:12'! remoteTestServerTCPOpenClosePutGet "The version of #remoteTestServerTCPOpenClosePutGet using the BSD style accept() mechanism." "Socket remoteTestServerTCPOpenClosePutGet" | socket server bytesIWantToSend bytesExpected receiveBuf sendBuf checkLength | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. server _ Socket newTCP. server listenOn: 54321 backlogSize: 20. server isValid ifFalse:[self error:'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. bytesIWantToSend _ 20000. bytesExpected _ 80. receiveBuf _ String new: 40000. sendBuf _ String new: bytesIWantToSend withAll: $x. 1000 timesRepeat: [socket _ server waitForAcceptUntil: (Socket deadlineSecs: 300). socket waitForDataUntil: (Socket deadlineSecs: 5). checkLength _ socket receiveDataInto: receiveBuf. (checkLength ~= bytesExpected) ifTrue: [self halt]. socket sendData: sendBuf. socket waitForSendDoneUntil: (Socket deadlineSecs: 5). socket closeAndDestroy]. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:09'! remoteTestServerTCPUsingAccept "The version of #remoteTestServer using the BSD style accept() mechanism." "Socket remoteTestServerTCPUsingAccept" | socket buffer n server | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. server _ Socket newTCP. server listenOn: 54321 backlogSize: 4. server isValid ifFalse:[self error:'Accept() is not supported']. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer _ String new: 40000. 10 timesRepeat: [socket _ server waitForAcceptUntil: (self deadlineSecs: 300). [socket isConnected] whileTrue: [ socket dataAvailable ifTrue: [n _ socket receiveDataInto: buffer. socket sendData: buffer count: n]]]. socket closeAndDestroy. server closeAndDestroy. Transcript cr; show: 'server endpoint destroyed'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/23/2000 12:25'! remoteTestServerUDP "See remoteTestClientUDP for instructions on running this method." "Socket remoteTestServerUDP" | socket buffer n | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. socket _ Socket newUDP. socket setPort: 54321. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer _ String new: 4000. [true] whileTrue: [ socket dataAvailable ifTrue: [n _ socket receiveDataInto: buffer. socket sendData: buffer count: n]]. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/24/2000 21:55'! remoteTestServerUDP2 "See remoteTestClientUDP for instructions on running this method." "Socket remoteTestServerUDP2" | socket buffer datagramInfo | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. socket _ Socket newUDP. socket setPort: 54321. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer _ String new: 65000. [true] whileTrue: [ socket dataAvailable ifTrue: [datagramInfo _ socket receiveUDPDataInto: buffer. Transcript show: datagramInfo printString;cr. socket sendData: buffer count: (datagramInfo at: 1)]]. ! ! !Socket class methodsFor: 'examples' stamp: 'JMM 5/17/2000 19:54'! remoteTestSinkTCP "See sendTest for instructions on running this method." "Socket remoteTestSinkTCP" | socket buffer n | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. socket _ Socket newTCP. socket listenOn: 9. Transcript show: 'server endpoint created -- run client test in other image'; cr. buffer _ String new: 64000. socket waitForConnectionUntil: self standardDeadline. [socket isConnected] whileTrue: [ socket dataAvailable ifTrue: [n _ socket receiveDataInto: buffer]]. socket closeAndDestroy. Transcript cr; show: 'sink endpoint destroyed'; cr.! ! !Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:57'! timeTest "Socket timeTest" | serverName serverAddr s | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr]. serverAddr _ NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName]. s _ Socket new. Transcript show: '---------- Connecting ----------'; cr. s connectTo: serverAddr port: 13. "13 is the 'daytime' port number" s waitForConnectionUntil: (self deadlineSecs: 1). Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Connection Closed ----------'; cr. ! ! !Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:57'! timeTestUDP "Socket timeTestUDP" | serverName serverAddr s | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr]. serverAddr _ NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName]. s _ Socket newUDP. "a 'random' port number will be allocated by the system" "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. "13 is the daytime service" Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr. ! ! !Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:58'! timeTestUDP2 "Socket timeTestUDP2" | serverName serverAddr s | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr]. serverAddr _ NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName]. s _ Socket newUDP. "The following associates a port with the UDP socket, but does NOT create a connectable endpoint" s setPort: 54321. "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr. ! ! !Socket class methodsFor: 'examples' stamp: 'sge 2/13/2000 07:59'! timeTestUDP3 "Socket timeTestUDP3" | serverName serverAddr s | Transcript show: 'initializing network ... '. Socket initializeNetworkIfFail: [^Transcript show:'failed']. Transcript show:'ok';cr. serverName _ FillInTheBlank request: 'What is your time server?' initialAnswer: 'localhost'. serverName isEmpty ifTrue: [^ Transcript show: 'never mind'; cr]. serverAddr _ NetNameResolver addressForName: serverName timeout: 10. serverAddr = nil ifTrue: [self error: 'Could not find the address for ', serverName]. s _ Socket newUDP. "The following associates a port with the UDP socket, but does NOT create a connectable endpoint" s setPort: (Socket wildcardPort). "explicitly request a default port number" "Send a packet to the daytime port and it will reply with the current date." Transcript show: '---------- Sending datagram from port ' , s port printString , ' ----------'; cr. s sendData: '!!' toHost: serverAddr port: 13. Transcript show: 'the time server reports: ' , s getResponseNoLF. s closeAndDestroy. Transcript show: '---------- Socket closed ----------'; cr. ! ! Sonograms are imageMorphs that will repeatedly plot arrays of values as black on white columns moving to the right in time and scrolling left as necessary.! !Sonogram methodsFor: 'all' stamp: 'jm 11/13/2002 10:58'! extent: newExtent super form: (Form extent: newExtent depth: Display depth). lastX _ -1. columnForm _ Form extent: (32//form depth)@(form height) depth: form depth. pixValMap _ ((1 to: 256) collect: [:i | (Color gray: (256-i)/255.0) pixelValueForDepth: columnForm depth]) as: Bitmap. ! ! !Sonogram methodsFor: 'all' stamp: 'di 8/26/1999 09:01'! extent: extent minVal: min maxVal: max scrollDelta: d minVal _ min. maxVal _ max. scrollDelta _ d. self extent: extent. " try following with scrolldelta = 1, 20, 200 | s data | s _ Sonogram new extent: 200@50 minVal: 0.0 maxVal: 1.0 scrollDelta: 20. World addMorph: s. data _ (1 to: 133) collect: [:i | 0.0]. 1 to: 300 do: [:i | data at: (i\\133)+1 put: 1.0. s plotColumn: data. data at: (i\\133)+1 put: 0.0. World doOneCycleNow]. s delete "! ! !Sonogram methodsFor: 'all' stamp: 'jm 11/13/2002 10:59'! plotColumn: dataArray | chm1 i normVal r | columnForm unhibernate. chm1 _ columnForm height - 1. 0 to: chm1 do: [:y | i _ y*(dataArray size-1)//chm1 + 1. normVal _ ((dataArray at: i) - minVal) / (maxVal - minVal). normVal < 0.0 ifTrue: [normVal _ 0.0]. normVal > 1.0 ifTrue: [normVal _ 1.0]. columnForm bits at: chm1-y+1 put: (pixValMap at: (normVal * 255.0) truncated + 1)]. (lastX _ lastX + 1) > (form width - 1) ifTrue: [self scroll]. form copy: (r _ (lastX@0 extent: 1@form height)) from: (32//form depth-1)@0 in: columnForm rule: Form over. self invalidRect: (r translateBy: self position). ! ! !Sonogram methodsFor: 'all' stamp: 'jm 11/13/2002 10:58'! scroll form copy: (scrollDelta@0 extent: (form width-scrollDelta)@form height) from: form to: 0@0 rule: Form over. lastX _ lastX - scrollDelta. self changed. ! ! I represent a collection of objects ordered by some property of the objects themselves. The ordering is specified in a BlockContext.! !SortedCollection methodsFor: 'accessing' stamp: 'sma 4/28/2000 17:47'! at: anInteger put: anObject self shouldNotImplement! ! !SortedCollection methodsFor: 'accessing' stamp: 'stp 12/05/1999 07:09'! sortBlock: aBlock "Make the argument, aBlock, be the criterion for ordering elements of the receiver." aBlock ifNotNil: [sortBlock := aBlock fixTemps] ifNil: [sortBlock := aBlock]. "The sortBlock must copy its home context, so as to avoid circularities!!" "Therefore sortBlocks with side effects may not work right" self size > 0 ifTrue: [self reSort]! ! !SortedCollection methodsFor: 'adding' stamp: 'go 4/27/2000 13:19'! add: newObject ^ super insert: newObject before: (self indexForInserting: newObject)! ! !SortedCollection methodsFor: 'adding' stamp: 'sma 4/28/2000 18:35'! addAll: aCollection aCollection size > (self size // 3) ifTrue: [aCollection do: [:each | self addLast: each]. self reSort] ifFalse: [aCollection do: [:each | self add: each]]. ^ aCollection! ! !SortedCollection methodsFor: 'adding' stamp: 'go 4/26/2000 17:26'! addFirst: newObject self shouldNotImplement! ! !SortedCollection methodsFor: 'enumerating' stamp: 'sma 2/5/2000 15:22'! collect: aBlock "Evaluate aBlock with each of my elements as the argument. Collect the resulting values into an OrderedCollection. Answer the new collection. Override the superclass in order to produce an OrderedCollection instead of a SortedCollection." | newCollection | newCollection _ OrderedCollection new: self size. self do: [:each | newCollection addLast: (aBlock value: each)]. ^ newCollection! ! !SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:32'! defaultSort: i to: j "Sort elements i through j of self to be nondescending according to sortBlock." "Assume the default sort block ([:x :y | x <= y])." | di dij dj tt ij k l n | "The prefix d means the data at that index." (n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort." "Sort di,dj." di _ array at: i. dj _ array at: j. (di <= dj) "i.e., should di precede dj?" ifFalse: [array swap: i with: j. tt _ di. di _ dj. dj _ tt]. n > 2 ifTrue: "More than two elements." [ij _ (i + j) // 2. "ij is the midpoint of i and j." dij _ array at: ij. "Sort di,dij,dj. Make dij be their median." (di <= dij) "i.e. should di precede dij?" ifTrue: [(dij <= dj) "i.e., should dij precede dj?" ifFalse: [array swap: j with: ij. dij _ dj]] ifFalse: "i.e. di should come after dij" [array swap: i with: ij. dij _ di]. n > 3 ifTrue: "More than three elements." ["Find k>i and l<j such that dk,dij,dl are in reverse order. Swap k and l. Repeat this procedure until k and l pass each other." k _ i. l _ j. [[l _ l - 1. k <= l and: [dij <= (array at: l)]] whileTrue. "i.e. while dl succeeds dij" [k _ k + 1. k <= l and: [(array at: k) <= dij]] whileTrue. "i.e. while dij succeeds dk" k <= l] whileTrue: [array swap: k with: l]. "Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk through dj. Sort those two segments." self defaultSort: i to: l. self defaultSort: k to: j]]! ! !SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:36'! indexForInserting: newObject | index low high | low _ firstIndex. high _ lastIndex. sortBlock isNil ifTrue: [[index _ high + low // 2. low > high] whileFalse: [((array at: index) <= newObject) ifTrue: [low _ index + 1] ifFalse: [high _ index - 1]]] ifFalse: [[index _ high + low // 2. low > high] whileFalse: [(sortBlock value: (array at: index) value: newObject) ifTrue: [low _ index + 1] ifFalse: [high _ index - 1]]]. ^low! ! !SortedCollection methodsFor: 'private' stamp: 'go 4/26/2000 17:17'! insert: anObject before: spot self shouldNotImplement! ! !SortedCollection methodsFor: 'private' stamp: 'sma 4/28/2000 17:46'! reSort self sort: firstIndex to: lastIndex! ! !SortedCollection methodsFor: 'private' stamp: 'stp 04/23/1999 05:33'! sort: i to: j "Sort elements i through j of self to be nondescending according to sortBlock." | di dij dj tt ij k l n | sortBlock ifNil: [^self defaultSort: i to: j]. "The prefix d means the data at that index." (n _ j + 1 - i) <= 1 ifTrue: [^self]. "Nothing to sort." "Sort di,dj." di _ array at: i. dj _ array at: j. (sortBlock value: di value: dj) "i.e., should di precede dj?" ifFalse: [array swap: i with: j. tt _ di. di _ dj. dj _ tt]. n > 2 ifTrue: "More than two elements." [ij _ (i + j) // 2. "ij is the midpoint of i and j." dij _ array at: ij. "Sort di,dij,dj. Make dij be their median." (sortBlock value: di value: dij) "i.e. should di precede dij?" ifTrue: [(sortBlock value: dij value: dj) "i.e., should dij precede dj?" ifFalse: [array swap: j with: ij. dij _ dj]] ifFalse: "i.e. di should come after dij" [array swap: i with: ij. dij _ di]. n > 3 ifTrue: "More than three elements." ["Find k>i and l<j such that dk,dij,dl are in reverse order. Swap k and l. Repeat this procedure until k and l pass each other." k _ i. l _ j. [[l _ l - 1. k <= l and: [sortBlock value: dij value: (array at: l)]] whileTrue. "i.e. while dl succeeds dij" [k _ k + 1. k <= l and: [sortBlock value: (array at: k) value: dij]] whileTrue. "i.e. while dij succeeds dk" k <= l] whileTrue: [array swap: k with: l]. "Now l<k (either 1 or 2 less), and di through dl are all less than or equal to dk through dj. Sort those two segments." self sort: i to: l. self sort: k to: j]]! ! !SortedCollection class methodsFor: 'instance creation' stamp: 'stp 04/23/1999 05:34'! new: anInteger "The default sorting function is a <= comparison on elements." ^(super new: anInteger) "sortBlock: [:x :y | x <= y]" "nil sortBlock OK"! ! SoundBuffers store 16 bit unsigned quantities. ! !SoundBuffer methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! bytesPerElement "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." ^ 2! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/15/1998 13:03'! asByteArray "Answer a ByteArray containing my sample data serialized in most-significant byte first order." | sampleCount bytes dst s | sampleCount _ self monoSampleCount. bytes _ ByteArray new: 2 * sampleCount. dst _ 0. 1 to: sampleCount do: [:src | s _ self at: src. bytes at: (dst _ dst + 1) put: ((s bitShift: -8) bitAnd: 255). bytes at: (dst _ dst + 1) put: (s bitAnd: 255)]. ^ bytes ! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:49'! downSampledLowPassFiltering: doFiltering "Answer a new SoundBuffer half the size of the receiver consisting of every other sample. If doFiltering is true, a simple low-pass filter is applied to avoid aliasing of high frequencies. Assume that receiver is monophonic." "Details: The simple low-pass filter in the current implementation could be improved, at some additional cost." | n resultBuf j | n _ self monoSampleCount. resultBuf _ SoundBuffer newMonoSampleCount: n // 2. j _ 0. doFiltering ifTrue: [ 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (((self at: i) + (self at: i + 1)) bitShift: -1)]] ifFalse: [ 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)]]. ^ resultBuf! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:52'! extractLeftChannel "Answer a new SoundBuffer half the size of the receiver consisting of only the left channel of the receiver, which is assumed to contain stereo sound data." | n resultBuf j | n _ self monoSampleCount. resultBuf _ SoundBuffer newMonoSampleCount: n // 2. j _ 0. 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)]. ^ resultBuf! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 8/18/1998 06:53'! extractRightChannel "Answer a new SoundBuffer half the size of the receiver consisting of only the right channel of the receiver, which is assumed to contain stereo sound data." | n resultBuf j | n _ self monoSampleCount. resultBuf _ SoundBuffer newMonoSampleCount: n // 2. j _ 0. 2 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (self at: i)]. ^ resultBuf! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 10/21/2001 10:43'! lowPassFiltered "Answer a simple low-pass filtered copy of this buffer. Assume it is monophonic." | sz out last this | sz _ self monoSampleCount. out _ self clone. last _ self at: 1. 2 to: sz do: [:i | this _ self at: i. out at: i put: (this + last) // 2. last _ this]. ^ out ! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 11/15/2001 18:26'! mergeStereo "Answer a new SoundBuffer half the size of the receiver that mixes the left and right stereo channels of the receiver, which is assumed to contain stereo sound data." | n resultBuf j | n _ self monoSampleCount. resultBuf _ SoundBuffer newMonoSampleCount: n // 2. j _ 0. 1 to: n by: 2 do: [:i | resultBuf at: (j _ j + 1) put: (((self at: i) + (self at: i + 1)) // 2)]. ^ resultBuf ! ! !SoundBuffer methodsFor: 'utilities' stamp: 'jm 3/28/1999 07:23'! splitStereo "Answer an array of two SoundBuffers half the size of the receiver consisting of the left and right channels of the receiver (which is assumed to contain stereo sound data)." | n leftBuf rightBuf leftIndex rightIndex | n _ self monoSampleCount. leftBuf _ SoundBuffer newMonoSampleCount: n // 2. rightBuf _ SoundBuffer newMonoSampleCount: n // 2. leftIndex _ rightIndex _ 0. 1 to: n by: 2 do: [:i | leftBuf at: (leftIndex _ leftIndex + 1) put: (self at: i). rightBuf at: (rightIndex _ rightIndex + 1) put: (self at: i + 1)]. ^ Array with: leftBuf with: rightBuf ! ! !SoundBuffer methodsFor: 'objects from disk' stamp: 'tk 2/3/2000 20:32'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Swap each pair of bytes (16-bit word), if the current machine is Little Endian. Why is this the right thing to do? We are using memory as a byteStream. High and low bytes are reversed in each 16-bit word, but the stream of words ascends through memory. Different from a Bitmap." | hack blt | Smalltalk endianness == #little ifTrue: [ "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 1. blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" blt sourceX: 1; destX: 0; copyBits. blt sourceX: 0; destX: 1; copyBits. blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" blt sourceX: 3; destX: 2; copyBits. blt sourceX: 2; destX: 3; copyBits]. ! ! !SoundBuffer methodsFor: 'objects from disk' stamp: 'jm 10/29/2001 19:53'! reverseEndianness "Swap the bytes of each 16-bit word, using a fast BitBlt hack." | hack blt | hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 1. blt sourceX: 0; destX: 1; copyBits. "Exchange bytes 0 and 1" blt sourceX: 1; destX: 0; copyBits. blt sourceX: 0; destX: 1; copyBits. blt sourceX: 2; destX: 3; copyBits. "Exchange bytes 2 and 3" blt sourceX: 3; destX: 2; copyBits. blt sourceX: 2; destX: 3; copyBits. ! ! !SoundBuffer methodsFor: 'objects from disk' stamp: 'tk 2/5/2000 16:15'! swapHalves "A normal switch in endianness (byte order in words) reverses the order of 4 bytes. That is not correct for SoundBuffers, which use 2-bytes units. If a normal switch has be done, this method corrects it further by swapping the two halves of the long word." | hack blt | "The implementation is a hack, but fast for large ranges" hack _ Form new hackBits: self. blt _ (BitBlt toForm: hack) sourceForm: hack. blt combinationRule: Form reverse. "XOR" blt sourceY: 0; destY: 0; height: self size; width: 2. blt sourceX: 0; destX: 2; copyBits. "Exchange bytes 0&1 with 2&3" blt sourceX: 2; destX: 0; copyBits. blt sourceX: 0; destX: 2; copyBits. ! ! !SoundBuffer methodsFor: 'objects from disk' stamp: 'tk 2/5/2000 21:52'! writeOn: aStream | reversed convertToBytes | "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds." convertToBytes _ aStream originalContents "collection" class isBytes. (aStream isKindOf: FileStream) ifTrue: [convertToBytes _ false]. "knows how" aStream nextInt32Put: self size. Smalltalk endianness == #big ifTrue: ["no change" convertToBytes ifTrue: [self do: [:vv | aStream nextNumber: 4 put: vv]] "Later define (aStream nextPutWordsAll:) that uses BitBlt to put words on a non-file byteStream quickly" ifFalse: [aStream nextPutAll: self]] "files use this" ifFalse: [ reversed _ self clone. reversed restoreEndianness. "swap an extra time to get to big endian format" convertToBytes ifTrue: [reversed do: [:vv | aStream nextNumber: 4 put: vv]] ifFalse: [aStream nextPutAll: reversed]] ! ! !SoundBuffer class methodsFor: 'instance creation' stamp: 'jm 8/15/1998 14:35'! fromByteArray: aByteArray "Convert the given ByteArray (stored with the most significant byte first) into 16-bit sample buffer." | n buf src w | n _ aByteArray size // 2. buf _ SoundBuffer newMonoSampleCount: n. src _ 1. 1 to: n do: [:i | w _ ((aByteArray at: src) bitShift: 8) + (aByteArray at: src + 1). w > 32767 ifTrue: [w _ w - 65536]. buf at: i put: w. src _ src + 2]. ^ buf ! ! !SoundBuffer class methodsFor: 'instance creation' stamp: 'tk 2/5/2000 22:00'! newFromStream: s | len | len _ s nextInt32. ^ s nextWordsInto: (self new: len)! ! I am an abstract class that describes the protocol for sound codecs. Each codec (the name stems from "COder/DECoder") describes a particular algorithm for compressing and decompressing sound data. Most sound codecs are called 'lossy' because they lose information; the decompressed sound data is not exactly the same as the original data. ! !SoundCodec methodsFor: 'initialization' stamp: 'jm 5/30/2003 10:32'! initialize self reset. ! ! !SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'! compressAndDecompress: aSound "Compress and decompress the given sound. Useful for testing." "(MuLawCodec new compressAndDecompress: (SampledSound soundNamed: 'camera')) play" ^ (self compressSound: aSound) asSound ! ! !SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 2/2/1999 16:01'! compressSound: aSound "Compress the entirety of the given sound with this codec. Answer a CompressedSoundData." | compressed channels | compressed _ CompressedSoundData new codecName: self class name; soundClassName: aSound class name. (aSound isKindOf: SampledSound) ifTrue: [ channels _ Array new: 1. channels at: 1 put: (self encodeSoundBuffer: aSound samples). compressed channels: channels; samplingRate: aSound originalSamplingRate; firstSample: 1; loopEnd: aSound samples size; loopLength: 0.0; perceivedPitch: 100.0; gain: aSound loudness. ^ compressed]. (aSound isKindOf: LoopedSampledSound) ifTrue: [ aSound isStereo ifTrue: [ channels _ Array new: 2. channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples). channels at: 2 put: (self encodeSoundBuffer: aSound rightSamples)] ifFalse: [ channels _ Array new: 1. channels at: 1 put: (self encodeSoundBuffer: aSound leftSamples)]. compressed channels: channels; samplingRate: aSound originalSamplingRate; firstSample: aSound firstSample; loopEnd: aSound loopEnd; loopLength: aSound loopLength; perceivedPitch: aSound perceivedPitch; gain: aSound gain. ^ compressed]. self error: 'you can only compress sampled sounds'. ! ! !SoundCodec methodsFor: 'compress/decompress' stamp: 'jm 3/30/1999 08:03'! decompressSound: aCompressedSound "Decompress the entirety of the given compressed sound with this codec and answer the resulting sound." | channels sound | channels _ aCompressedSound channels collect: [:compressed | self decodeCompressedData: compressed]. 'SampledSound' = aCompressedSound soundClassName ifTrue: [ sound _ SampledSound samples: channels first samplingRate: (aCompressedSound samplingRate). sound loudness: aCompressedSound gain. ^ sound]. 'LoopedSampledSound' = aCompressedSound soundClassName ifTrue: [ aCompressedSound loopLength = 0 ifTrue: [ sound _ LoopedSampledSound unloopedSamples: channels first pitch: aCompressedSound perceivedPitch samplingRate: aCompressedSound samplingRate] ifFalse: [ sound _ LoopedSampledSound samples: channels first loopEnd: aCompressedSound loopEnd loopLength: aCompressedSound loopLength pitch: aCompressedSound perceivedPitch samplingRate: aCompressedSound samplingRate]. channels size > 1 ifTrue: [sound rightSamples: channels last]. sound firstSample: aCompressedSound firstSample; gain: aCompressedSound gain. sound setPitch: 100.0 dur: (channels first size / aCompressedSound samplingRate) loudness: 1.0. ^ sound]. self error: 'unknown sound class'. ! ! !SoundCodec methodsFor: 'subclass responsibilities' stamp: 'di 2/8/1999 14:23'! bytesPerEncodedFrame "Answer the number of bytes required to hold one frame of compressed sound data. Answer zero if this codec produces encoded frames of variable size." self subclassResponsibility. ! ! !SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:38'! decodeFrames: frameCount from: srcByteArray at: srcIndex into: dstSoundBuffer at: dstIndex "Decode the given number of monophonic frames starting at the given index in the given ByteArray of compressed sound data and storing the decoded samples into the given SoundBuffer starting at the given destination index. Answer a pair containing the number of bytes of compressed data consumed and the number of decompressed samples produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." self subclassResponsibility. ! ! !SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:39'! encodeFrames: frameCount from: srcSoundBuffer at: srcIndex into: dstByteArray at: dstIndex "Encode the given number of frames starting at the given index in the given monophonic SoundBuffer and storing the encoded sound data into the given ByteArray starting at the given destination index. Encode only as many complete frames as will fit into the destination. Answer a pair containing the number of samples consumed and the number of bytes of compressed data produced." "Note: Assume that the sender has ensured that the given number of frames will not exhaust either the source or destination buffers." self subclassResponsibility. ! ! !SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/4/1999 11:30'! reset "Reset my encoding and decoding state. Optional. This default implementation does nothing." ! ! !SoundCodec methodsFor: 'subclass responsibilities' stamp: 'jm 2/2/1999 15:45'! samplesPerFrame "Answer the number of sound samples per compression frame." self subclassResponsibility. ! ! !SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:53'! decodeCompressedData: aByteArray "Decode the entirety of the given encoded data buffer with this codec. Answer a monophonic SoundBuffer containing the uncompressed samples." | frameCount result increments | frameCount _ self frameCount: aByteArray. result _ SoundBuffer newMonoSampleCount: frameCount * self samplesPerFrame. self reset. increments _ self decodeFrames: frameCount from: aByteArray at: 1 into: result at: 1. ((increments first = aByteArray size) and: [increments last = result size]) ifFalse: [ self error: 'implementation problem; increment sizes should match buffer sizes']. ^ result ! ! !SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 14:20'! encodeSoundBuffer: aSoundBuffer "Encode the entirety of the given monophonic SoundBuffer with this codec. Answer a ByteArray containing the compressed sound data." | codeFrameSize frameSize fullFrameCount lastFrameSamples result increments finalFrame i lastIncs | frameSize _ self samplesPerFrame. fullFrameCount _ aSoundBuffer monoSampleCount // frameSize. lastFrameSamples _ aSoundBuffer monoSampleCount - (fullFrameCount * frameSize). codeFrameSize _ self bytesPerEncodedFrame. codeFrameSize = 0 ifTrue: ["Allow room for 1 byte per sample for variable-length compression" codeFrameSize _ frameSize]. lastFrameSamples > 0 ifTrue: [result _ ByteArray new: (fullFrameCount + 1) * codeFrameSize] ifFalse: [result _ ByteArray new: fullFrameCount * codeFrameSize]. self reset. increments _ self encodeFrames: fullFrameCount from: aSoundBuffer at: 1 into: result at: 1. lastFrameSamples > 0 ifTrue: [ finalFrame _ SoundBuffer newMonoSampleCount: frameSize. i _ fullFrameCount * frameSize. 1 to: lastFrameSamples do: [:j | finalFrame at: j put: (aSoundBuffer at: (i _ i + 1))]. lastIncs _ self encodeFrames: 1 from: finalFrame at: 1 into: result at: 1 + increments second. increments _ Array with: increments first + lastIncs first with: increments second + lastIncs second]. increments second < result size ifTrue: [^ result copyFrom: 1 to: increments second] ifFalse: [^ result] ! ! !SoundCodec methodsFor: 'private' stamp: 'di 2/8/1999 19:54'! frameCount: aByteArray "Compute the frame count for this byteArray. This default computation will have to be overridden by codecs with variable frame sizes." | codeFrameSize | codeFrameSize _ self bytesPerEncodedFrame. (aByteArray size \\ codeFrameSize) = 0 ifFalse: [self error: 'encoded buffer is not an even multiple of the encoded frame size']. ^ aByteArray size // codeFrameSize! ! This subclass of SoundRecorder supports real-time processing of incoming sound data. The sound input process queues raw sound buffers, allowing them to be read and processed by the client as they become available. A semaphore is used to synchronize between the record process and the client process. Since sound data is buffered, the client process may lag behind the input process without losing data. ! !SoundInputStream methodsFor: 'initialization' stamp: 'jm 9/8/1999 15:22'! initialize super initialize. bufferSize _ 1024. mutex _ nil. ! ! !SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'! bufferCount "Answer the number of sound buffers that have been queued." | n | mutex ifNil: [^ 0]. "not recording" mutex critical: [n _ recordedBuffers size]. ^ n ! ! !SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:36'! bufferSize ^ bufferSize ! ! !SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:26'! bufferSize: aNumber "Set the sound buffer size. Buffers of this size will be queued for the client to process." bufferSize _ aNumber truncated. ! ! !SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/8/1999 15:23'! isRecording "Answer true if the sound input process is running." ^ recordProcess ~~ nil ! ! !SoundInputStream methodsFor: 'accessing' stamp: 'jm 9/6/1999 10:32'! nextBufferOrNil "Answer the next input buffer or nil if no buffer is available." | result | mutex ifNil: [^ nil]. "not recording" mutex critical: [ recordedBuffers size > 0 ifTrue: [result _ recordedBuffers removeFirst] ifFalse: [result _ nil]]. ^ result ! ! !SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'! startRecording "Start the sound input process." recordProcess ifNotNil: [self stopRecording]. recordedBuffers _ OrderedCollection new: 100. mutex _ Semaphore forMutualExclusion. super startRecording. paused _ false. ! ! !SoundInputStream methodsFor: 'recording controls' stamp: 'jm 9/8/1999 15:23'! stopRecording "Turn off the sound input process and close the driver." super stopRecording. recordedBuffers _ nil. mutex _ nil. ! ! !SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'! allocateBuffer "Allocate a new buffer and reset nextIndex. This message is sent by the sound input process." currentBuffer _ SoundBuffer newMonoSampleCount: bufferSize. nextIndex _ 1. ! ! !SoundInputStream methodsFor: 'private' stamp: 'jm 9/8/1999 15:24'! emitBuffer: buffer "Queue a buffer for later processing. This message is sent by the sound input process." mutex critical: [recordedBuffers addLast: buffer]. ! ! !SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:13'! initialize "SoundPlayer initialize; shutDown; startUp" "Details: BufferMSecs represents a tradeoff between latency and quality. If BufferMSecs is too low, the sound will not play smoothly, especially during long-running primitives such as large BitBlts. If BufferMSecs is too high, there will be a long time lag between when a sound buffer is submitted to be played and when that sound is actually heard. BufferMSecs is typically in the range 50-200." SamplingRate _ 22050. BufferMSecs _ 120. Stereo _ true. UseReverb ifNil: [UseReverb _ true]. ! ! !SoundPlayer class methodsFor: 'initialization' stamp: 'jm 1/14/1999 13:14'! useShortBuffer "Experimental support for real-time MIDI input. This only works on platforms whose hardware allows very short buffer sizes. It has been tested on a Macintosh Powerbook G3." "SoundPlayer useShortBuffer" self shutDown. BufferMSecs _ 15. SoundPlayer startPlayerProcessBufferSize: (BufferMSecs * SamplingRate) // 1000 rate: SamplingRate stereo: Stereo. ! ! !SoundPlayer class methodsFor: 'accessing' stamp: 'jm 8/13/1998 15:00'! bufferMSecs ^ BufferMSecs ! ! !SoundPlayer class methodsFor: 'playing' stamp: 'tk 6/24/1999 11:42'! canStartPlayer "Some platforms do no support simultaneous record and play. If this is one of those platforms, return false if there is a running SoundRecorder." SoundRecorder canRecordWhilePlaying ifTrue: [^ true]. SoundRecorder allSubInstancesDo: [:rec | rec isActive ifTrue: [^ false]]. ^ true ! ! !SoundPlayer class methodsFor: 'playing' stamp: 'di 8/5/1998 23:08'! isPlaying: aSound ^ ActiveSounds includes: aSound! ! !SoundPlayer class methodsFor: 'playing' stamp: 'jm 9/8/1998 17:54'! resumePlaying: aSound "Start playing the given sound without resetting it; it will resume playing from where it last stopped." "Implementation detail: On virtual machines that don't support the quickstart primitive, you may need to edit this method to pass false to resumePlaying:quickStart:." self resumePlaying: aSound quickStart: true. ! ! !SoundPlayer class methodsFor: 'playing' stamp: 'sw 1/12/2000 22:43'! resumePlaying: aSound quickStart: quickStart "Start playing the given sound without resetting it; it will resume playing from where it last stopped. If quickStart is true, then try to start playing the given sound immediately." | doQuickStart | Preferences soundsEnabled ifFalse: [^ self]. doQuickStart _ quickStart. Preferences soundQuickStart ifFalse: [doQuickStart _ false]. PlayerProcess == nil ifTrue: [ self canStartPlayer ifFalse: [^ self]. self startUp. "Check if startup was successful" SoundSupported ifFalse:[^self]. doQuickStart _ false]. PlayerSemaphore critical: [ (ActiveSounds includes: aSound) ifTrue: [doQuickStart _ false] ifFalse: [ doQuickStart ifFalse: [ActiveSounds add: aSound]]]. "quick-start the given sound, unless the sound player has just started" doQuickStart ifTrue: [self startPlayingImmediately: aSound]. ! ! !SoundPlayer class methodsFor: 'player process' stamp: 'ar 12/5/1998 16:37'! startPlayerProcessBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag "Start the sound player process. Terminate the old process, if any." "SoundPlayer startPlayerProcessBufferSize: 1000 rate: 11025 stereo: false" self stopPlayerProcess. ActiveSounds _ OrderedCollection new. Buffer _ SoundBuffer newStereoSampleCount: (bufferSize // 4) * 4. PlayerSemaphore _ Semaphore forMutualExclusion. SamplingRate _ samplesPerSecond. Stereo _ stereoFlag. ReadyForBuffer _ Semaphore new. SoundSupported _ true. "Assume so" UseReadySemaphore _ true. "set to false if ready semaphore not supported by VM" self primSoundStartBufferSize: Buffer stereoSampleCount rate: samplesPerSecond stereo: Stereo semaIndex: (Smalltalk registerExternalObject: ReadyForBuffer). "Check if sound start prim was successful" SoundSupported ifFalse:[^self]. UseReadySemaphore ifTrue: [PlayerProcess _ [SoundPlayer playLoop] newProcess] ifFalse: [PlayerProcess _ [SoundPlayer oldStylePlayLoop] newProcess]. UseReverb ifTrue: [self startReverb]. PlayerProcess priority: Processor userInterruptPriority. PlayerProcess resume.! ! !SoundPlayer class methodsFor: 'player process' stamp: 'jm 6/7/1999 10:40'! startReverb "Start a delay-line style reverb with the given tap delays and gains. Tap delays are given in samples and should be prime integers; the following comment gives an expression that generates primes." "Integer primesUpTo: 22050" UseReverb _ true. ReverbState _ ReverbSound new tapDelays: #(1601 7919) gains: #(0.12 0.07). ! ! !SoundPlayer class methodsFor: 'private' stamp: 'ar 12/5/1998 16:36'! primSoundStartBufferSize: bufferSize rate: samplesPerSecond stereo: stereoFlag "Start double-buffered sound output with the given buffer size and sampling rate. This version has been superceded by primitive 171 (primSoundStartBufferSize:rate:stereo:semaIndex:)." "ar 12/5/1998 Turn off the sound if not supported" <primitive: 170> SoundSupported _ false.! ! !SoundPlayer class methodsFor: 'private' stamp: 'jm 6/7/1999 10:35'! startPlayingImmediately: aSound "Private!! Start playing the given sound as soon as possible by mixing it into the sound output buffers of the underlying sound driver." | totalSamples buf n leftover src rest | "first, fill a double-size buffer with samples" "Note: The code below assumes that totalSamples contains two buffers worth of samples, and the insertSamples primitive is expected to consume at least one buffer's worth of these samples. The remaining samples are guaranteed to fit into a single buffer." totalSamples _ Buffer stereoSampleCount * 2. "two buffer's worth" buf _ SoundBuffer newStereoSampleCount: totalSamples. aSound playSampleCount: totalSamples into: buf startingAt: 1. ReverbState == nil ifFalse: [ ReverbState applyReverbTo: buf startingAt: 1 count: totalSamples]. PlayerSemaphore critical: [ "insert as many samples as possible into the sound driver's buffers" n _ self primSoundInsertSamples: totalSamples from: buf samplesOfLeadTime: 1024. leftover _ totalSamples - n. "copy the remainder of buf into Buffer" "Note: the following loop iterates over 16-bit words, not two-word stereo slices" "assert: 0 < leftover <= Buffer stereoSampleCount" src _ 2 * n. 1 to: 2 * leftover do: [:dst | Buffer at: dst put: (buf at: (src _ src + 1))]. "generate enough additional samples to finish filling Buffer" rest _ Buffer stereoSampleCount - leftover. aSound playSampleCount: rest into: Buffer startingAt: leftover + 1. ReverbState == nil ifFalse: [ ReverbState applyReverbTo: Buffer startingAt: leftover + 1 count: rest]. "record the fact that this sound has already been played into Buffer so that we don't process it again this time around" SoundJustStarted _ aSound. ActiveSounds add: aSound]. ! ! !SoundRecorder methodsFor: 'initialization' stamp: 'jm 4/22/1999 14:30'! initialize "SoundRecorder new" stereo _ false. samplingRate _ 11025. recordLevel _ 0.5. self initializeRecordingState. ! ! !SoundRecorder methodsFor: 'accessing' stamp: 'di 2/17/1999 11:08'! codec: aSoundCodec codec _ aSoundCodec! ! !SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:03'! recordLevel ^ recordLevel ! ! !SoundRecorder methodsFor: 'accessing' stamp: 'jm 7/4/1998 15:04'! recordLevel: level "Set the desired recording level to the given value in the range 0.0 to 1.0, where 0.0 is the lowest recording level and 1.0 is the maximum. Do nothing if the sound input hardware does not support changing the recording level." "Details: On the Macintosh, the lowest possible record level attenuates the input signal, but does not silence it entirely." recordLevel _ (level asFloat min: 1.0) max: 0.0. recordProcess ifNotNil: [ self primSetRecordLevel: (1000.0 * recordLevel) asInteger]. ! ! !SoundRecorder methodsFor: 'accessing' stamp: 'di 2/16/1999 09:58'! samplingRate: newRate samplingRate _ newRate "Best are 44100 22050 11025" ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'di 2/17/1999 10:54'! clearRecordedSound "Clear the sound recorded thus far. Go into pause mode if currently recording." paused _ true. recordedSound _ SequentialSound new. self allocateBuffer. ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'di 2/16/1999 09:13'! pause "Go into pause mode. The record level continues to be updated, but no sound is recorded." paused _ true. ((currentBuffer ~~ nil) and: [nextIndex > 1]) ifTrue: [self emitPartialBuffer. self allocateBuffer]. soundPlaying ifNotNil: [ soundPlaying pause. soundPlaying _ nil]. CanRecordWhilePlaying ifFalse: [self stopRecording]. ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'jm 6/15/2003 23:54'! playback "Playback the sound that has been recorded." self pause. soundPlaying _ self recordedSound. soundPlaying ifNotNil: [soundPlaying play]. ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'di 3/4/1999 22:38'! startRecording "Turn of the sound input driver and start the recording process. Initially, recording is paused." | semaIndex | recordLevel ifNil: [recordLevel _ 0.5]. "lazy initialization" CanRecordWhilePlaying ifFalse: [SoundPlayer shutDown]. recordProcess ifNotNil: [self stopRecording]. paused _ true. meteringBuffer _ SoundBuffer newMonoSampleCount: 1024. meterLevel _ 0. self allocateBuffer. bufferAvailableSema _ Semaphore new. semaIndex _ Smalltalk registerExternalObject: bufferAvailableSema. self primStartRecordingDesiredSampleRate: samplingRate asInteger stereo: stereo semaIndex: semaIndex. samplingRate _ self primGetActualRecordingSampleRate. self primSetRecordLevel: (1000.0 * recordLevel) asInteger. recordProcess _ [self recordLoop] newProcess. recordProcess priority: Processor userInterruptPriority. recordProcess resume. ! ! !SoundRecorder methodsFor: 'recording controls' stamp: 'di 2/16/1999 09:13'! stopRecording "Stop the recording process and turn of the sound input driver." recordProcess ifNotNil: [recordProcess terminate]. recordProcess _ nil. self primStopRecording. Smalltalk unregisterExternalObject: bufferAvailableSema. ((currentBuffer ~~ nil) and: [nextIndex > 1]) ifTrue: [self emitPartialBuffer]. self initializeRecordingState. ! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'! endPlace ^ Array with: recordedBuffers size with: recordedBuffers last size! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 22:11'! firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace "Beginning at startPlace, this routine will return the first place at which a sample exceeds the given threshold." | buf s iStart jStart nThreshold | nThreshold _ threshold negated. iStart _ startPlace first. jStart _ startPlace second. iStart to: recordedBuffers size do: [:i | buf _ recordedBuffers at: i. jStart to: buf size do: [:j | s _ (buf at: j) - dcOffset. (s < nThreshold or: [s > threshold]) ifTrue: ["found a sample over threshold" ^ Array with: i with: j]]. jStart _ 1]. ^ self endPlace! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:01'! place: startPlace plus: nSamples "Return the place that is nSamples (may be negative) beyond thisPlace." | i j remaining buf | i _ startPlace first. j _ startPlace second. nSamples >= 0 ifTrue: [remaining _ nSamples. [buf _ recordedBuffers at: i. (j + remaining) <= buf size ifTrue: [^ Array with: i with: j + remaining]. i < recordedBuffers size] whileTrue: [remaining _ remaining - (buf size - j + 1). i _ i+1. j _ 1]. ^ self endPlace] ifFalse: [remaining _ nSamples negated. [buf _ recordedBuffers at: i. (j - remaining) >= 1 ifTrue: [^ Array with: i with: j - remaining]. i > 1] whileTrue: [remaining _ remaining - j. i _ i-1. j _ (recordedBuffers at: i) size]. ^ #(1 1)]! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 2/16/1999 23:19'! scanForEndThreshold: threshold dcOffset: dcOffset minLull: lull startingAt: startPlace "Beginning at startPlace, this routine will find the last sound that exceeds threshold, such that if you look lull samples later you will not find another sound over threshold within the following block of lull samples. Return the place that is lull samples beyond to that last sound. If no end of sound is found, return endPlace." | buf s iStart jStart nThreshold n | nThreshold _ threshold negated. iStart _ startPlace first. jStart _ startPlace second. n _ 0. iStart to: recordedBuffers size do: [:i | buf _ recordedBuffers at: i. jStart to: buf size do: [:j | s _ (buf at: j) - dcOffset. (s < nThreshold or: [s > threshold]) ifTrue: ["found a sample over threshold" n _ 0] ifFalse: ["still not over threshold" n _ n + 1. n >= lull ifTrue: [^ Array with: i with: j]]]. jStart _ 1]. ^ self endPlace! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 22:13'! scanForStartThreshold: threshold dcOffset: dcOffset minDur: duration startingAt: startPlace "Beginning at startPlace, this routine will find the first sound that exceeds threshold, such that if you look duration samples later you will find another sound over threshold within the following block of duration samples. Return the place that is duration samples prior to that first sound. If no sound is found, return endPlace." | soundPlace lookPlace nextSoundPlace thirdPlace | soundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: startPlace. [soundPlace = self endPlace ifTrue: [^ soundPlace]. "Found a sound -- look duration later" lookPlace _ self place: soundPlace plus: duration. nextSoundPlace _ self firstSampleOverThreshold: threshold dcOffset: dcOffset startingAt: lookPlace. thirdPlace _ self place: lookPlace plus: duration. nextSoundPlace first < thirdPlace first or: [nextSoundPlace first = thirdPlace first and: [nextSoundPlace second < thirdPlace second]]] whileFalse: [soundPlace _ nextSoundPlace]. "Yes, there is sound in the next interval as well" ^ self place: soundPlace plus: 0-duration ! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 3/4/1999 21:26'! segmentsAbove: threshold normalizedVolume: percentOfMaxVolume "Break the current recording up into a sequence of sound segments separated by silences." | max min sum totalSamples bufSize s dcOffset firstPlace endPlace resultBuf nFactor lastPlace segments gapSize minDur minLull soundSize restSize | stereo ifTrue: [self error: 'stereo trimming is not yet supported']. paused ifFalse: [self error: 'must stop recording before trimming']. (recordedSound == nil or: [recordedSound sounds isEmpty]) ifTrue:[^ self]. "Reconstruct buffers so old trimming code will work" recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. soundSize _ restSize _ 0. max _ min _ sum _ totalSamples _ 0. recordedBuffers do: [:buf | bufSize _ buf size. totalSamples _ totalSamples + buf size. 1 to: bufSize do: [:i | s _ buf at: i. s > max ifTrue: [max _ s]. s < min ifTrue: [min _ s]. sum _ sum + s]]. dcOffset _ sum // totalSamples. minDur _ (samplingRate/20.0) asInteger. " 1/20 second " minLull _ (samplingRate/4.0) asInteger. " 1/2 second " segments _ SequentialSound new. endPlace _ self endPlace. lastPlace _ #(1 1). [firstPlace _ self scanForStartThreshold: threshold dcOffset: dcOffset minDur: minDur startingAt: lastPlace. firstPlace = endPlace] whileFalse: [firstPlace = lastPlace ifFalse: ["Add a silence equal to the gap size" "Wasteful but simple way to get gap size..." gapSize _ (self copyFrom: lastPlace to: firstPlace normalize: 1000 dcOffset: dcOffset) size - 2. "... -2 makes up for overlap of one sample on either end" segments add: (RestSound dur: gapSize asFloat / samplingRate). restSize _ restSize + gapSize. "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: gapSize; space; show: 'gap'." ]. lastPlace _ self scanForEndThreshold: threshold dcOffset: dcOffset minLull: minLull + minDur startingAt: firstPlace. "Allow room for lead time of next sound" lastPlace _ self place: lastPlace plus: minDur negated. nFactor _ self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset. resultBuf _ self copyFrom: firstPlace to: lastPlace normalize: nFactor dcOffset: dcOffset. soundSize _ soundSize + resultBuf size. "Transcript cr; print: firstPlace; space; print: lastPlace; space; print: resultBuf size; space; show: 'sound'." segments add: (codec == nil ifTrue: [SampledSound new setSamples: resultBuf samplingRate: samplingRate] ifFalse: [codec compressSound: (SampledSound new setSamples: resultBuf samplingRate: samplingRate)])]. "Final gap for consistency" gapSize _ (self copyFrom: lastPlace to: self endPlace normalize: 1000 dcOffset: dcOffset) size - 1. segments add: (RestSound dur: gapSize asFloat / samplingRate). restSize _ restSize + gapSize. PopUpMenu notify: ((soundSize+restSize/samplingRate) roundTo: 0.1) printString , ' secs reduced to ' , ((soundSize/samplingRate) roundTo: 0.1) printString. recordedBuffers _ nil. ^ segments! ! !SoundRecorder methodsFor: 'trimming' stamp: 'di 2/17/1999 20:38'! suppressSilence recordedSound _ self soundSegments! ! !SoundRecorder methodsFor: 'trimming' stamp: 'jm 6/15/2003 23:56'! trim: threshold normalizedVolume: percentOfMaxVolume "Remove the leading and trailing parts of this recording that are below the given threshold. Remove any DC offset and scale the recording so that its peaks are the given percent of the maximum volume." | max min sum totalSamples bufSize s dcOffset startPlace endPlace resultBuf nFactor | recordedSound ifNil: [^ self]. stereo ifTrue: [self error: 'stereo trimming is not yet supported']. paused ifFalse: [self error: 'must stop recording before trimming']. recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. recordedBuffers isEmpty ifTrue: [^ self]. max _ min _ sum _ totalSamples _ 0. recordedBuffers do: [:buf | bufSize _ buf size. totalSamples _ totalSamples + buf size. 1 to: bufSize do: [:i | s _ buf at: i. s > max ifTrue: [max _ s]. s < min ifTrue: [min _ s]. sum _ sum + s]]. dcOffset _ sum // totalSamples. "a place is an array of <buffer index><index of sample in buffer>" startPlace _ self scanForStartThreshold: threshold dcOffset: dcOffset minDur: (samplingRate/60.0) asInteger "at least 1/60th of a second" startingAt: #(1 1). startPlace = self endPlace ifTrue: ["no samples above threshold" recordedBuffers _ nil. ^ self]. endPlace _ self scanForEndThreshold: threshold dcOffset: dcOffset minLull: (samplingRate/5) asInteger startingAt: startPlace. nFactor _ self normalizeFactorFor: percentOfMaxVolume min: min max: max dcOffset: dcOffset. resultBuf _ self copyFrom: startPlace to: endPlace normalize: nFactor dcOffset: dcOffset. recordedSound _ SampledSound new setSamples: resultBuf samplingRate: samplingRate. recordedBuffers _ nil ! ! !SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'! allocateBuffer "Allocate a new buffer and reset nextIndex." | bufferTime | bufferTime _ stereo "Buffer time = 1/2 second" ifTrue: [self samplingRate asInteger] ifFalse: [self samplingRate asInteger // 2]. currentBuffer _ SoundBuffer newMonoSampleCount: "Multiple of samplesPerFrame that is approx. bufferTime long" (bufferTime truncateTo: self samplesPerFrame). nextIndex _ 1. ! ! !SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 10:52'! emitBuffer: buffer | sound | sound _ SampledSound new setSamples: buffer samplingRate: samplingRate. recordedSound add: (codec == nil ifTrue: [sound] ifFalse: [codec compressSound: sound])! ! !SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 11:13'! emitPartialBuffer | s | s _ self samplesPerFrame. self emitBuffer: (currentBuffer copyFrom: 1 to: ((nextIndex-1) +( s-1) truncateTo: s))! ! !SoundRecorder methodsFor: 'private' stamp: 'di 2/16/1999 08:55'! recordLoop "Record process loop that records samples." | n sampleCount | n _ 0. [true] whileTrue: [ n = 0 ifTrue: [bufferAvailableSema wait]. paused ifTrue: [ n _ self primRecordSamplesInto: meteringBuffer startingAt: 1. self meterFrom: 1 count: n in: meteringBuffer] ifFalse: [ n _ self primRecordSamplesInto: currentBuffer startingAt: nextIndex. self meterFrom: nextIndex count: n in: currentBuffer. nextIndex _ nextIndex + n. stereo ifTrue: [sampleCount _ currentBuffer stereoSampleCount] ifFalse: [sampleCount _ currentBuffer monoSampleCount]. nextIndex > sampleCount ifTrue: [ self emitBuffer: currentBuffer. self allocateBuffer]]]. ! ! !SoundRecorder methodsFor: 'private' stamp: 'di 2/17/1999 10:39'! samplesPerFrame "Can be overridden to quantize buffer size for, eg, fixed-frame codecs" codec == nil ifTrue: [^ 1] ifFalse: [^ codec samplesPerFrame]! ! !SoundRecorder methodsFor: 'results' stamp: 'jm 6/15/2003 23:56'! condensedSamples "Return a single SoundBuffer that is the contatenation of all my recorded buffers." | sz newBuf i | recordedSound ifNil: [^ SoundBuffer new: 0]. recordedBuffers _ recordedSound sounds collect: [:snd | snd samples]. recordedBuffers isEmpty ifTrue: [^ SoundBuffer new: 0]. recordedBuffers size = 1 ifTrue: [^ recordedBuffers first copy]. sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size]. newBuf _ SoundBuffer newMonoSampleCount: sz. i _ 1. recordedBuffers do: [:b | 1 to: b size do: [:j | newBuf at: i put: (b at: j). i _ i + 1]]. recordedBuffers _ nil. ^ newBuf ! ! !SoundRecorder methodsFor: 'results' stamp: 'di 2/16/1999 20:49'! condensedStereoSound "Decompose my buffers into left and right channels and return a mixed sound consisting of the those two channels. This may be take a while, since the data must be copied into new buffers." | sz leftBuf rightBuf leftI rightI left | sz _ recordedBuffers inject: 0 into: [:tot :buff | tot + buff size]. leftBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2. rightBuf _ SoundBuffer newMonoSampleCount: (sz + 1) // 2. leftI _ rightI _ 1. left _ true. recordedBuffers do: [:b | 1 to: b size do: [:j | left ifTrue: [leftBuf at: leftI put: (b at: j). leftI _ leftI + 1. left _ false] ifFalse: [rightBuf at: rightI put: (b at: j). rightI _ rightI + 1. left _ true]]]. ^ MixedSound new add: (SampledSound new setSamples: leftBuf samplingRate: samplingRate) pan: 0.0; add: (SampledSound new setSamples: rightBuf samplingRate: samplingRate) pan: 1.0 ! ! !SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 11:07'! recordedSound "Return the sound that was recorded." ^ recordedSound ! ! !SoundRecorder methodsFor: 'results' stamp: 'di 2/17/1999 21:24'! soundSegments ^ self segmentsAbove: 1000 normalizedVolume: 80.0 ! ! This class is an abstract superclass for source code access mechanisms. It defines the messages that need to be understood by those subclasses that store and retrieve source chunks on files, over the network or in databases. The first concrete subclass, StandardSourceFileArray, supports access to the traditional sources and changes files. Other subclasses might implement multiple source files for different applications, or access to a network source server.! ]style[(254 23 184)f1,f1LStandardSourceFileArray Comment;,f1! !SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:42'! at: index self subclassResponsibility! ! !SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'! at: index put: aFileStream self subclassResponsibility! ! !SourceFileArray methodsFor: 'accessing' stamp: 'ar 5/17/2000 18:28'! collect: aBlock | copy | copy _ self species new: self size. 1 to: self size do:[:i| copy at: i put: (aBlock value: (self at: i))]. ^copy! ! !SourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/26/2000 21:43'! size self subclassResponsibility! ! !SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'! fileIndexFromSourcePointer: anInteger "Return the index of a source file corresponding to the given source pointer." self subclassResponsibility! ! !SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:00'! filePositionFromSourcePointer: anInteger "Return the position within a source file for the given source pointer." self subclassResponsibility! ! !SourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 22:01'! sourcePointerFromFileIndex: index andPosition: position "Return a sourcePointer encoding the given file index and position" self subclassResponsibility! ! I am a tool for analyzing sound data from a microphone, CD, or other input source in real time. I have several display modes: signal snapshots of the raw signal data as it arrives spectrum frequency spectrum of the signal data as it arrives sonogram scrolling plot of the frequency spectrum over time, where the vertical axis is frequency, the horizontal axis is time, and amount of energy at a given frequency is shown as a grayscale value with larger values being darker To use this tool, be sure that you have selected the proper sound source using you host OS facilities. Set the desired sampling rate and FFT size (try 22050 samples/sec and an FFT size of 512) then click on the 'start' button. Use the slider to adjust the level so that the yellow level indicator peaks somewhere between the middle and the right edge at the maximum signal level. Note that if the level meter peaks hit the right edge, you will get 'clipping', which creates a bunch of spurious high frequency noise in the frequency spectrum. If the display is set to 'signal' mode, you can actually see the tops and bottoms of the waveform being cut off when clipping occurs. Many machines may not be able to perform spectrum analysis in real time, especially at higher sampling rates and larger FFT sizes. In both 'signal' and 'spectrum' modes, this tool will skip data to try to keep up with real time. However, in 'sonogram' mode it always processes all the data, even if it falls behind. This allows you to get a complete sonogram without dropouts even on a slower machine. However, as the sonogram display falls behind there will be a larger and larger time lag between when a sound is input and when it appears on the display. The smaller the FFT size, the less frequency resolution you get. The lower the sampling rate, the less total frequency range you get. For an FFT size of N and a sampling rate of R, each of the N/2 'bins' of the frequency spectrum has a frequency resolution of R / N. For example, at a sampleing rate of 22050 samples/second, the total frequency range is 0 to 11025 Hz and an FFT of size 256 would divide this range into 128 bins (the output of an FFT of size N has N/2 bins), each of which covers a frequency band about 86 Hz wide. To increase time resolution, increase the sampling rate and decrease the FFT size. ! !SpectrumAnalyzerMorph methodsFor: 'initialization' stamp: 'jm 9/8/1999 17:59'! initialize super initialize. borderWidth _ 2. orientation _ #vertical. soundInput _ SoundInputStream new samplingRate: 22050. fft _ FFT new: 512. displayType _ 'sonogram'. self addButtonRow. self addLevelSlider. self addMorphBack: self makeLevelMeter. self addMorphBack: (Morph new extent: 10@10; color: Color transparent). "spacer" self resetDisplay. "adds the display morph" ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:11'! invokeMenu "Invoke the settings menu." | aMenu | aMenu _ CustomMenu new. aMenu addList: #( ('set sampling rate' setSamplingRate) ('set FFT size' setFFTSize) ('set display type' setDisplayType)). aMenu invokeOn: self defaultSelection: nil. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 12:52'! resetDisplay "Recreate my display after changing some parameter such as FFT size." displayType = 'signal' ifTrue: [self showSignal]. displayType = 'spectrum' ifTrue: [self showSpectrum]. displayType = 'sonogram' ifTrue: [self showSonogram]. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'! setDisplayType "Set the display type." | aMenu choice on | aMenu _ CustomMenu new title: 'display type (currently ', displayType, ')'. aMenu addList: #( ('signal' 'signal') ('spectrum' 'spectrum') ('sonogram' 'sonogram')). choice _ aMenu startUp. choice ifNil: [^ self]. on _ soundInput isRecording. self stop. displayType _ choice. self resetDisplay. on ifTrue: [self start]. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 19:38'! setFFTSize "Set the size of the FFT used for frequency analysis." | aMenu sz on | aMenu _ CustomMenu new title: 'FFT size (currently ', fft n printString, ')'. ((7 to: 10) collect: [:n | 2 raisedTo: n]) do:[:r | aMenu add: r printString action: r]. sz _ aMenu startUp. sz ifNil: [^ self]. on _ soundInput isRecording. self stop. fft _ FFT new: sz. self resetDisplay. on ifTrue: [self start]. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'! setSamplingRate "Set the sampling rate to be used for incoming sound data." | aMenu rate on | aMenu _ CustomMenu new title: 'Sampling rate (currently ', soundInput samplingRate printString, ')'. #(11025 22050 44100) do:[:r | aMenu add: r printString action: r]. rate _ aMenu startUp. rate ifNil: [^ self]. on _ soundInput isRecording. self stop. soundInput samplingRate: rate. self resetDisplay. on ifTrue: [self start]. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'! start "Start displaying sound data." displayType = 'signal' ifTrue: [soundInput bufferSize: graphMorph width - (2 * graphMorph borderWidth)] ifFalse: [soundInput bufferSize: fft n]. soundInput startRecording. ! ! !SpectrumAnalyzerMorph methodsFor: 'menu and buttons' stamp: 'jm 9/8/1999 15:12'! stop "Stop displaying sound data." soundInput stopRecording. ! ! !SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/8/1999 19:05'! step "Update the record light, level meter, and display." | w | "update the record light and level meter" soundInput isRecording ifTrue: [statusLight color: Color yellow] ifFalse: [statusLight color: Color gray]. w _ ((121 * soundInput meterLevel) // 100) max: 1. levelMeter width ~= w ifTrue: [levelMeter width: w]. "update the display if any data is available" self updateDisplay. ! ! !SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/7/1999 22:26'! stepTime ^ 0 ! ! !SpectrumAnalyzerMorph methodsFor: 'stepping' stamp: 'jm 9/6/1999 12:12'! stopStepping "Turn off recording." super stopStepping. soundInput stopRecording. ! ! !SpectrumAnalyzerMorph methodsFor: 'deletion' stamp: 'jm 9/6/1999 14:40'! delete "Turn off recording when this morph is deleted." super delete. soundInput stopRecording. ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 12:44'! addButtonRow | r | r _ AlignmentMorph newRow vResizing: #shrinkWrap. r addMorphBack: (self buttonName: 'Menu' action: #invokeMenu). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Start' action: #start). r addMorphBack: (Morph new extent: 4@1; color: Color transparent). r addMorphBack: (self buttonName: 'Stop' action: #stop). r addMorphBack: (Morph new extent: 12@1; color: Color transparent). r addMorphBack: self makeStatusLight. self addMorphBack: r. ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/7/1999 18:01'! addLevelSlider | levelSlider r | levelSlider _ SimpleSliderMorph new color: color; extent: 100@2; target: soundInput; actionSelector: #recordLevel:; adjustToValue: soundInput recordLevel. r _ AlignmentMorph newRow color: color; inset: 0; centering: #center; hResizing: #shrinkWrap; vResizing: #rigid; height: 24. r addMorphBack: (StringMorph contents: '0 '). r addMorphBack: levelSlider. r addMorphBack: (StringMorph contents: ' 10'). self addMorphBack: r. ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jhm 10/15/97 14:30'! buttonName: aString action: aSymbol ^ SimpleButtonMorph new target: self; label: aString; actionSelector: aSymbol ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 6/15/2003 10:29'! makeLevelMeter | outerBox | outerBox _ BorderedMorph new extent: 125@14; color: Color lightGray. levelMeter _ Morph new extent: 2@10; color: Color yellow. levelMeter position: outerBox topLeft + (2@2). outerBox addMorph: levelMeter. ^ outerBox ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 6/15/2003 10:29'! makeStatusLight | s | statusLight _ BorderedMorph new extent: 24@19. statusLight color: Color gray. s _ StringMorph contents: 'On'. s position: statusLight center - (s extent // 2). statusLight addMorph: s. ^ statusLight ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 18:41'! processBuffer: buf "Analyze one buffer of data." | data | displayType = 'signal' ifTrue: [data _ buf] ifFalse: [data _ fft transformDataFrom: buf startingAt: 1]. graphMorph ifNotNil: [graphMorph data: data; changed]. sonogramMorph ifNotNil: [ data _ data collect: [:v | v sqrt]. "square root compresses dynamic range" data /= 400.0. sonogramMorph plotColumn: (data copyFrom: 1 to: data size // 1)]. ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 12:49'! removeAllDisplays "Remove all currently showing displays." sonogramMorph ifNotNil: [sonogramMorph delete]. graphMorph ifNotNil: [graphMorph delete]. sonogramMorph _ graphMorph _ nil. ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:56'! showSignal "Display the actual signal waveform." displayType _ 'signal'. self removeAllDisplays. graphMorph _ GraphMorph new. graphMorph extent: (400 + (2 * graphMorph borderWidth))@128. graphMorph data: (Array new: 100 withAll: 0). graphMorph color: (Color r: 0.8 g: 1.0 b: 1.0). self addMorphBack: graphMorph. self extent: 10@10. "shrink to minimum size" ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:43'! showSonogram "Display a sonogram showing the frequency spectrum versus time." | zeros h w | displayType _ 'sonogram'. self removeAllDisplays. h _ fft n // 2. h _ h min: 512 max: 64. w _ 400. sonogramMorph _ Sonogram new extent: w@h minVal: 0.0 maxVal: 1.0 scrollDelta: w. zeros _ Array new: sonogramMorph height withAll: 0. sonogramMorph width timesRepeat: [sonogramMorph plotColumn: zeros]. self addMorphBack: sonogramMorph. self extent: 10@10. "shrink to minimum size" ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 15:10'! showSpectrum "Display the frequency spectrum." displayType _ 'spectrum'. self removeAllDisplays. graphMorph _ GraphMorph new. graphMorph extent: ((fft n // 2) + (2 * graphMorph borderWidth))@128. graphMorph data: (Array new: fft n // 2 withAll: 0). self addMorphBack: graphMorph. self extent: 10@10. "shrink to minimum size" ! ! !SpectrumAnalyzerMorph methodsFor: 'private' stamp: 'jm 9/8/1999 19:39'! updateDisplay "Update the display if any data is available." | buf bufCount | soundInput bufferCount = 0 ifTrue: [^ self]. graphMorph ifNotNil: [ [soundInput bufferCount > 0] whileTrue: [ "skip to the most recent buffer" buf _ soundInput nextBufferOrNil]. ^ self processBuffer: buf]. sonogramMorph ifNotNil: [ "at small buffer sizes we have to update the sonogram in batches or we may get behind; shoot for 8 updates/second" bufCount _ (soundInput samplingRate / (8 * soundInput bufferSize)) truncated max: 1. [bufCount > 0 and: [soundInput bufferCount > 0]] whileTrue: [ self processBuffer: (soundInput nextBufferOrNil)]]. ! ! !SpectrumAnalyzerMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! I represent a SelectionMenu which operates like a modal dialog for selecting files, somewhat similar to the StandardFile dialogs in MacOS and Java Swing. Try for example, the following: StandardFileMenu oldFile inspect StandardFileMenu newFile inspect ! !StandardFileMenu methodsFor: 'menu building' stamp: 'di 5/12/2000 10:31'! directoryNamesString: aDirectory "Answer a string concatenating the directory name strings in aDirectory, each string followed by a '[...]' indicator, and followed by a cr." ^ String streamContents: [:s | aDirectory directoryNames do: [:dn | s nextPutAll: dn withBlanksTrimmed , ' [...]'; cr]] ! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'jm 8/3/2003 15:43'! fileNamesString: aDirectory "Answer a string concatenating the file name strings in aDirectory, each string followed by a cr." ^ String streamContents: [:s | (self matchingFileNamesFor: aDirectory) do: [:fn | s nextPutAll: fn withBlanksTrimmed; cr]]. ! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'jm 8/3/2003 15:27'! makeFileMenuFor: aDirectory "Initialize an instance of me to operate on aDirectory" | theMenu | Cursor wait showWhile: [self labels: (self menuLabelsString: aDirectory) font: (MenuStyle fontAt: 1) lines: (self menuLinesArray: aDirectory). theMenu _ self selections: (self menuSelectionsArray: aDirectory)]. ^theMenu! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'acg 4/15/1999 21:57'! menuLabelsString: aDirectory "Answer a menu labels object corresponding to aDirectory" ^ String streamContents: [:s | canTypeFileName ifTrue: [s nextPutAll: 'Enter File Name...'; cr]. s nextPutAll: (self pathPartsString: aDirectory). s nextPutAll: (self directoryNamesString: aDirectory). s nextPutAll: (self fileNamesString: aDirectory). s skip: -1]! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'ti 5/10/2000 11:18'! menuLinesArray: aDirectory "Answer a menu lines object corresponding to aDirectory" | typeCount nameCnt | typeCount _ canTypeFileName ifTrue: [1] ifFalse: [0]. nameCnt _ aDirectory directoryNames size. ^Array streamContents: [:s | canTypeFileName ifTrue: [s nextPut: 1]. s nextPut: aDirectory pathParts size + typeCount + 1. s nextPut: aDirectory pathParts size + nameCnt + typeCount + 1]! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'jm 8/3/2003 15:38'! menuSelectionsArray: dir "Answer a menu selections object corresponding to dir. The object is an array corresponding to each item, each element itself constituting a two-element array, the first element of which contains a selector to operate on and the second element of which contains the parameters for that selector." | count showIt ext | count _ dir pathParts size. ^ Array streamContents: [:s | canTypeFileName ifTrue: [ s nextPut: (StandardFileMenuResult directory: dir name: nil)]. s nextPut: (StandardFileMenuResult directory: FileDirectory root name: ''). dir pathParts doWithIndex: [:d :i | s nextPut: (StandardFileMenuResult directory: (self advance: count - i containingDirectoriesFrom: dir) name: '')]. dir directoryNames do: [:dn | s nextPut: (StandardFileMenuResult directory: (FileDirectory on: (dir fullNameFor: dn)) name: '')]. dir fileNames do: [:fn | extensions ifNil: [showIt _ true] ifNotNil: [ ext _ (FileDirectory extensionFor: fn) asLowercase. showIt _ extensions includes: ext]. showIt ifTrue: [ s nextPut: (StandardFileMenuResult directory: dir name: fn)]]]! ! !StandardFileMenu methodsFor: 'menu building' stamp: 'jm 6/6/2003 07:35'! pathPartsString: aDirectory "Answer a string concatenating the path parts strings in aDirectory, each string followed by a cr." ^ String streamContents: [:s | s nextPutAll: '[]'; cr. aDirectory pathParts asArray doWithIndex: [:part :i | i timesRepeat: [s space]. s nextPutAll: part withBlanksTrimmed; cr]] ! ! !StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 4/15/1999 21:52'! confirmExistingFiles: aResult |choice| (aResult directory fileExists: aResult name) ifFalse: [^aResult]. choice _ (PopUpMenu labels: 'overwrite that file choose another name cancel') startUpWithCaption: aResult name, ' already exists.'. choice = 1 ifTrue: [ aResult directory deleteFileNamed: aResult name ifAbsent: [^self startUpWithCaption: 'Can''t delete ', aResult name, ' Select another file']. ^aResult]. choice = 2 ifTrue: [^self startUpWithCaption: 'Select Another File']. ^nil ! ! !StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 4/15/1999 22:32'! getTypedFileName: aResult | name | name _ FillInTheBlank request: 'Enter a new file name' initialAnswer: ''. name = '' ifTrue: [^self startUpWithCaption: 'Select a File:']. name _ aResult directory fullNameFor: name. ^ StandardFileMenuResult directory: (FileDirectory forFileName: name) name: (FileDirectory localNameFor: name) ! ! !StandardFileMenu methodsFor: 'basic control sequences' stamp: 'acg 9/28/1999 23:34'! startUpWithCaption: aString at: location |result| result _ super startUpWithCaption: aString at: location. result ifNil: [^nil]. result isDirectory ifTrue: [self makeFileMenuFor: result directory. self computeForm. ^self startUpWithCaption: aString at: location]. result isCommand ifTrue: [result _ self getTypedFileName: result. result ifNil: [^nil]]. canTypeFileName ifTrue: [^self confirmExistingFiles: result]. ^result ! ! !StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 00:32'! advance: anInteger containingDirectoriesFrom: aDirectory | theDirectory | theDirectory _ aDirectory. 1 to: anInteger do: [:i | theDirectory _ theDirectory containingDirectory]. ^theDirectory! ! !StandardFileMenu methodsFor: 'private' stamp: 'jm 8/3/2003 15:43'! matchingFileNamesFor: aDirectory | ext | ^ aDirectory fileNames select: [:fn | extensions ifNil: [true] ifNotNil: [ ext _ (FileDirectory extensionFor: fn) asLowercase. extensions includes: ext]]. ! ! !StandardFileMenu methodsFor: 'private' stamp: 'acg 4/15/1999 22:03'! newFileFrom: aDirectory canTypeFileName _ true. ^self makeFileMenuFor: aDirectory! ! !StandardFileMenu methodsFor: 'private' stamp: 'jm 8/3/2003 15:36'! oldFileFrom: aDirectory extensions: arrayOrNil canTypeFileName _ false. extensions _ arrayOrNil. ^ self makeFileMenuFor: aDirectory ! ! !StandardFileMenu class methodsFor: 'instance creation' stamp: 'jm 8/3/2003 15:23'! newFileMenu: aDirectory Smalltalk isMorphic ifFalse: [^ PluggableFileList newFileMenu: aDirectory]. ^ super new newFileFrom: aDirectory ! ! !StandardFileMenu class methodsFor: 'instance creation' stamp: 'jm 8/3/2003 15:56'! oldFileMenu: aDirectory extensions: arrayOrNil Smalltalk isMorphic ifFalse: [^ PluggableFileList oldFileMenu: aDirectory]. ^ super new oldFileFrom: aDirectory extensions: arrayOrNil ! ! !StandardFileMenu class methodsFor: 'standard file operations' stamp: 'jm 8/3/2003 15:53'! newFile ^ self newFileFrom: FileDirectory default ! ! !StandardFileMenu class methodsFor: 'standard file operations' stamp: 'jm 8/3/2003 15:55'! newFileFrom: aDirectory ^ (self newFileMenu: aDirectory) startUpWithCaption: 'Select a File:' ! ! !StandardFileMenu class methodsFor: 'standard file operations' stamp: 'jm 8/3/2003 16:00'! oldFile ^ self oldFileFrom: FileDirectory default extensions: nil ! ! !StandardFileMenu class methodsFor: 'standard file operations' stamp: 'jm 8/3/2003 16:04'! oldFileExtensions: anArrayOrNil ^ self oldFileFrom: FileDirectory default extensions: anArrayOrNil ! ! !StandardFileMenu class methodsFor: 'standard file operations' stamp: 'jm 8/3/2003 16:00'! oldFileFrom: aDirectory extensions: anArrayOrNil ^ (self oldFileMenu: aDirectory extensions: anArrayOrNil) startUpWithCaption: 'Select a File:' ! ! Records the file name and directory result of a file selection. ! !StandardFileMenuResult methodsFor: 'accessing' stamp: 'jm 8/3/2003 15:20'! directory ^ directory ! ! !StandardFileMenuResult methodsFor: 'accessing' stamp: 'jm 8/3/2003 15:20'! name ^ name ! ! !StandardFileMenuResult methodsFor: 'accessing' stamp: 'jm 8/3/2003 15:19'! printOn: aStream super printOn: aStream. aStream nextPut: $(. name printOn: aStream. aStream nextPutAll: ' in '. aStream nextPutAll: directory pathName. aStream nextPut: $). ! ! !StandardFileMenuResult methodsFor: 'testing' stamp: 'jm 8/3/2003 15:20'! isCommand ^ name isNil ! ! !StandardFileMenuResult methodsFor: 'testing' stamp: 'jm 8/3/2003 15:20'! isDirectory ^ name = '' ! ! !StandardFileMenuResult methodsFor: 'private' stamp: 'jm 8/3/2003 15:21'! directory: aDirectory name: aString directory _ aDirectory. name _ aString. ! ! !StandardFileMenuResult class methodsFor: 'instance creation' stamp: 'jm 8/3/2003 15:21'! directory: aDirectory name: aString ^ super new directory: aDirectory name: aString ! ! Provides a simple, platform-independent, interface to a file system. This initial version ignores issues of Directories etc. The instance-variable fallbackStream at the moment holds an instance of HFSMacFileStream, to bridge us to the new world while in the old. The instance variable rwmode, inherited from class PositionableStream, here is used to hold a Boolean -- true means opened for read-write, false means opened for read-only. 2/12/96 sw! !StandardFileStream methodsFor: 'open/close' stamp: 'ar 10/7/1998 14:43'! close "Close this file." fileID ifNotNil: [ self primClose: fileID. self unregister. fileID _ nil]. ! ! !StandardFileStream methodsFor: 'open/close' stamp: 'jm 2/6/2002 08:33'! closed "Answer true if this file is closed." ^ fileID isNil or: [(self primSizeNoError: fileID) isNil] ! ! !StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 16:20'! ensureOpen "Make sure that this file really is open." self closed ifTrue: [^ self reopen]. (self primSizeNoError: fileID) ifNotNil: [^ self]. self reopen. ! ! !StandardFileStream methodsFor: 'open/close' stamp: 'ar 10/7/1998 14:44'! open: fileName forWrite: writeMode "Open the file with the given name. If writeMode is true, allow writing, otherwise open the file in read-only mode." "Changed to do a GC and retry before failing ar 3/21/98 17:25" fileID _ self retryWithGC:[self primOpen: fileName writable: writeMode] until:[:id| id notNil]. fileID ifNil: [^ nil]. "allows sender to detect failure" self register. name _ fileName. rwmode _ writeMode. buffer1 _ String new: 1. ! ! !StandardFileStream methodsFor: 'open/close' stamp: 'jm 9/21/1998 13:58'! reopen "Close and reopen this file. The file position is reset to zero." "Details: Files that were open when a snapshot occurs are no longer valid when the snapshot is resumed. This operation re-opens the file if that has happened." fileID ifNotNil: [self primCloseNoError: fileID]. self open: name forWrite: rwmode. ! ! !StandardFileStream methodsFor: 'properties-setting' stamp: 'tk 11/4/1998 19:17'! isReadOnly ^ rwmode not ! ! !StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 9/21/1998 13:56'! readOnly "Make this file read-only." rwmode _ false. ! ! !StandardFileStream methodsFor: 'properties-setting' stamp: 'jm 9/21/1998 13:56'! readWrite "Make this file writable." rwmode _ true. ! ! !StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:16'! directory "Return the directory containing this file." ^ FileDirectory forFileName: self fullName ! ! !StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'! fullName "Answer this file's full path name." ^ name ! ! !StandardFileStream methodsFor: 'access' stamp: 'ar 11/24/1998 14:00'! localName ^ name ifNotNil: [(name findTokens: FileDirectory pathNameDelimiter asString) last]! ! !StandardFileStream methodsFor: 'access' stamp: 'jm 9/21/1998 14:19'! name "Answer this file's full path name." ^ name ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'! basicNext "Answer the next byte from this file, or nil if at the end of the file." | count | count _ self primRead: fileID into: buffer1 startingAt: 1 count: 1. count = 1 ifTrue: [^ buffer1 at: 1] ifFalse: [^ nil]. ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 3/15/2000 10:31'! compressFile "Write a new file that has the data in me compressed in GZip format." | zipped buffer | self readOnly; binary. zipped _ self directory newFileNamed: (self name, FileDirectory dot, 'gz'). zipped binary; setFileTypeToObject. "Type and Creator not to be text, so can be enclosed in an email" zipped _ GZipWriteStream on: zipped. buffer _ ByteArray new: 50000. 'Compressing ', self fullName displayProgressAt: Sensor cursorPoint from: 0 to: self size during: [:bar | [self atEnd] whileFalse: [ bar value: self position. zipped nextPutAll: (self nextInto: buffer)]. zipped close. self close]. ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'! next "Answer the next byte from this file, or nil if at the end of the file." ^ self basicNext! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 12/23/1999 15:02'! next: n into: aString startingAt: startIndex "Read n bytes into the given string. Return aString or a partial copy if less than n elements have been read." | count | count _ self primRead: fileID into: aString startingAt: startIndex count: n. count = n ifTrue:[^aString] ifFalse:[^aString copyFrom: 1 to: startIndex+count-1]! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'ar 1/2/2000 15:33'! next: anInteger putAll: aString startingAt: startIndex "Store the next anInteger elements from the given collection." rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. self primWrite: fileID from: aString startingAt: startIndex count: anInteger. ^aString! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:55'! nextPut: char "Write the given character to this file." rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. buffer1 at: 1 put: char. self primWrite: fileID from: buffer1 startingAt: 1 count: 1. ^ char ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:43'! nextPutAll: aString "Write all the characters of the given string to this file." rwmode ifFalse: [^ self error: 'Cannot write a read-only file']. self primWrite: fileID from: aString startingAt: 1 count: aString basicSize. ^ aString ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 2/5/2000 21:58'! nextWordsInto: aBitmap "Note: The file primitives automatically adjust for word based objects." self next: aBitmap basicSize into: aBitmap startingAt: 1. aBitmap restoreEndianness. ^ aBitmap! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'tk 10/15/1998 09:30'! padToEndWith: aChar "On the Mac, files do not truncate. One can delete the old file and write a new one, but sometime deletion fails (file still open? file stale?). This is a sad compromise. Just let the file be the same length but pad it with a harmless character." | pad | self atEnd ifTrue: [^ self]. pad _ self isBinary ifTrue: [aChar asCharacter asciiValue] "ok for char or number" ifFalse: [aChar asCharacter]. self nextPutAll: (buffer1 class new: ((self size - self position) min: 20000) withAll: pad).! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'mir 2/25/2000 12:37'! peek "Answer what would be returned if the message next were sent to the receiver. If the receiver is at the end, answer nil. " | next | self atEnd ifTrue: [^ nil]. next _ self basicNext. self position: self position - 1. ^ next! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 10/27/2002 10:45'! upToEnd "Answer a subcollection from the current access position through the last element of the receiver." | buffer | buffer _ buffer1 species new: (self size - self position). self nextInto: buffer. ^ buffer ! ! !StandardFileStream methodsFor: 'read, write, position' stamp: 'jm 9/21/1998 13:56'! verbatim: aString "A version of nextPutAll that can be called knowing it won't call nextPut: " ^ self nextPutAll: aString ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 16:18'! primAtEnd: id "Answer true if the file position is at the end of the file." <primitive: 150> self primitiveFailed ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 14:02'! primClose: id "Close this file." <primitive: 151> self primitiveFailed ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 14:02'! primCloseNoError: id "Close this file. Don't raise an error if the primitive fails." <primitive: 151> ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 14:04'! primGetPosition: id "Get this files current position." <primitive: 152> self primitiveFailed ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 14:06'! primOpen: fileName writable: writableFlag "Open a file of the given name, and return the file ID obtained. If writableFlag is true, then if there is none with this name, then create one else prepare to overwrite the existing from the beginning otherwise if the file exists, open it read-only else return nil" <primitive: 153> ^ nil ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 16:18'! primRead: id into: byteArray startingAt: startIndex count: count "Read up to count bytes of data from this file into the given string or byte array starting at the given index. Answer the number of bytes actually read." <primitive: 154> self closed ifTrue: [^ self error: 'File is closed']. self error: 'File read failed'. ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 14:09'! primSetPosition: id to: anInteger "Set this file to the given position." <primitive: 155> self primitiveFailed ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 16:17'! primSize: id "Answer the size of this file." <primitive: 157> self primitiveFailed ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 16:17'! primSizeNoError: id "Answer the size of this file. Answer nil if the primitive fails; this indicates that the file handle has become stale." <primitive: 157> ^ nil ! ! !StandardFileStream methodsFor: 'primitives' stamp: 'jm 9/21/1998 16:18'! primWrite: id from: stringOrByteArray startingAt: startIndex count: count "Write count bytes onto this file from the given string or byte array starting at the given index. Answer the number of bytes written." <primitive: 158> self closed ifTrue: [^ self error: 'File is closed']. self error: 'File write failed'. ! ! !StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'! register ^self class register: self! ! !StandardFileStream methodsFor: 'registry' stamp: 'ar 3/21/98 17:23'! unregister ^self class unregister: self! ! !StandardFileStream methodsFor: 'finalization' stamp: 'ar 3/21/98 18:16'! actAsExecutor super actAsExecutor. name := nil.! ! !StandardFileStream methodsFor: 'finalization' stamp: 'ar 10/7/1998 15:44'! finalize self primCloseNoError: fileID.! ! !StandardFileStream methodsFor: 'dnd requests' stamp: 'jm 5/3/2003 20:13'! primDropRequestFileHandle: dropIndex "Answer a read-only file handle for the dropped file with the given index. The first dropped file is index 1. Answer nil if there is no dropped file with the given index or the primitive is not supported." <primitive: 'primitiveDropRequestFileHandle' module:' DropPlugin'> ^ nil ! ! !StandardFileStream methodsFor: 'dnd requests' stamp: 'jm 5/3/2003 20:13'! primDropRequestFileName: dropIndex "Answer the file name for the dropped file with the given index. The first dropped file is index 1. Answer nil if there is no dropped file with the given index or the primitive is not supported." <primitive: 'primitiveDropRequestFileName' module: 'DropPlugin'> ^ nil ! ! !StandardFileStream methodsFor: 'dnd requests' stamp: 'jm 5/3/2003 20:40'! requestDropStream: dropIndex "Initialize me to be a read-only stream for a file that the user has just dropped onto the Squeak window. The first dropped file is index 1. Answer nil if there is no dropped file with the given index." name _ self primDropRequestFileName: dropIndex. fileID _ self primDropRequestFileHandle: dropIndex. fileID ifNil: [ name ifNil: [^ nil]. "try to open by name (needed for Squeak 3.0):" self open: name forWrite: false. fileID ifNil: [^ nil]. ^ self]. self register. rwmode _ false. buffer1 _ String new: 1. ! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'TPR 8/13/1999 21:22'! fileNamed: fileName "Open a file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close." ^ self new open: (self fullName: fileName) forWrite: true ! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'mpw 9/18/1999 00:05'! isAFileNamed: fileName "Answer true if a file of the given name exists." | f | f _ self new open: fileName forWrite: false. f ifNil: [^ false]. f close. ^ true ! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'sma 5/12/2000 10:36'! newFileNamed: fileName "Create a new file with the given name, and answer a stream opened for writing on that file. If the file already exists, ask the user what to do." | dir localName choice newName fullName | fullName _ self fullName: fileName. (self isAFileNamed: fullName) ifFalse: [^ self new open: fullName forWrite: true]. "file already exists:" dir _ FileDirectory forFileName: fullName. localName _ FileDirectory localNameFor: fullName. choice _ (PopUpMenu labels: 'overwrite that file choose another name cancel') startUpWithCaption: localName, ' already exists.'. choice = 1 ifTrue: [ dir deleteFileNamed: localName ifAbsent: [self error: 'Could not delete the old version of that file']. ^ self new open: fullName forWrite: true]. choice = 2 ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: 'fullName'. newName isEmpty ifFalse: [ fullName _ self fullName: newName. ^ self newFileNamed: fullName]]. self error: 'Please close this to abort file opening'! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'TPR 8/13/1999 21:26'! oldFileNamed: fileName "Open an existing file with the given name for reading and writing. If the name has no directory part, then the file will be created in the default directory. If the file already exists, its prior contents may be modified or replaced, but the file will not be truncated on close." | selection fullName newName | fullName _ self fullName: fileName. (self isAFileNamed: fullName) ifTrue: [^ self new open: fullName forWrite: true]. "File does not exist..." selection _ (PopUpMenu labels: 'create a new file choose another name cancel') startUpWithCaption: (FileDirectory localNameFor: fullName) , ' does not exist.'. selection = 1 ifTrue: [^ self new open: fullName forWrite: true]. selection = 2 ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fullName. ^ self oldFileNamed: (self fullName: newName)]. self halt! ! !StandardFileStream class methodsFor: 'file creation' stamp: 'ar 12/17/1999 13:56'! readOnlyFileNamed: fileName "Open an existing file with the given name for reading." "Changed to open a more usefull popup menu. It now also includes the most likely choices. jaf" | selection dir files choices newName fullName | fullName _ self fullName: fileName. (self isAFileNamed: fullName) ifTrue: [^ self new open: fullName forWrite: false]. "File does not exist..." dir _ FileDirectory forFileName: fullName. files _ dir fileNames. choices _ (FileDirectory localNameFor: fullName) correctAgainst: files. choices add: 'Choose another name'. choices add: 'Cancel'. selection _ (PopUpMenu labelArray: choices lines: (Array with: 5) ) startUpWithCaption: (FileDirectory localNameFor: fullName), ' does not exist.'. selection < (choices size - 1) ifTrue: [ newName _ (dir pathName , FileDirectory slash , (choices at: selection))]. selection = (choices size - 1) ifTrue: [ newName _ FillInTheBlank request: 'Enter a new file name' initialAnswer: fileName]. newName = '' ifFalse: [^ self readOnlyFileNamed: (self fullName: newName)]. ^ self error: 'Could not open a file'! ! !StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'! register: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry add: anObject! ! !StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 14:41'! registry WeakArray isFinalizationSupported ifFalse:[^nil]. ^Registry isNil ifTrue:[Registry := WeakRegistry new] ifFalse:[Registry].! ! !StandardFileStream class methodsFor: 'registry' stamp: 'ar 10/7/1998 15:23'! unregister: anObject WeakArray isFinalizationSupported ifFalse:[^anObject]. self registry remove: anObject ifAbsent:[]! ! This class implements the source file management behavior of traditional Squeak, with a sources file and a changes file. File positions are mapped such that those files can be up to 32MBytes in size. Structure: files Array -- storing the actual source files ! !StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'hmm 4/25/2000 21:20'! initialize files _ Array new: 2. files at: 1 put: (SourceFiles at: 1). files at: 2 put: (SourceFiles at: 2)! ! !StandardSourceFileArray methodsFor: 'initialize-release' stamp: 'ar 5/17/2000 18:28'! initialize: nFiles files _ Array new: nFiles! ! !StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! at: index ^files at: index! ! !StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! at: index put: aFile files at: index put: aFile! ! !StandardSourceFileArray methodsFor: 'accessing' stamp: 'hmm 4/25/2000 21:20'! size ^files size! ! !StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:44'! fileIndexFromSourcePointer: anInteger "Return the index of the source file which contains the source chunk addressed by anInteger" "This implements the recent 32M source file algorithm" | hi | hi _ anInteger // 16r1000000. ^hi < 3 ifTrue: [hi] ifFalse: [hi - 2]! ! !StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:44'! filePositionFromSourcePointer: anInteger "Return the position of the source chunk addressed by anInteger" "This implements the recent 32M source file algorithm" | hi lo | hi _ anInteger // 16r1000000. lo _ anInteger \\ 16r1000000. ^hi < 3 ifTrue: [lo] ifFalse: [lo + 16r1000000]! ! !StandardSourceFileArray methodsFor: 'sourcePointer conversion' stamp: 'hmm 4/25/2000 21:48'! sourcePointerFromFileIndex: index andPosition: position | hi lo | "Return a source pointer according to the new 32M algorithm" ((index between: 1 and: 2) and: [position between: 0 and: 16r1FFFFFF]) ifFalse: [self error: 'invalid source code pointer']. hi _ index. lo _ position. lo >= 16r1000000 ifTrue: [ hi _ hi+2. lo _ lo - 16r1000000]. ^hi * 16r1000000 + lo! ! !StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'hmm 4/25/2000 21:19'! install "Replace SourceFiles by an instance of me with the standard sources and changes files. This only works if SourceFiles is either an Array or an instance of this class" "StandardSourceFileArray install" SourceFiles _ self new initialize! ! !StandardSourceFileArray class methodsFor: 'initialize-release' stamp: 'ar 5/17/2000 18:27'! new: nFiles ^self new initialize: nFiles.! ! I am a controller for StandardSystemViews, that is, those views that are at the top level of a project in the system user interface. I am a kind of MouseMenuController that creates a blue button menu for moving, framing, collapsing, and closing ScheduledViews, and for selecting views under the view of my instance.! !StandardSystemController methodsFor: 'initialize-release' stamp: 'sma 3/11/2000 11:48'! initialize super initialize. status _ #inactive! ! !StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 12:01'! blueButtonActivity ScheduledBlueButtonMenu ifNil: [^ super controlActivity]. ScheduledBlueButtonMenu invokeOn: self! ! !StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/11/2000 15:20'! controlActivity self checkForReframe. ^ super controlActivity! ! !StandardSystemController methodsFor: 'control defaults' stamp: 'sma 3/15/2000 22:19'! redButtonActivity "If cursor is in label of a window when red button is pushed, check for closeBox or growBox, else drag the window frame or edit the label." | box p | p _ sensor cursorPoint. self labelHasCursor ifFalse: [super redButtonActivity. ^ self]. ((box _ view closeBoxFrame) containsPoint: p) ifTrue: [Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [self close. ^ self]. ^ self]. ((box _ view growBoxFrame) containsPoint: p) ifTrue: [Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [Sensor controlKeyPressed ifTrue: [^ self expand; fullScreen]. ^ view isCollapsed ifTrue: [self expand] ifFalse: [self collapse]]. ^ self]. (((box _ view labelTextRegion expandBy: 1) containsPoint: p) and: [Preferences clickOnLabelToEdit or: [sensor leftShiftDown]]) ifTrue: [Utilities awaitMouseUpIn: box repeating: [] ifSucceed: [^ self label]. ^ self]. self move! ! !StandardSystemController methodsFor: 'basic control sequence' stamp: 'sw 10/20/1999 09:52'! controlInitialize view displayEmphasized. view uncacheBits. "Release cached bitmap while active" model windowActiveOnFirstClick ifFalse: [sensor waitNoButton]. status _ #active. view isCollapsed ifFalse: [model modelWakeUpIn: view]! ! !StandardSystemController methodsFor: 'basic control sequence' stamp: 'di 5/11/1999 22:05'! controlTerminate status == #closed ifTrue: [view ~~ nil ifTrue: [view release]. ScheduledControllers unschedule: self. ^self]. view deEmphasize; cacheBits. view isCollapsed ifFalse: [model modelSleep].! ! !StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:45'! adjustPaneBorders | side sub newRect outerFrame | outerFrame _ view displayBox. side _ #none. VBorderCursor showWhile: [ [sub _ view subviewWithLongestSide: [:s | side _ s] near: sensor cursorPoint. self cursorOnBorder and: [(side = #left) | (side = #right)]] whileTrue: [ self interActivityPause. sensor redButtonPressed ifTrue: [side = #left ifTrue: [newRect _ sub stretchFrame: [:f | (f withLeft: sensor cursorPoint x) intersect: outerFrame] startingWith: sub displayBox]. side = #right ifTrue: [newRect _ sub stretchFrame: [:f | (f withRight: sensor cursorPoint x) intersect: outerFrame] startingWith: sub displayBox]. view reframePanesAdjoining: sub along: side to: newRect]]]. HBorderCursor showWhile: [ [sub _ view subviewWithLongestSide: [:s | side _ s] near: sensor cursorPoint. self cursorOnBorder and: [(side = #top) | (side = #bottom)]] whileTrue: [ self interActivityPause. sensor redButtonPressed ifTrue: [side = #top ifTrue: [newRect _ sub stretchFrame: [:f | (f withTop: sensor cursorPoint y) intersect: outerFrame] startingWith: sub displayBox]. side = #bottom ifTrue: [newRect _ sub stretchFrame: [:f | (f withBottom: sensor cursorPoint y) intersect: outerFrame] startingWith: sub displayBox]. view reframePanesAdjoining: sub along: side to: newRect]]]! ! !StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:42'! adjustWindowBorders | side | VBorderCursor showWhile: [ [side _ view displayBox sideNearestTo: sensor cursorPoint. self cursorOnBorder and: [(side = #left) | (side = #right)]] whileTrue: [(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue: [side = #left ifTrue: [view newFrame: [:f | f withLeft: sensor cursorPoint x]]. side = #right ifTrue: [view newFrame: [:f | f withRight: sensor cursorPoint x]]]. self interActivityPause]. ]. HBorderCursor showWhile: [ [side _ view displayBox sideNearestTo: sensor cursorPoint. self cursorOnBorder and: [(side = #top) | (side = #bottom)]] whileTrue: [(sensor redButtonPressed and: [self cursorOnBorder]) ifTrue: [side = #top ifTrue: [view newFrame: [:f | f withTop: sensor cursorPoint y]]. side = #bottom ifTrue: [view newFrame: [:f | f withBottom: sensor cursorPoint y]]]. self interActivityPause]]! ! !StandardSystemController methodsFor: 'borders' stamp: 'ls 7/11/1998 07:38'! adjustWindowCorners | box cornerBox p clicked f2 | box _ view windowBox. clicked _ false. #(topLeft topRight bottomRight bottomLeft) do: [:readCorner | cornerBox _ ((box insetBy: 2) perform: readCorner) - (10@10) extent: 20@20. (cornerBox containsPoint: sensor cursorPoint) ifTrue: ["Display reverse: cornerBox." (Cursor perform: readCorner) showWhile: [[(cornerBox containsPoint: (p _ sensor cursorPoint)) and: [(clicked _ sensor anyButtonPressed) not]] whileTrue: [ self interActivityPause ]. "Display reverse: cornerBox." clicked ifTrue: [view newFrame: [:f | p _ sensor cursorPoint. readCorner = #topLeft ifTrue: [f2 _ p corner: f bottomRight]. readCorner = #bottomLeft ifTrue: [f2 _ (f withBottom: p y) withLeft: p x]. readCorner = #bottomRight ifTrue: [f2 _ f topLeft corner: p]. readCorner = #topRight ifTrue: [f2 _ (f withTop: p y) withRight: p x]. f2]]]]]. ^ clicked! ! !StandardSystemController methodsFor: 'pluggable menus' stamp: 'sma 3/11/2000 15:12'! getPluggableYellowButtonMenu: shiftKeyState ^ nil! ! !StandardSystemController class methodsFor: 'class initialization' stamp: 'sma 3/11/2000 11:57'! initialize "StandardSystemController initialize" ScheduledBlueButtonMenu _ SelectionMenu labels: 'edit label choose color... two-tone/full color move frame full screen collapse close' lines: #(3 7) selections: #(label chooseColor toggleTwoTone move reframe fullScreen collapse close). VBorderCursor _ Cursor extent: 16@16 fromArray: #( 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010010000100000 2r1010110000110000 2r1011111111111000 2r1010110000110000 2r1010010000100000 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010000000000000 2r1010000000000000) offset: 0@0. HBorderCursor _ Cursor extent: 16@16 fromArray: #( 2r1111111111111111 2r0000000000000000 2r1111111111111111 2r0000000100000000 2r0000001110000000 2r0000011111000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000000100000000 2r0000011111000000 2r0000001110000000 2r0000000100000000 2r0000000000000000 2r0000000000000000 2r0000000000000000) offset: 0@0.! ! !StandardSystemController class methodsFor: 'cursor constants' stamp: 'jm 6/17/2003 11:31'! hBorderCursor ^ HBorderCursor ! ! !StandardSystemController class methodsFor: 'cursor constants' stamp: 'jm 6/17/2003 11:31'! vBorderCursor ^ VBorderCursor ! ! I represent a view that has a label above its top left corner. The text in the label identifies the kind of view. In addition to a label, I add control over the maximum and minimum size of the display box of my instance. My default controller is StandardSystemController. The elements of ScheduledControllers, the sole instance of ControlManager, are usually controllers for instances of me.! !StandardSystemView methodsFor: 'initialize-release' stamp: 'sw 10/29/1999 12:58'! initialize "Refer to the comment in View|initialize." super initialize. labelFrame _ Quadrangle new. labelFrame region: (Rectangle origin: 0 @ 0 extent: 50 @ self labelHeight). labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2. self label: nil. isLabelComplemented _ false. minimumSize _ 50 @ 50. maximumSize _ Display extent. collapsedViewport _ nil. expandedViewport _ nil. bitsValid _ false. updatablePanes _ #()! ! !StandardSystemView methodsFor: 'initialize-release' stamp: 'jm 8/20/1998 18:29'! release model windowIsClosing. self isCollapsed ifTrue: [savedSubViews do: [:v | v release]]. super release. ! ! !StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:44'! label: aString "Set aString to be the receiver's label." labelText _ Paragraph withText: (Text string: ((aString == nil or: [aString isEmpty]) ifTrue: ['Untitled' copy] ifFalse: [aString]) attributes: (Array with: TextEmphasis bold)) style: LabelStyle. insetDisplayBox == nil ifTrue: [^ self]. "wait for further initialization" self setLabelRegion! ! !StandardSystemView methodsFor: 'label access' stamp: 'sw 12/9/1999 17:47'! labelHeight ^ ((LabelStyle fontAt: 1) height + 4) max: 20! ! !StandardSystemView methodsFor: 'label access' stamp: 'sr 3/26/2000 04:26'! labelText ^labelText! ! !StandardSystemView methodsFor: 'label access' stamp: 'di 6/10/1998 13:18'! relabel: aString "A new string for the label. Window is assumed to be active. Window will redisplay only if label bar has to grow." | oldRegion oldWidth | (model windowReqNewLabel: aString) ifFalse: [^ self]. oldRegion _ self labelTextRegion. oldWidth _ self insetDisplayBox width. self label: aString. Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0) fillColor: self labelColor. self insetDisplayBox width = oldWidth ifTrue: [self displayLabelText; emphasizeLabel] ifFalse: [self uncacheBits; displayEmphasized]. ! ! !StandardSystemView methodsFor: 'label access' stamp: 'sw 1/11/2000 15:27'! setLabelTo: aString "Force aString to be the new label of the receiver, bypassing any logic about whether it is acceptable and about propagating information about the change." | oldRegion oldWidth | oldRegion _ self labelTextRegion. oldWidth _ self insetDisplayBox width. self label: aString. Display fill: ((oldRegion merge: self labelTextRegion) expandBy: 3@0) fillColor: self labelColor. self insetDisplayBox width = oldWidth ifTrue: [self displayLabelText; emphasizeLabel] ifFalse: [self uncacheBits; displayEmphasized]. ! ! !StandardSystemView methodsFor: 'framing' stamp: 'sr 3/26/2000 03:47'! chooseCollapsePoint "Answer the point at which to place the collapsed window." | pt labelForm beenDown offset | labelForm _ Form fromDisplay: self labelDisplayBox. self uncacheBits. self erase. beenDown _ Sensor anyButtonPressed. self isCollapsed ifTrue: [offset _ self labelDisplayBox topLeft - self growBoxFrame topLeft. labelForm follow: [pt _ (Sensor cursorPoint + offset max: 0@0) truncateTo: 8] while: [Sensor anyButtonPressed ifTrue: [beenDown _ true] ifFalse: [beenDown not]]. ^ pt]. ^ (RealEstateAgent assignCollapseFrameFor: self) origin. ! ! !StandardSystemView methodsFor: 'framing' stamp: 'di 5/11/1999 22:09'! collapse "If the receiver is not already collapsed, change its view to be that of its label only." self isCollapsed ifFalse: [model modelSleep. (subViews ~~ nil and: [subViews size = 1 and: [subViews first isKindOf: MorphWorldView]]) ifTrue: [subViews first deEmphasizeView]. expandedViewport _ self viewport. savedSubViews _ subViews. self resetSubViews. labelText isNil ifTrue: [self label: nil. bitsValid _ false.]. self window: (self inverseDisplayTransform: ((self labelDisplayBox topLeft extent: (labelText extent x + 70) @ self labelHeight) intersect: self labelDisplayBox))]! ! !StandardSystemView methodsFor: 'framing' stamp: 'sw 10/20/1999 09:46'! expand "If the receiver is collapsed, change its view to be that of all of its subviews, not its label alone." | newFrame | self isCollapsed ifTrue: [newFrame _ self chooseFrame expandBy: borderWidth. collapsedViewport _ self viewport. subViews _ savedSubViews. labelFrame borderWidthLeft: 2 right: 2 top: 2 bottom: 2. savedSubViews _ nil. self setWindow: nil. self resizeTo: newFrame. self displayDeEmphasized. model modelWakeUpIn: self]! ! !StandardSystemView methodsFor: 'framing' stamp: 'di 10/22/1998 16:15'! reframePanesAdjoining: subView along: side to: aDisplayBox | newBox delta newRect minDim theMin | newRect _ aDisplayBox. theMin _ 16. "First check that this won't make any pane smaller than theMin screen dots" minDim _ ((subViews select: [:sub | sub displayBox bordersOn: subView displayBox along: side]) collect: [:sub | sub displayBox adjustTo: newRect along: side]) inject: 999 into: [:was :rect | (was min: rect width) min: rect height]. "If so, amend newRect as required" minDim < theMin ifTrue: [delta _ minDim - theMin. newRect _ newRect withSide: side setTo: ((newRect perform: side) > (subView displayBox perform: side) ifTrue: [(newRect perform: side) + delta] ifFalse: [(newRect perform: side) - delta])]. "Now adjust all adjoining panes for real" subViews do: [:sub | (sub displayBox bordersOn: subView displayBox along: side) ifTrue: [newBox _ sub displayBox adjustTo: newRect along: side. sub window: sub window viewport: (sub transform: (sub inverseDisplayTransform: newBox)) rounded]]. "And adjust the growing pane itself" subView window: subView window viewport: (subView transform: (subView inverseDisplayTransform: newRect)) rounded. "Finally force a recomposition of the whole window" viewport _ nil. self resizeTo: self viewport. self uncacheBits; displayEmphasized! ! !StandardSystemView methodsFor: 'displaying' stamp: 'hmm 7/21/1999 07:37'! displayDeEmphasized "Display this view with emphasis off. If windowBits is not nil, then simply BLT if possible, but force full display for top window so color is preserved." (bitsValid and: [controller ~~ ScheduledControllers activeController]) ifTrue: [self lock. windowBits displayAt: self windowOrigin] ifFalse: [Display deferUpdates: true. super display. Display deferUpdates: false; forceToScreen: self windowBox. CacheBits ifTrue: [self cacheBitsAsIs]] ! ! !StandardSystemView methodsFor: 'displaying' stamp: 'di 9/10/1998 09:43'! displayLabelText "The label goes in the center of the window" | labelRect | labelText foregroundColor: self foregroundColor backgroundColor: self labelColor. labelRect _ self labelTextRegion. Display fill: (labelRect expandBy: 3@0) fillColor: self labelColor. labelText displayOn: Display at: labelRect topLeft clippingBox: labelRect rule: labelText rule fillColor: labelText fillColor. labelText destinationForm: nil! ! !StandardSystemView methodsFor: 'displaying' stamp: 'jm 5/12/2003 19:56'! displayOn: aBitBlt bitsValid ifFalse: [ ^ Display clippingTo: aBitBlt clipRect do: [super display]]. aBitBlt copyForm: windowBits to: self windowOrigin rule: Form over. ! ! !StandardSystemView methodsFor: 'displaying' stamp: 'di 8/10/1999 08:38'! makeMeVisible | newLoc portRect | ((Display boundingBox insetBy: (0@0 corner: self labelHeight asPoint)) containsPoint: self displayBox topLeft) ifTrue: [^ self "OK -- my top left is visible"]. "window not on screen (probably due to reframe) -- move it now" newLoc _ self isCollapsed ifTrue: [RealEstateAgent assignCollapsePointFor: self] ifFalse: [(RealEstateAgent initialFrameFor: self) topLeft]. portRect _ newLoc + self labelOffset extent: self windowBox extent - self labelOffset. self resizeTo: portRect. self setLabelRegion. ! ! !StandardSystemView methodsFor: 'private' stamp: 'di 10/21/1998 16:12'! subviewWithLongestSide: sideBlock near: aPoint | theSub theSide theLen box | theLen _ 0. subViews do: [:sub | box _ sub insetDisplayBox. box forPoint: aPoint closestSideDistLen: [:side :dist :len | (dist <= 5 and: [len > theLen]) ifTrue: [theSub _ sub. theSide _ side. theLen _ len]]]. sideBlock value: theSide. ^ theSub! ! !StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 12:57'! setUpdatablePanesFrom: getSelectors | aList aPane | "Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors. Order is important here!! Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case" aList _ OrderedCollection new. getSelectors do: [:sel | aPane _ self subViewSatisfying: [:pane | (pane isKindOf: PluggableListView) and: [pane getListSelector == sel]]. aPane ifNotNil: [aList add: aPane] ifNil: [Transcript cr; show: 'Warning: view ', sel, ' not found.']]. updatablePanes _ aList asArray! ! !StandardSystemView methodsFor: 'updating' stamp: 'sw 10/29/1999 21:20'! updatablePanes "Answer the list of panes, in order, which might be sent the #verifyContents message upon window activation or expansion." ^ updatablePanes ifNil: [updatablePanes _ #()]! ! !StandardSystemView methodsFor: 'updating' stamp: 'sw 1/11/2000 15:30'! update: aSymbol aSymbol = #relabel ifTrue: [^ self setLabelTo: model labelString]. ^ super update: aSymbol! ! !StandardSystemView class methodsFor: 'class initialization' stamp: 'sw 12/6/1999 23:42'! initialize "StandardSystemView initialize" self doCacheBits. self setLabelStyle! ! !StandardSystemView class methodsFor: 'class initialization' stamp: 'sw 12/9/1999 17:43'! setLabelStyle | aFont | "StandardSystemView setLabelStyle" aFont _ Preferences windowTitleFont. LabelStyle _ aFont textStyle copy consistOnlyOf: aFont. LabelStyle gridForFont: 1 withLead: 0! ! I am an abstract class that represents an accessor for a sequence of objects. This sequence is referred to as my "contents".! !Stream methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:07'! flush "Do nothing by default"! ! !Stream methodsFor: 'accessing' stamp: 'ls 9/12/1998 20:55'! upToEnd "answer the remaining elements in the string" | elements | elements _ OrderedCollection new. [ self atEnd ] whileFalse: [ elements add: self next ]. ^elements! ! !Stream methodsFor: 'printing' stamp: 'sma 6/1/2000 09:56'! print: anObject "Have anObject print itself on the receiver." anObject printOn: self! ! I implement a streaming player for monophonic Sun (.au) and AIFF (.aif) audio files. Example of use: (StreamingMonoSound onFileNamed: 'song.aif') play. ! !StreamingMonoSound methodsFor: 'initialization' stamp: 'jm 9/29/2003 16:58'! initStream: aStream headerStart: anInteger "Initialize for streaming from the given stream. The audio file header starts at the given stream position." stream _ aStream. volume _ 1.0. leftRight _ 0.5. repeat _ false. headerStart _ anInteger. self reset. ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:12'! duration "Answer the duration of this sound in seconds." ^ totalSamples asFloat / streamSamplingRate ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 12/28/2002 09:44'! fileName ^ stream fullName ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 10/18/2001 15:46'! repeat "Answer the repeat flag." ^ repeat ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 6/3/2001 18:39'! repeat: aBoolean "Set the repeat flag. If true, this sound will loop back to the beginning when it gets to the end." repeat _ aBoolean. ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 9/29/2003 16:59'! setPan: newPan volume: newVol for: channel "Set the left-right balance and volume for the given channel." leftRight _ newPan. volume _ newVol. mixer ifNotNil: [ mixer setPan: newPan volume: newVol for: channel]. ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/16/2001 17:05'! soundPosition "Answer the relative position of sound playback as a number between 0.0 and 1.0." (stream isNil or: [stream closed]) ifTrue: [^ 0.0]. ^ self currentSampleIndex asFloat / totalSamples ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 12/14/2001 11:29'! soundPosition: fraction "Jump to the position the given fraction through the sound file. The argument is a number between 0.0 and 1.0." | desiredSampleIndex | (stream isNil or: [stream closed]) ifTrue: [^ self]. desiredSampleIndex _ ((totalSamples * fraction) truncated max: 0) min: totalSamples. codec ifNil: [stream position: audioDataStart + (desiredSampleIndex * 2)] ifNotNil: [self positionCodecTo: desiredSampleIndex]. leftoverSamples _ SoundBuffer new. ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 11/20/2001 16:59'! streamSamplingRate "Answer the sampling rate of the MP3 stream." ^ streamSamplingRate ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 9/26/2000 07:49'! volume "Answer my volume." ^ volume ! ! !StreamingMonoSound methodsFor: 'accessing' stamp: 'jm 5/30/2001 16:53'! volume: aNumber "Set my volume to the given number between 0.0 and 1.0." volume _ aNumber. self createMixer. ! ! !StreamingMonoSound methodsFor: 'playing' stamp: 'jm 11/27/2001 09:19'! millisecondsSinceStart "Answer the number of milliseconds of this sound started playing." | mSecs | (stream isNil or: [stream closed]) ifTrue: [^ 0]. mSecs _ self currentSampleIndex * 1000 // streamSamplingRate. (self isPlaying and: [lastBufferMSecs > 0]) ifTrue: [ "adjust mSecs by the milliseconds since the last buffer" mutex critical: [ mSecs _ self currentSampleIndex * 1000 // streamSamplingRate. mSecs _ mSecs + ((Time millisecondClockValue - lastBufferMSecs) max: 0)]]. ^ mSecs + 350 - (2 * SoundPlayer bufferMSecs) ! ! !StreamingMonoSound methodsFor: 'playing' stamp: 'jm 11/27/2001 07:58'! playSampleCount: n into: aSoundBuffer startingAt: startIndex "Mix the next n samples of this sound into the given buffer starting at the given index" self repeat ifTrue: [ "loop if necessary" (totalSamples - self currentSampleIndex) < n ifTrue: [self startOver]]. mutex critical: [ lastBufferMSecs _ Time millisecondClockValue. self loadBuffersForSampleCount: (n * streamSamplingRate) // SoundPlayer samplingRate. mixer playSampleCount: n into: aSoundBuffer startingAt: startIndex]. ! ! !StreamingMonoSound methodsFor: 'playing' stamp: 'jm 10/21/2001 09:45'! reset super reset. self startOver. self createMixer. ! ! !StreamingMonoSound methodsFor: 'playing' stamp: 'jm 11/8/2001 09:09'! samplesRemaining "Answer the number of samples remaining to be played." | result | (stream isNil or: [stream closed]) ifTrue: [^ 0]. self repeat ifTrue: [^ 1000000]. result _ (totalSamples - self currentSampleIndex) max: 0. result <= 0 ifTrue: [self closeFile]. ^ result ! ! !StreamingMonoSound methodsFor: 'other' stamp: 'jm 12/14/2001 11:01'! closeFile "Close my stream, if it responds to close." stream ifNotNil: [ (stream respondsTo: #close) ifTrue: [stream close]]. mixer _ nil. codec _ nil. ! ! !StreamingMonoSound methodsFor: 'other' stamp: 'jm 11/21/2001 08:05'! extractFrom: startSecs to: endSecs "Extract a portion of this sound between the given start and end times. The current implementation only works if the sound is uncompressed." | emptySound first last sampleCount byteStream sndBuf | codec ifNotNil: [^ self error: 'only works on uncompressed sounds']. emptySound _ SampledSound samples: SoundBuffer new samplingRate: streamSamplingRate. first _ (startSecs * streamSamplingRate) truncated max: 0. last _ ((endSecs * streamSamplingRate) truncated min: totalSamples) - 1. first >= last ifTrue: [^ emptySound]. codec ifNotNil: [self error: 'extracting from compressed sounds is not supported']. sampleCount _ last + 1 - first. stream position: audioDataStart + (2 * first). byteStream _ ReadStream on: (stream next: 2 * sampleCount). sndBuf _ SoundBuffer newMonoSampleCount: sampleCount. 1 to: sampleCount do: [:i | sndBuf at: i put: byteStream int16]. ^ SampledSound samples: sndBuf samplingRate: streamSamplingRate ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 10/18/2001 15:51'! createMixer "Create a mixed sound consisting of sampled sounds with one sound buffer's worth of samples." | snd | mixer _ MixedSound new. snd _ SampledSound samples: (SoundBuffer newMonoSampleCount: 2) "buffer size will be adjusted dynamically" samplingRate: streamSamplingRate. mixer add: snd pan: 0.5 volume: volume. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 09:05'! currentSampleIndex "Answer the index of the current sample." | bytePosition frameIndex | bytePosition _ stream position - audioDataStart. codec ifNil: [^ bytePosition // 2] ifNotNil: [ frameIndex _ bytePosition // codec bytesPerEncodedFrame. ^ (frameIndex * codec samplesPerFrame) - leftoverSamples monoSampleCount]. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 11:37'! loadBuffer: aSoundBuffer compressedSampleCount: sampleCount "Load the given sound buffer from the compressed sample stream." "Details: Most codecs decode in multi-sample units called 'frames'. Since the requested sampleCount is typically not an even multiple of the frame size, we need to deal with partial frames. The unused samples from a partial frame are retained until the next call to this method." | n samplesNeeded frameCount encodedBytes r decodedCount buf j | "first, use any leftover samples" n _ self loadFromLeftovers: aSoundBuffer sampleCount: sampleCount. samplesNeeded _ sampleCount - n. samplesNeeded <= 0 ifTrue: [^ self]. "decode an integral number of full compression frames" frameCount _ samplesNeeded // codec samplesPerFrame. encodedBytes _ stream next: (frameCount * codec bytesPerEncodedFrame). r _ codec decodeFrames: frameCount from: encodedBytes at: 1 into: aSoundBuffer at: n + 1. decodedCount _ r last. decodedCount >= samplesNeeded ifTrue: [^ self]. "decode one last compression frame to finish filling the buffer" buf _ SoundBuffer newMonoSampleCount: codec samplesPerFrame. encodedBytes _ stream next: codec bytesPerEncodedFrame. codec decodeFrames: 1 from: encodedBytes at: 1 into: buf at: 1. j _ 0. (n + decodedCount + 1) to: sampleCount do: [:i | aSoundBuffer at: i put: (buf at: (j _ j + 1))]. "save the leftover samples" leftoverSamples _ buf copyFrom: (j + 1) to: buf monoSampleCount. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 08:03'! loadBuffer: aSoundBuffer uncompressedSampleCount: sampleCount "Load the given sound buffer from the uncompressed sample stream." "read directly into the sample buffer; count is in 32-bit words" stream next: sampleCount // 2 into: aSoundBuffer startingAt: 1. aSoundBuffer restoreEndianness. "read the final sample if sampleCount is odd:" sampleCount odd ifTrue: [aSoundBuffer at: sampleCount put: stream int16]. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 12/22/2002 09:55'! loadBuffersForSampleCount: count "Load the sound buffers from the stream. Answer the buffer." | snd buf sampleCount | snd _ mixer sounds first. buf _ snd samples. buf monoSampleCount = count ifFalse: [ buf _ SoundBuffer newMonoSampleCount: count. snd setSamples: buf samplingRate: streamSamplingRate]. sampleCount _ count min: (totalSamples - self currentSampleIndex). sampleCount < count ifTrue: [buf primFill: 0]. codec ifNil: [self loadBuffer: buf uncompressedSampleCount: sampleCount] ifNotNil: [self loadBuffer: buf compressedSampleCount: sampleCount]. mixer reset. ^ buf ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 09:09'! loadFromLeftovers: aSoundBuffer sampleCount: sampleCount "Load the given sound buffer from the samples leftover from the last frame. Answer the number of samples loaded, which typically is less than sampleCount." | leftoverCount n | leftoverCount _ leftoverSamples monoSampleCount. leftoverCount = 0 ifTrue: [^ 0]. n _ leftoverCount min: sampleCount. 1 to: n do: [:i | aSoundBuffer at: i put: (leftoverSamples at: i)]. n < sampleCount ifTrue: [leftoverSamples _ SoundBuffer new] ifFalse: [leftoverSamples _ leftoverSamples copyFrom: n + 1 to: leftoverSamples size]. ^ n ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 12/14/2001 14:57'! positionCodecTo: desiredSampleIndex "Position to the closest frame before the given sample index when using a codec. If using the ADPCM codec, try to ensure that it is in sync with the compressed sample stream." | desiredFrameIndex desiredPosition tmpStream tmpCodec byteBuf bufFrames sampleBuf frameCount n startOffset | (codec isKindOf: ADPCMCodec) ifFalse: [ "stateless codecs (or relatively stateless ones, like GSM: just jump to frame boundary" desiredFrameIndex _ desiredSampleIndex // codec samplesPerFrame. stream position: audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame). codec reset. ^ self]. "compute the desired stream position" desiredFrameIndex _ desiredSampleIndex // codec samplesPerFrame. desiredPosition _ audioDataStart + (desiredFrameIndex * codec bytesPerEncodedFrame). "copy stream and codec" (stream isKindOf: FileStream) ifTrue: [tmpStream _ (FileStream readOnlyFileNamed: stream name) binary] ifFalse: [tmpStream _ stream deepCopy]. tmpCodec _ codec copy reset. "reset the codec and start back about 30 seconds to try to get codec in sync" startOffset _ ((desiredFrameIndex - 80000) max: 0) * codec bytesPerEncodedFrame. tmpStream position: audioDataStart + startOffset. "decode forward to the desired position" byteBuf _ ByteArray new: (32000 roundTo: codec bytesPerEncodedFrame). bufFrames _ byteBuf size // codec bytesPerEncodedFrame. sampleBuf _ SoundBuffer newMonoSampleCount: bufFrames * codec samplesPerFrame. frameCount _ (desiredPosition - tmpStream position) // codec bytesPerEncodedFrame. [frameCount > 0] whileTrue: [ n _ bufFrames min: frameCount. tmpStream next: n * codec bytesPerEncodedFrame into: byteBuf startingAt: 1. tmpCodec decodeFrames: n from: byteBuf at: 1 into: sampleBuf at: 1. frameCount _ frameCount - n]. codec _ tmpCodec. stream position: tmpStream position. (tmpStream isKindOf: FileStream) ifTrue: [tmpStream close].! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/16/2001 10:23'! readAIFFHeader "Read an AIFF file header from stream." | aiffReader | aiffReader _ AIFFFileReader new. aiffReader readFromStream: stream mergeIfStereo: false skipDataChunk: true. aiffReader channelCount = 1 ifFalse: [self error: 'not monophonic']. aiffReader bitsPerSample = 16 ifFalse: [self error: 'not 16-bit']. audioDataStart _ headerStart + aiffReader channelDataOffset. streamSamplingRate _ aiffReader samplingRate. totalSamples _ aiffReader frameCount min: (stream size - audioDataStart) // 2. codec _ nil. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/16/2001 10:32'! readHeader "Read the sound file header from my stream." | id | stream position: headerStart. id _ (stream next: 4) asString. stream position: headerStart. id = '.snd' ifTrue: [^ self readSunAudioHeader]. id = 'FORM' ifTrue: [^ self readAIFFHeader]. self error: 'unrecognized sound file format'. ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/21/2001 13:02'! readSunAudioHeader "Read a Sun audio file header from my stream." | id headerBytes dataBytes format channelCount | id _ (stream next: 4) asString. headerBytes _ stream uint32. "header bytes" dataBytes _ stream uint32. format _ stream uint32. streamSamplingRate _ stream uint32. channelCount _ stream uint32. id = '.snd' ifFalse: [self error: 'not Sun audio format']. dataBytes _ dataBytes min: (stream size - headerBytes). channelCount = 1 ifFalse: [self error: 'not monophonic']. audioDataStart _ headerStart + headerBytes. codec _ nil. format = 1 ifTrue: [ "8-bit u-LAW" codec _ MuLawCodec new. totalSamples _ dataBytes. ^ self]. format = 3 ifTrue: [ "16-bit linear" totalSamples _ dataBytes // 2. ^ self]. format = 23 ifTrue: [ "ADPCM-4 bit (CCITT G.721)" codec _ ADPCMCodec new initializeForBitsPerSample: 4 samplesPerFrame: 0. totalSamples _ (dataBytes // 4) * 8. ^ self]. format = 25 ifTrue: [ "ADPCM-3 bit (CCITT G.723)" codec _ ADPCMCodec new initializeForBitsPerSample: 3 samplesPerFrame: 0. totalSamples _ (dataBytes // 3) * 8. ^ self]. format = 26 ifTrue: [ "ADPCM-5 bit (CCITT G.723)" codec _ ADPCMCodec new initializeForBitsPerSample: 5 samplesPerFrame: 0. totalSamples _ (dataBytes // 5) * 8. ^ self]. format = 610 ifTrue: [ "GSM 06.10 (this format was added by Squeak)" codec _ GSMCodec new. totalSamples _ (dataBytes // 33) * 160. ^ self]. self error: 'unsupported Sun audio format ', format printString ! ! !StreamingMonoSound methodsFor: 'private' stamp: 'jm 11/27/2001 07:36'! startOver "Jump back to the first sample." stream reopen; binary. self readHeader. stream position: audioDataStart. leftoverSamples _ SoundBuffer new. lastBufferMSecs _ 0. mutex _ Semaphore forMutualExclusion. ! ! !StreamingMonoSound methodsFor: 'converting' stamp: 'jm 12/13/2001 20:08'! saveAsFileNamed: newFileName compressionType: compressionTypeString "Store this sound in a new file with the given name using the given compression type. Useful for converting between compression formats." | outFile | outFile _ (FileStream newFileNamed: newFileName) binary. self storeSunAudioOn: outFile compressionType: compressionTypeString. outFile close. ! ! !StreamingMonoSound methodsFor: 'converting' stamp: 'jm 12/14/2001 10:10'! storeSunAudioOn: aBinaryStream compressionType: compressionName "Store myself on the given stream as a monophonic sound compressed with the given type of compression. The sampling rate is reduced to 22050 samples/second if it is higher." | fmt inBufSize samplesPerFrame outCodec compressed outSamplingRate audioWriter samplesRemaining inBuf outBuf counts byteCount | self pause; reset. "stop playing and return to beginning" fmt _ SunAudioFileWriter formatCodeForCompressionType: compressionName. inBufSize _ 64000. samplesPerFrame _ 1. outCodec _ SunAudioFileWriter codecForFormatCode: fmt. outCodec ifNotNil: [ samplesPerFrame _ outCodec samplesPerFrame. inBufSize _ inBufSize roundUpTo: (2 * samplesPerFrame). compressed _ ByteArray new: (inBufSize // samplesPerFrame) * outCodec bytesPerEncodedFrame]. outSamplingRate _ streamSamplingRate. streamSamplingRate > 22050 ifTrue: [ streamSamplingRate = 44100 ifFalse: [self error: 'unexpected MP3 sampling rate']. outSamplingRate _ 22050]. "write audio header" audioWriter _ SunAudioFileWriter onStream: aBinaryStream. audioWriter writeHeaderSamplingRate: outSamplingRate format: fmt. "convert and write sound data" 'Storing audio...' displayProgressAt: Sensor cursorPoint from: 0 to: totalSamples during: [:bar | samplesRemaining _ totalSamples. [samplesRemaining > 0] whileTrue: [ bar value: totalSamples - samplesRemaining. self loadBuffersForSampleCount: (inBufSize min: samplesRemaining). inBuf _ mixer sounds first samples. outSamplingRate < streamSamplingRate ifTrue: [outBuf _ inBuf downSampledLowPassFiltering: true] ifFalse: [outBuf _ inBuf]. outCodec ifNil: [audioWriter appendSamples: outBuf] ifNotNil: [ counts _ outCodec encodeFrames: (outBuf size // samplesPerFrame) from: outBuf at: 1 into: compressed at: 1. byteCount _ counts last. byteCount = compressed size ifTrue: [audioWriter appendBytes: compressed] ifFalse: [audioWriter appendBytes: (compressed copyFrom: 1 to: byteCount)]]. samplesRemaining _ samplesRemaining - inBuf monoSampleCount]]. "update audio header" audioWriter updateHeaderDataSize. ! ! !StreamingMonoSound class methodsFor: 'instance creation' stamp: 'jm 11/16/2001 16:57'! onFileNamed: fileName "Answer an instance of me for playing the file with the given name." | f | f _ FileDirectory default readOnlyFileNamed: fileName. f ifNil: [^ self error: 'could not open ', fileName]. ^ self new initStream: f headerStart: 0 ! ! !StreamingMonoSound class methodsFor: 'instance creation' stamp: 'jm 11/16/2001 10:25'! onFileNamed: fileName headerStart: anInteger "Answer an instance of me for playing audio data starting at the given position in the file with the given name." | f | f _ FileDirectory default readOnlyFileNamed: fileName. f ifNil: [^ self error: 'could not open ', fileName]. ^ self new initStream: f headerStart: anInteger ! ! I represent a compact encoding of a set of Forms corresponding to characters in the ASCII character set. All the forms are placed side by side in a large form whose height is the font height, and whose width is the sum of all the character widths. The xTable variable gives the left-x coordinates of the subforms corresponding to the glyphs. Characters are mapped to glyphs by using the characterToGyphMap. Subclasses can have non-trivial mapping rules as well as different representations for glyphs sizes (e.g., not using an xTable). If so, these classes should return nil when queried for xTable and/or the characterToGlyphMap. This will cause the CharacterScanner primitive to fail and query the font for the width of a character (so that a more programatical approach can be implemented). For display, fonts need to implement two messages: #installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor This method installs the receiver (a font) on the given DisplayContext (which may be an instance of BitBlt or Canvas (or any of it's subclasses). The font should take the appropriate action to initialize the display context so that further display operations can be optimized. #displayString: aString on: aDisplayContext from: startIndex to: stopIndex at: aPoint kern: kernDelta This method is called for each subsequent run of characters in aString which is to be displayed with the (previously installed) settings. ! !StrikeFont methodsFor: 'accessing' stamp: 'jm 5/12/2003 16:36'! characterToGlyphMap "Return the character to glyph mapping table. If the table is not provided the character scanner will query the font directly for the width of each individual character." ^ characterToGlyphMap ifNil: [ characterToGlyphMap _ self createCharacterToGlyphMap]. ! ! !StrikeFont methodsFor: 'accessing' stamp: 'jm 5/12/2003 17:39'! characterToGlyphMap: anArray characterToGlyphMap _ anArray. ! ! !StrikeFont methodsFor: 'accessing' stamp: 'jm 5/12/2003 17:57'! familyName ^ self name withoutTrailingDigits ! ! !StrikeFont methodsFor: 'accessing' stamp: 'sw 1/18/2000 20:54'! pointSize ^ pointSize! ! !StrikeFont methodsFor: 'accessing' stamp: 'jm 6/9/2003 22:19'! textStyle "Answer the first TextStyle that contains me." | aDict | aDict _ TextConstants select: [:thang | thang isKindOf: TextStyle]. aDict removeKey: #DefaultTextStyle. ^ aDict detect: [:aStyle | aStyle fontArray includes: self] ifNone: [nil] ! ! !StrikeFont methodsFor: 'accessing' stamp: 'di 3/27/2000 14:49'! widthOf: aCharacter "Answer the width of the argument as a character in the receiver." | ascii | ascii _ aCharacter asciiValue. (ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1]. ^ (xTable at: ascii + 2) - (xTable at: ascii + 1) ! ! !StrikeFont methodsFor: 'displaying' stamp: 'ar 5/19/2000 15:09'! displayString: aString on: aBitBlt from: startIndex to: stopIndex at: aPoint kern: kernDelta "Draw the given string from startIndex to stopIndex at aPoint on the (already prepared) BitBlt." aBitBlt displayString: aString from: startIndex to: stopIndex at: aPoint strikeFont: self kern: kernDelta.! ! !StrikeFont methodsFor: 'displaying' stamp: 'jm 5/12/2003 16:34'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor "Install the receiver on the given display context for further drawing operations." ^ aDisplayContext installStrikeFont: self foregroundColor: foregroundColor backgroundColor: backgroundColor ! ! !StrikeFont methodsFor: 'emphasis' stamp: 'jm 5/29/2003 18:04'! bonk: glyphForm with: bonkForm "Bonking means to run through the glyphs clearing out black pixels between characters to prevent them from straying into an adjacent character as a result of, eg, bolding or italicizing" "Uses the bonkForm to erase at every character boundary in glyphs." | bb offset | offset _ bonkForm offset x. bb _ BitBlt toForm: glyphForm. bb sourceForm: bonkForm; sourceRect: bonkForm boundingBox; combinationRule: Form erase; destY: 0. 1 to: xTable size-1 do: [:i | bb destX: (xTable at: i) + offset; copyBits]. ! ! !StrikeFont methodsFor: 'emphasis' stamp: 'sma 12/30/1999 15:02'! reset "Reset the cache of derivative emphasized fonts" | style font | derivativeFonts _ Array new: 32. #('B' 'I' 'BI') doWithIndex: [:tag :index | (style _ TextStyle named: self familyName) ifNotNil: [(font _ style fontArray detect: [:each | each name = (self name , tag)] ifNone: [nil]) ifNotNil: [derivativeFonts at: index put: font]]]! ! !StrikeFont methodsFor: 'file in/out' stamp: 'jm 6/15/2003 17:59'! readFromOldStrikeFile: fileName "Build an instance from the old ST-80 strike font file name. The '.strike' extension is optional." "Note: this is an old format; use strike2 format instead." | f rasterWidth | f _ (FileStream readOnlyFileNamed: fileName) binary. name _ fileName copyUpTo: $.. minAscii _ f nextWord. maxAscii _ f nextWord. maxWidth _ f nextWord. "strikeLength _" f nextWord. ascent _ f nextWord. descent _ f nextWord. "xOffset _" f nextWord. rasterWidth _ f nextWord * 16. emphasis _ 0. glyphs _ Form extent: rasterWidth @ self height. glyphs bits fromByteStream: f. characterToGlyphMap _ nil. xTable _ (Array new: maxAscii + 3) atAllPut: 0. minAscii + 1 to: maxAscii + 3 do: [:i | xTable at: i put: f nextWord]. "Set up space character" ((xTable at: (Space asciiValue + 2)) = 0 or: [(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))]) ifTrue: [(Space asciiValue + 2) to: xTable size do: [:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]]. f close. ! ! !StrikeFont methodsFor: 'file in/out' stamp: 'jm 5/23/2003 11:06'! readFromStrike2: fileName "Build an instance from the strike font stored in strike2 format." "StrikeFont new readFromStrike2: 'Palatino14.sf2'" | file | ('*.sf2' match: fileName) ifFalse: [self halt. "likely incompatible"]. name _ fileName copyUpTo: $. . "get family name" file _ (FileStream readOnlyFileNamed: fileName) binary. self readFromStrike2Stream: file. file close. ! ! !StrikeFont methodsFor: 'file in/out' stamp: 'jm 5/12/2003 17:19'! readFromStrike2Stream: file "Build an instance from the supplied binary stream on data in strike2 format" | fType | fType _ file nextInt32. fType = 2 ifFalse: [file close. self error: 'not strike2 format']. minAscii _ file nextInt32. maxAscii _ file nextInt32. maxWidth _ file nextInt32. ascent _ file nextInt32. descent _ file nextInt32. pointSize _ file nextInt32. emphasis _ file nextInt32. xTable _ (Array new: maxAscii + 3) atAllPut: 0. (minAscii + 1 to: maxAscii + 3) do: [:index | xTable at: index put: file nextInt32]. glyphs _ Form new readFrom: file. "Set up space character" ((xTable at: (Space asciiValue + 2)) = 0 or: [(xTable at: (Space asciiValue + 2)) = (xTable at: (Space asciiValue + 1))]) ifTrue: [(Space asciiValue + 2) to: xTable size do: [:index | xTable at: index put: ((xTable at: index) + DefaultSpace)]]. characterToGlyphMap _ nil.! ! !StrikeFont methodsFor: 'file in/out' stamp: 'jm 5/12/2003 17:20'! writeAsStrike2On: aStream "Write me onto the given binary stream in strike2 format." aStream nextInt32Put: 2. aStream nextInt32Put: minAscii. aStream nextInt32Put: maxAscii. aStream nextInt32Put: maxWidth. aStream nextInt32Put: ascent. aStream nextInt32Put: descent. aStream nextInt32Put: pointSize. aStream nextInt32Put: emphasis. (minAscii + 1 to: maxAscii + 3) do: [:i | aStream nextInt32Put: (xTable at: i)]. glyphs writeOn: aStream. ! ! !StrikeFont methodsFor: 'file in/out' stamp: 'jm 5/12/2003 17:49'! writeAsStrike2named: fileName "Write me onto a file in strike2 format. By convention, the file name should be of the form: <family name><pointSize>.sf2" | file | file _ (FileStream newFileNamed: fileName) binary. self writeAsStrike2On: file. file close. ! ! !StrikeFont methodsFor: 'utilities' stamp: 'di 3/27/2000 14:25'! characterFormAt: character "Answer a Form copied out of the glyphs for the argument, character." | ascii leftX rightX | ascii _ character asciiValue. (ascii between: minAscii and: maxAscii) ifFalse: [ascii _ maxAscii + 1]. leftX _ xTable at: ascii + 1. rightX _ xTable at: ascii + 2. ^ glyphs copy: (leftX @ 0 corner: rightX @ self height)! ! !StrikeFont methodsFor: 'utilities' stamp: 'di 3/27/2000 16:15'! characterFormAt: character put: characterForm "Copy characterForm over the glyph for the argument, character." | ascii leftX rightX widthDif newGlyphs | ascii _ character asciiValue. ascii < minAscii ifTrue: [^ self error: 'Cant store characters below min ascii']. ascii > maxAscii ifTrue: [(self confirm: 'This font does not accomodate ascii values higher than ' , maxAscii printString , '. Do you wish to extend it permanently to handle values up to ' , ascii printString) ifTrue: [self extendMaxAsciiTo: ascii] ifFalse: [^ self error: 'No change made']]. leftX _ xTable at: ascii + 1. rightX _ xTable at: ascii + 2. widthDif _ characterForm width - (rightX - leftX). widthDif ~= 0 ifTrue: ["Make new glyphs with more or less space for this char" newGlyphs _ Form extent: (glyphs width + widthDif) @ glyphs height. newGlyphs copy: (0@0 corner: leftX@glyphs height) from: 0@0 in: glyphs rule: Form over. newGlyphs copy: ((rightX+widthDif)@0 corner: newGlyphs width@glyphs height) from: rightX@0 in: glyphs rule: Form over. glyphs _ newGlyphs. "adjust further entries on xTable" ascii+2 to: xTable size do: [:i | xTable at: i put: (xTable at: i) + widthDif]]. glyphs copy: (leftX @ 0 extent: characterForm extent) from: 0@0 in: characterForm rule: Form over " | f | f _ TextStyle defaultFont. f characterFormAt: $ put: (Form extent: (f widthOf: $ )+10@f height) "! ! !StrikeFont methodsFor: 'utilities' stamp: 'sma 3/11/2000 11:28'! edit: character "(TextStyle default fontAt: 1) edit: $_" "Open a Bit Editor on the given character. Note that you must do an accept (in the option menu of the bit editor) if you want this work. Accepted edits will not take effect in the font until you leave or close the bit editor. Also note that unaccepted edits will be lost when you leave or close." | charForm editRect scaleFactor bitEditor savedForm r | charForm _ self characterFormAt: character. editRect _ BitEditor locateMagnifiedView: charForm scale: (scaleFactor _ 8@8). bitEditor _ BitEditor bitEdit: charForm at: editRect topLeft scale: scaleFactor remoteView: nil. savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)). bitEditor controller startUp. bitEditor release. savedForm displayOn: Display at: r topLeft. self characterFormAt: character put: charForm! ! !StrikeFont methodsFor: 'utilities' stamp: 'di 4/28/2000 16:10'! fixOneWideChars "This fixes all 1-wide characters to be 2 wide with blank on the right so as not to cause artifacts in neighboring characters in bold or italic." | twoWide | minAscii to: maxAscii do: [:i | (self widthOf: (Character value: i)) = 1 ifTrue: [twoWide _ Form extent: 2@glyphs height. (self characterFormAt: (Character value: i)) displayOn: twoWide at: 0@0. self characterFormAt: (Character value: i) put: twoWide]]. " StrikeFont allInstancesDo: [:f | f fixOneWideChars]. StrikeFont shutDown. 'Flush synthetic fonts'. " ! ! !StrikeFont methodsFor: 'utilities' stamp: 'sma 2/10/2000 22:56'! fontDisplay "TextStyle default defaultFont fontDisplay." Display restoreAfter: [(Form extent: 440@400) displayAt: 90@90. 0 to: 15 do: [:i | i hex displayAt: 100 @ (20 * i + 100). 0 to: 15 do: [:j | ((16*i+j) between: 1 and: (self xTable size - 2)) ifTrue: [(self characterFormAt: (16 * i + j) asCharacter) displayAt: (20 * j + 150) @ (20 * i + 100)]]]. 'Click to continue...' asDisplayText displayAt: 100@450]! ! !StrikeFont methodsFor: 'utilities' stamp: 'jm 5/12/2003 17:48'! widthOfString: aString "Answer the width of the given string in this font." "TextStyle default defaultFont widthOfString: 'hello!!'" ^ self composeWord: (1 to: aString size) in: aString beginningAt: 0 ! ! !StrikeFont methodsFor: 'printing' stamp: 'jm 5/12/2003 17:56'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self name; space; print: self height; nextPut: $). ! ! !StrikeFont methodsFor: 'private' stamp: 'jm 5/29/2003 18:04'! characters: anInterval in: sourceString displayAt: aPoint clippedBy: clippingRectangle rule: ruleInteger fillColor: aForm "Simple, slow, primitive method for displaying a line of characters. No wrap-around is provided." | ascii destPoint bb leftX rightX sourceRect | destPoint _ aPoint. bb _ BitBlt toForm: Display. anInterval do: [:i | ascii _ (sourceString at: i) asciiValue. (ascii < minAscii or: [ascii > maxAscii]) ifTrue: [ascii _ maxAscii]. leftX _ xTable at: ascii + 1. rightX _ xTable at: ascii + 2. sourceRect _ leftX@0 extent: (rightX-leftX) @ self height. bb copyFrom: sourceRect in: glyphs to: destPoint. destPoint _ destPoint + ((rightX-leftX)@0)]. ^ destPoint! ! !StrikeFont methodsFor: 'private' stamp: 'jm 5/12/2003 16:40'! composeWord: aTextLineInterval in: aString beginningAt: startX "Non-primitive composition of a word--add the widths of all the characters in the given interval to startX and answer the total. Similar to the scanning primitive, but does not process any stop conditions." | result | result _ startX. aTextLineInterval do: [:i | result _ result + (self widthOf: (aString at: i))]. ^ result ! ! !StrikeFont methodsFor: 'private' stamp: 'ar 5/18/2000 18:13'! createCharacterToGlyphMap "Private. Create the character to glyph mapping for a font that didn't have any before. This is basically equivalent to what the former setStopCondition did, only based on indexes." | map | map _ Array new: 256. 0 to: minAscii - 1 do:[:i| map at: i + 1 put: maxAscii + 1]. minAscii to: maxAscii do:[:i| map at: i + 1 put: i]. maxAscii + 1 to: 255 do:[:i| map at: i + 1 put: maxAscii + 1]. ^map! ! !StrikeFont methodsFor: 'private' stamp: 'ar 5/23/2000 12:48'! extendMaxAsciiTo: newMax "Extend the range of this font so that it can display glyphs up to newMax." (newMax+3) <= xTable size ifTrue: [^ self]. "No need to extend." xTable size = (maxAscii+3) ifFalse: [^ self error: 'This font is not well-formed.']. "Insert a bunch of zero-width characters..." xTable _ (xTable copyFrom: 1 to: maxAscii+2) , ((maxAscii+1 to: newMax) collect: [:i | xTable at: maxAscii+2]) , { xTable at: maxAscii+3 }. maxAscii _ newMax. self fillZeroWidthSlots. characterToGlyphMap _ nil.! ! !StrikeFont methodsFor: 'private' stamp: 'jm 5/24/2003 16:29'! fillZeroWidthSlots "Note: this is slow because it copies the font once for every replacement." | nullGlyph | nullGlyph _ (Form extent: 1@glyphs height) fillColor: Color gray. "Fill the empty slots with narrow box characters." minAscii to: maxAscii do: [:i | (self widthOf: (Character value: i)) = 0 ifTrue: [self characterFormAt: (Character value: i) put: nullGlyph]]. ! ! !StrikeFont class methodsFor: 'instance creation' stamp: 'tk 1/28/1999 11:31'! familyName: aName size: aSize emphasized: emphasisCode "Create the font with this emphasis" ^ (self familyName: aName size: aSize) emphasized: emphasisCode! ! !StrikeFont class methodsFor: 'instance creation' stamp: 'bolot 11/2/1999 02:53'! passwordFontSize: aSize | aFont newXTable newGlyphs | aFont _ (StrikeFont familyName: #NewYork10 size: aSize) copy. newXTable _ aFont xTable copy. newGlyphs _ aFont glyphs copy. aFont instVarNamed: 'xTable' put: newXTable. aFont instVarNamed: 'glyphs' put: newGlyphs. aFont minAscii to: aFont maxAscii do: [:ascii | aFont characterFormAt: ascii asCharacter put: (aFont characterFormAt: $*)]. ^aFont! ! !StrikeFont class methodsFor: 'examples' stamp: 'jm 5/12/2003 17:44'! example "Displays a line of text on the display screen at the location of the cursor." "StrikeFont example" TextStyle default defaultFont displayLine: 'A line of text in the default font.' at: 10@10 ! ! !StrikeFont class methodsFor: 'derivative font caching' stamp: 'tk 6/24/1999 11:45'! shutDown "StrikeFont shutDown" "Deallocate synthetically derived copies of base fonts to save space" self allSubInstancesDo: [:sf | sf reset]! ! !StrikeFont class methodsFor: 'accessing' stamp: 'jm 6/15/2003 23:31'! familyName: aName size: aSize "Answer a font (or the default font if the name is unknown) in the specified size." "StrikeFont familyName: 'ComicBold' size: 12" | fonts fStyle | fonts _ StrikeFont allInstances select: [:f | f name = aName]. fStyle _ fonts size = 0 ifTrue: [TextStyle default] ifFalse: [TextStyle fontArray: fonts]. ^ fStyle fontOfSize: aSize ! ! !StrikeFont class methodsFor: 'accessing' stamp: 'jm 6/15/2003 23:28'! familyNames "StrikeFont familyNames" ^ (TextConstants select: [:each | each isKindOf: TextStyle]) keys asSortedCollection ! ! !StrikeFont class methodsFor: 'accessing' stamp: 'jm 6/9/2003 21:46'! sizesForFamilyName: fontName "Answer a collection of sizes for the font with the given name. If there are no fonts of the given name answer an empty collection." "StrikeFont sizesForFamilyName: 'NewYork'" ^ ((TextStyle named: fontName asSymbol) ifNil: [^ #()]) fontArray collect: [:f | f height] ! ! !String methodsFor: 'accessing' stamp: 'wod 6/16/1998 15:24'! at: index put: aCharacter "Primitive. Store the Character in the field of the receiver indicated by the index. Fail if the index is not an Integer or is out of bounds, or if the argument is not a Character. Essential. See Object documentation whatIsAPrimitive." <primitive: 64> (aCharacter isKindOf: Character) ifTrue: [ index isInteger ifTrue: [self errorSubscriptBounds: index] ifFalse: [self errorNonIntegerIndex]] ifFalse: [self error: 'Strings only store Characters']! ! !String methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! byteAt: index <primitive: 60> ^(self at: index) asciiValue! ! !String methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! byteAt: index put: value <primitive: 61> self at: index put: value asCharacter. ^value! ! !String methodsFor: 'accessing' stamp: 'ls 3/19/2000 16:43'! findCloseParenthesisFor: startIndex "assume (self at: startIndex) is $(. Find the matching $), allowing parentheses to nest." " '(1+(2-3))-3.14159' findCloseParenthesisFor: 1 " " '(1+(2-3))-3.14159' findCloseParenthesisFor: 4 " | pos nestLevel | pos := startIndex+1. nestLevel := 1. [ pos <= self size ] whileTrue: [ (self at: pos) = $( ifTrue: [ nestLevel := nestLevel + 1 ]. (self at: pos) = $) ifTrue: [ nestLevel := nestLevel - 1 ]. nestLevel = 0 ifTrue: [ ^pos ]. pos := pos + 1. ]. ^self size + 1! ! !String methodsFor: 'accessing' stamp: 'ar 4/11/1999 22:15'! findString: subString "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^self findString: subString startingAt: 1.! ! !String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:43'! findString: subString startingAt: start "Answer the index of subString within the receiver, starting at start. If the receiver does not contain subString, answer 0." ^ self findSubstring: subString in: self startingAt: start matchTable: CaseSensitiveOrder! ! !String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:45'! findString: key startingAt: start caseSensitive: caseSensitive "Answer the index in this String at which the substring key first occurs, at or beyond start. The match can be case-sensitive or not. If no match is found, zero will be returned." caseSensitive ifTrue: [^ self findSubstring: key in: self startingAt: start matchTable: CaseSensitiveOrder] ifFalse: [^ self findSubstring: key in: self startingAt: start matchTable: CaseInsensitiveOrder]! ! !String methodsFor: 'accessing' stamp: 'di 11/15/1998 16:53'! includesSubstring: aString caseSensitive: caseSensitive ^ (self findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0! ! !String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'! indexOf: aCharacter (aCharacter class == Character) ifFalse: [^ 0]. ^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: 1! ! !String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'! indexOf: aCharacter startingAt: start (aCharacter class == Character) ifFalse: [^ 0]. ^ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start! ! !String methodsFor: 'accessing' stamp: 'di 9/1/1999 18:28'! indexOf: aCharacter startingAt: start ifAbsent: aBlock | ans | (aCharacter class == Character) ifFalse: [ ^ aBlock value ]. ans _ String indexOfAscii: aCharacter asciiValue inString: self startingAt: start. ans = 0 ifTrue: [ ^ aBlock value ] ifFalse: [ ^ ans ]! ! !String methodsFor: 'accessing' stamp: 'ls 8/20/1998 05:19'! indexOfAnyOf: aCharacterSet ifAbsent: aBlock "returns the index of the first character in the given set. Returns the evaluation of aBlock if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: 1 ifAbsent: aBlock! ! !String methodsFor: 'accessing' stamp: 'ls 8/20/1998 05:19'! indexOfAnyOf: aCharacterSet startingAt: start "returns the index of the first character in the given set, starting from start. Returns 0 if none are found" ^self indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: [ 0 ]! ! !String methodsFor: 'accessing' stamp: 'ls 8/18/1998 00:27'! indexOfAnyOf: aCharacterSet startingAt: start ifAbsent: aBlock "returns the index of the first character in the given set, starting from start" | ans | ans _ String findFirstInString: self inSet: aCharacterSet byteArrayMap startingAt: start. ans = 0 ifTrue: [ ^aBlock value ] ifFalse: [ ^ans ]! ! !String methodsFor: 'accessing' stamp: 'di 11/15/1998 17:02'! indexOfSubCollection: sub startingAt: start ifAbsent: exceptionBlock | index | index _ self findSubstring: sub in: self startingAt: start matchTable: CaseSensitiveOrder. index = 0 ifTrue: [^ exceptionBlock value]. ^ index! ! !String methodsFor: 'accessing' stamp: 'jm 5/24/2003 13:35'! lines "Answer a collection of lines for this string. Lines are terminated by a CR or LF character or possibly both. The termination character(s) are not included in the line." | cr lf sz result start i ch end | cr _ Character cr. lf _ Character lf. sz _ self size. result _ OrderedCollection new: 100. start _ i _ 1. [true] whileTrue: [ [ch _ self at: i. i < sz and: [(ch ~~ cr) & (ch ~~ lf)]] whileTrue: [ i _ i + 1]. "scan for line end" end _ (ch == cr) | (ch == lf) ifTrue: [i - 1] ifFalse: [i]. result addLast: (self copyFrom: start to: end). (i _ i + 1) <= sz ifTrue: [ (ch = cr and: [(self at: i) = lf]) ifTrue: [i _ i + 1]. "CR-LF" (ch = lf and: [(self at: i) = cr]) ifTrue: [i _ i + 1]]. "LF-CR" i > sz ifTrue: [^ result asArray]. start _ i]. ! ! !String methodsFor: 'accessing' stamp: 'BJP 6/12/2000 18:53'! skipAnySubStr: delimiters startingAt: start "Answer the index of the last character within the receiver, starting at start, that does NOT match one of the delimiters. delimiters is a Array of substrings (Characters also allowed). If the receiver is all delimiters, answer size + 1." | any this ind ii | ii _ start-1. [(ii _ ii + 1) <= self size] whileTrue: [ "look for char that does not match" any _ false. delimiters do: [:delim | delim class == Character ifTrue: [(self at: ii) == delim ifTrue: [any _ true]] ifFalse: ["a substring" delim size > (self size - ii + 1) ifFalse: "Here's where the one-off error was." [ind _ 0. this _ true. delim do: [:dd | dd == (self at: ii+ind) ifFalse: [this _ false]. ind _ ind + 1]. this ifTrue: [ii _ ii + delim size - 1. any _ true]] ifTrue: [any _ false] "if the delim is too big, it can't match"]]. any ifFalse: [^ ii]]. ^ self size + 1! ! !String methodsFor: 'comparing' stamp: 'di 9/14/1998 16:29'! = aString "Answer whether the receiver sorts equally as aString. The collation order is simple ascii (with case differences)." aString species == String ifFalse: [^ false]. ^ (self compare: self with: aString collated: AsciiOrder) = 2! ! !String methodsFor: 'comparing' stamp: 'di 11/15/1998 17:25'! beginsWith: prefix "Answer whether the receiver begins with the given prefix string. The comparison is case-sensitive." self size < prefix size ifTrue: [^ false]. ^ (self findSubstring: prefix in: self startingAt: 1 matchTable: CaseSensitiveOrder) = 1 ! ! !String methodsFor: 'comparing' stamp: 'sw 4/19/1999 12:11'! caseInsensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case insensitive." ^ (self compare: self with: aString collated: CaseInsensitiveOrder) <= 2! ! !String methodsFor: 'comparing' stamp: 'di 9/20/1998 14:33'! caseSensitiveLessOrEqual: aString "Answer whether the receiver sorts before or equal to aString. The collation order is case sensitive." ^ (self compare: self with: aString collated: CaseSensitiveOrder) <= 2! ! !String methodsFor: 'comparing' stamp: 'di 11/15/1998 17:25'! endsWith: suffix "Answer whether the tail end of the receiver is the same as suffix. The comparison is case-sensitive." | extra | (extra _ self size - suffix size) < 0 ifTrue: [^ false]. ^ (self findSubstring: suffix in: self startingAt: extra + 1 matchTable: CaseSensitiveOrder) > 0 " 'Elvis' endsWith: 'vis' "! ! !String methodsFor: 'comparing' stamp: 'di 11/19/1998 13:37'! match: text "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." ^ self startingAt: 1 match: text startingAt: 1 " '*' match: 'zort' true '*baz' match: 'mobaz' true '*baz' match: 'mobazo' false '*baz*' match: 'mobazo' true '*baz*' match: 'mozo' false 'foo*' match: 'foozo' true 'foo*' match: 'bozo' false 'foo*baz' match: 'foo23baz' true 'foo*baz' match: 'foobaz' true 'foo*baz' match: 'foo23bazo' false 'foo' match: 'Foo' true 'foo*baz*zort' match: 'foobazort' false 'foo*baz*zort' match: 'foobazzort' false '*foo#zort' match: 'afoo3zortthenfoo3zort' true '*foo*zort' match: 'afoodezortorfoo3zort' true "! ! !String methodsFor: 'comparing' stamp: 'di 11/19/1998 13:28'! startingAt: keyStart match: text startingAt: textStart "Answer whether text matches the pattern in this string. Matching ignores upper/lower case differences. Where this string contains #, text may contain any character. Where this string contains *, text may contain any sequence of characters." | anyMatch matchStart matchEnd i matchStr j ii jj | i _ keyStart. j _ textStart. "Check for any #'s" [i > self size ifTrue: [^ j > text size "Empty key matches only empty string"]. (self at: i) = $#] whileTrue: ["# consumes one char of key and one char of text" j > text size ifTrue: [^ false "no more text"]. i _ i+1. j _ j+1]. "Then check for *" (self at: i) = $* ifTrue: [i = self size ifTrue: [^ true "Terminal * matches all"]. "* means next match string can occur anywhere" anyMatch _ true. matchStart _ i + 1] ifFalse: ["Otherwise match string must occur immediately" anyMatch _ false. matchStart _ i]. "Now determine the match string" matchEnd _ self size. (ii _ self indexOf: $* startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '** not valid -- use * instead']. matchEnd _ ii-1]. (ii _ self indexOf: $# startingAt: matchStart) > 0 ifTrue: [ii = 1 ifTrue: [self error: '*# not valid -- use #* instead']. matchEnd _ matchEnd min: ii-1]. matchStr _ self copyFrom: matchStart to: matchEnd. "Now look for the match string" [jj _ text findString: matchStr startingAt: j caseSensitive: false. anyMatch ifTrue: [jj > 0] ifFalse: [jj = j]] whileTrue: ["Found matchStr at jj. See if the rest matches..." (self startingAt: matchEnd+1 match: text startingAt: jj + matchStr size) ifTrue: [^ true "the rest matches -- success"]. "The rest did not match." anyMatch ifFalse: [^ false]. "Preceded by * -- try for a later match" j _ j+1]. ^ false "Failed to find the match string"! ! !String methodsFor: 'converting' stamp: 'di 11/9/1998 12:17'! adaptToNumber: rcvr andSend: selector "If I am involved in arithmetic with a number, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !String methodsFor: 'converting' stamp: 'di 11/6/1998 13:49'! adaptToPoint: rcvr andSend: selector "If I am involved in arithmetic with a point, convert me to a number." ^ rcvr perform: selector with: self asNumber! ! !String methodsFor: 'converting' stamp: 'sma 3/11/2000 17:25'! asHtml "Do the basic character conversion for HTML. Leave all original return and tabs in place, so can conver back by simply removing bracked things. 4/4/96 tk" | temp | temp _ self copyReplaceAll: '&' with: '&'. HtmlEntities keysAndValuesDo: [:entity :char | char = $& ifFalse: [temp _ temp copyReplaceAll: char asString with: '&' , entity , ';']]. temp _ temp copyReplaceAll: ' ' with: ' <IMG SRC="tab.gif" ALT=" ">'. temp _ temp copyReplaceAll: ' ' with: ' <BR>'. ^ temp " 'A<&>B' asHtml "! ! !String methodsFor: 'converting' stamp: 'sma 6/12/2000 11:40'! asLowercase "Answer a String made up from the receiver whose characters are all lowercase." ^ self copy asString translateToLowercase! ! !String methodsFor: 'converting' stamp: 'jm 10/14/2002 19:04'! asNumber "Answer the Number created by interpreting the receiver as the string representation of a number." ^ Number readFrom: (ReadStream on: self) ! ! !String methodsFor: 'converting' stamp: 'sma 6/12/2000 11:41'! asUppercase "Answer a String made up from the receiver whose characters are all uppercase." ^ self collect: [:each | each asUppercase]! ! !String methodsFor: 'converting' stamp: 'ls 9/10/1998 08:48'! capitalized "Return a copy with the first letter capitalized" | cap | self isEmpty ifTrue: [ ^self copy ]. cap _ self copy. cap at: 1 put: (cap at: 1) asUppercase. ^ cap! ! !String methodsFor: 'converting' stamp: 'jm 5/29/2003 18:55'! correctAgainst: wordList continuedFrom: oldCollection "Like correctAgainst:. Use when you want to correct against several lists, give nil as the first oldCollection, and nil as the last wordList." ^ wordList isNil ifTrue: [self correctAgainstEnumerator: nil continuedFrom: oldCollection] ifFalse: [ self correctAgainstEnumerator: [:action | wordList do: [:w | w ifNotNil: [action value: w]]] continuedFrom: oldCollection] ! ! !String methodsFor: 'converting' stamp: 'ls 8/12/1998 23:31'! encodeForHTTP "change dangerous characters to their %XX form, for use in HTTP transactions" | encodedStream | encodedStream _ WriteStream on: (String new). self do: [ :c | c isSafeForHTTP ifTrue: [ encodedStream nextPut: c ] ifFalse: [ encodedStream nextPut: $%. encodedStream nextPut: (c asciiValue // 16) asHexDigit. encodedStream nextPut: (c asciiValue \\ 16) asHexDigit. ] ]. ^encodedStream contents. ! ! !String methodsFor: 'converting' stamp: 'bf 10/13/1999 09:26'! findSelector "Dan's code for hunting down selectors with keyword parts; while this doesn't give a true parse, in most cases it does what we want, in where it doesn't, we're none the worse for it." | sel possibleParens level n | sel _ self withBlanksTrimmed. (sel includes: $:) ifTrue: [possibleParens _ sel findTokens: Character separators. sel _ String streamContents: [:s | level _ 0. possibleParens do: [:token | (level = 0 and: [token endsWith: ':']) ifTrue: [s nextPutAll: token] ifFalse: [(n _ token occurrencesOf: $( ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $[ ) > 0 ifTrue: [level _ level + n]. (n _ token occurrencesOf: $] ) > 0 ifTrue: [level _ level - n]. (n _ token occurrencesOf: $) ) > 0 ifTrue: [level _ level - n]]]]]. sel isEmpty ifTrue: [^ nil]. Symbol hasInterned: sel ifTrue: [:aSymbol | ^ aSymbol]. ^ nil! ! !String methodsFor: 'converting' stamp: 'sw 8/20/1999 10:23'! initialIntegerOrNil "Answer the integer represented by the leading digits of the receiver, or nil if the receiver does not begin with a digit" | firstNonDigit | (self size == 0 or: [self first isDigit not]) ifTrue: [^ nil]. firstNonDigit _ (self findFirst: [:m | m isDigit not]). firstNonDigit = 0 ifTrue: [firstNonDigit _ self size + 1]. ^ (self copyFrom: 1 to: (firstNonDigit - 1)) asNumber " '234Whoopie' initialIntegerOrNil 'wimpy' initialIntegerOrNil '234' initialIntegerOrNil '2N' initialIntegerOrNil '2' initialIntegerOrNil ' 89Ten ' initialIntegerOrNil '78 92' initialIntegerOrNil " ! ! !String methodsFor: 'converting' stamp: 'sma 4/22/2000 17:17'! keywords "Answer an array of the keywords that compose the receiver." | answer size last | answer _ OrderedCollection new. size _ self size. last _ 0. 1 to: size do: [:index | (self at: index) == $: ifTrue: [answer add: (self copyFrom: last + 1 to: index). last _ index]]. last = size ifFalse: [answer add: (self copyFrom: last + 1 to: size)]. ^ answer asArray! ! !String methodsFor: 'converting' stamp: 'di 9/24/1999 12:31'! splitInteger "Answer an array that is a splitting of self into a string and an integer. '43Sam' ==> #(43 'Sam'). 'Try90' ==> #('Try' 90) BUT NOTE: 'Sam' ==> #('Sam' 0), and '90' ==> #('' 90) ie, (<string> <integer>)." | pos | (pos _ self findFirst: [:d | d isDigit not]) == 0 ifTrue: [^ Array with: '' with: self asNumber]. self first isDigit ifTrue: [ ^ Array with: (self copyFrom: 1 to: pos - 1) asNumber with: (self copyFrom: pos to: self size)]. (pos _ self findFirst: [:d | d isDigit]) == 0 ifTrue: [^ Array with: self with: 0]. ^ Array with: (self copyFrom: 1 to: pos - 1) with: (self copyFrom: pos to: self size) asNumber! ! !String methodsFor: 'converting' stamp: 'ls 1/3/1999 13:36'! substrings "Answer an array of the substrings that compose the receiver." | result end beginning | result _ WriteStream on: (Array new: 10). end _ 0. "find one substring each time through this loop" [ "find the beginning of the next substring" beginning _ self indexOfAnyOf: CSNonSeparators startingAt: end+1 ifAbsent: [ nil ]. beginning ~~ nil ] whileTrue: [ "find the end" end _ self indexOfAnyOf: CSSeparators startingAt: beginning ifAbsent: [ self size + 1 ]. end _ end - 1. result nextPut: (self copyFrom: beginning to: end). ]. ^result contents! ! !String methodsFor: 'converting' stamp: 'ls 8/15/1998 10:31'! translateFrom: start to: stop table: table "translate the characters in the string by the given table, in place" String translate: self from: start to: stop table: table! ! !String methodsFor: 'converting' stamp: 'ls 8/18/1998 07:44'! translateToLowercase "Translate all characters to lowercase, in place" self translateWith: LowercasingTable! ! !String methodsFor: 'converting' stamp: 'ls 8/15/1998 08:30'! translateWith: table "translate the characters in the string by the given table, in place" ^self translateFrom: 1 to: self size table: table! ! !String methodsFor: 'converting' stamp: 'sw 9/2/1998 17:09'! truncateWithElipsisTo: maxLength "Return myself or a copy suitably shortened but with elipsis added" ^ self size <= maxLength ifTrue: [self] ifFalse: [(self copyFrom: 1 to: (maxLength - 3)), '...'] "'truncateWithElipsisTo:' truncateWithElipsisTo: 20"! ! !String methodsFor: 'converting' stamp: 'bolot 11/3/1999 17:35'! withBlanksCondensed "Return a copy of the receiver with leading/trailing blanks removed and consecutive white spaces condensed." | trimmed lastBlank | trimmed _ self withBlanksTrimmed. ^String streamContents: [:stream | lastBlank _ false. trimmed do: [:c | (c isSeparator and: [lastBlank]) ifFalse: [stream nextPut: c]. lastBlank _ c isSeparator]]. " ' abc d ' withBlanksCondensed" ! ! !String methodsFor: 'converting' stamp: 'tk 3/28/1999 22:44'! withNoLineLongerThan: aNumber "Answer a string with the same content as receiver, but rewrapped so that no line has more characters than the given number" | listOfLines currentLast currentStart resultString putativeLast putativeLine crPosition | aNumber isNumber not | (aNumber < 1) ifTrue: [self error: 'too narrow']. listOfLines _ OrderedCollection new. currentLast _ 0. [currentLast < self size] whileTrue: [currentStart _ currentLast + 1. putativeLast _ (currentStart + aNumber - 1) min: self size. putativeLine _ self copyFrom: currentStart to: putativeLast. (crPosition _ putativeLine indexOf: Character cr) > 0 ifTrue: [putativeLast _ currentStart + crPosition - 1. putativeLine _ self copyFrom: currentStart to: putativeLast]. currentLast _ putativeLast == self size ifTrue: [putativeLast] ifFalse: [currentStart + putativeLine lastSpacePosition - 1]. currentLast <= currentStart ifTrue: ["line has NO spaces; baleout!!" currentLast _ putativeLast]. listOfLines add: (self copyFrom: currentStart to: currentLast) withBlanksTrimmed]. listOfLines size > 0 ifFalse: [^ '']. resultString _ listOfLines first. 2 to: listOfLines size do: [:i | resultString _ resultString, String cr, (listOfLines at: i)]. ^ resultString "#(5 7 20) collect: [:i | 'Fred the bear went down to the brook to read his book in silence' withNoLineLongerThan: i]"! ! !String methodsFor: 'converting' stamp: 'ls 8/20/1998 10:43'! withSeparatorsCompacted "replace each sequences of whitespace by a single space character" | out pos textEnd | self isEmpty ifTrue: [ ^self ]. out _ WriteStream on: (String new: self size). pos _ 1. "current position in a scan through aString" "handle the case of initial separators" self first isSeparator ifTrue: [ out nextPut: Character space. pos _ self indexOfAnyOf: CSNonSeparators ifAbsent: [ self size + 1 ] ]. "central loop: handle a segment of text, followed possibly by a segment of whitespace" [ pos <= self size ] whileTrue: [ "handle a segment of text..." textEnd _ self indexOfAnyOf: CSSeparators startingAt: pos ifAbsent: [ self size + 1 ]. textEnd _ textEnd - 1. out nextPutAll: (self copyFrom: pos to: textEnd). pos _ textEnd + 1. pos <= self size ifTrue: [ pos _ self indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ self size + 1 ]. out nextPut: Character space ] ]. ^out contents! ! !String methodsFor: 'converting' stamp: 'sw 1/8/1999 14:45'! withoutLeadingDigits "Answer the portion of the receiver that follows any leading series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstNonDigit | firstNonDigit _ (self findFirst: [:m | m isDigit not and: [m ~~ $ ]]). ^ firstNonDigit > 0 ifTrue: [self copyFrom: firstNonDigit to: self size] ifFalse: [''] " '234Whoopie' withoutLeadingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !String methodsFor: 'converting' stamp: 'bf 11/24/1998 19:58'! withoutTrailingBlanks "Return a copy of the receiver from which trailing blanks have been trimmed." | last | last _ self findLast: [:c | c isSeparator not]. last = 0 ifTrue: [^ '']. "no non-separator character" ^ self copyFrom: 1 to: last " ' abc d ' withoutTrailingBlanks" ! ! !String methodsFor: 'converting'! withoutTrailingDigits "Answer the portion of the receiver that precedes any trailing series of digits and blanks. If the receiver consists entirely of digits and blanks, return an empty string" | firstDigit | firstDigit _ (self findFirst: [:m | m isDigit or: [m == $ ]]). ^ firstDigit > 0 ifTrue: [self copyFrom: 1 to: firstDigit-1] ifFalse: [self] " 'Whoopie234' withoutTrailingDigits ' 4321 BlastOff!!' withoutLeadingDigits 'wimpy' withoutLeadingDigits ' 89Ten ' withoutLeadingDigits '78 92' withoutLeadingDigits " ! ! !String methodsFor: 'displaying' stamp: 'jm 5/30/2003 13:17'! display "Display the receiver on the Display." self displayOn: Display at: 0@0. ! ! !String methodsFor: 'displaying' stamp: 'jm 5/25/2003 11:58'! displayAt: aPoint "Display the receiver at the given point." self displayOn: Display at: aPoint. ! ! !String methodsFor: 'displaying' stamp: 'jm 5/25/2003 11:57'! displayOn: aForm "Display the receiver on the given Form." self displayOn: aForm at: 0@0. ! ! !String methodsFor: 'displaying' stamp: 'jm 5/25/2003 12:00'! displayOn: aForm at: aPoint "Display myself at the given point on the given Form." (self asDisplayText foregroundColor: Color black backgroundColor: Color white) displayOn: aForm at: aPoint. ! ! !String methodsFor: 'displaying' stamp: 'jm 5/24/2003 16:29'! displayProgressAt: aPoint from: minVal to: maxVal during: workBlock "Display this string as a caption over a progress bar while workBlock is evaluated. EXAMPLE (Select next 6 lines and Do It) 'Now here''s some Real Progress' displayProgressAt: Sensor cursorPoint from: 0 to: 10 during: [:bar | 1 to: 10 do: [:x | bar value: x. (Delay forMilliseconds: 500) wait]]. HOW IT WORKS (Try this in any other language :-) Since your code (the last 2 lines in the above example) is in a block, this method gets control to display its heading before, and clean up the screen after, its execution. The key, though, is that the block is supplied with an argument, named 'bar' in the example, which will update the bar image every it is sent the message value: x, where x is in the from:to: range. " | delta savedArea captionText textFrame barFrame outerFrame result range lastW w | barFrame _ aPoint - (75@10) corner: aPoint + (75@10). captionText _ DisplayText text: self asText allBold. captionText foregroundColor: Color black backgroundColor: Color white. textFrame _ captionText boundingBox insetBy: -4. textFrame _ textFrame align: textFrame bottomCenter with: barFrame topCenter + (0@2). outerFrame _ barFrame merge: textFrame. delta _ outerFrame amountToTranslateWithin: Display boundingBox. barFrame _ barFrame translateBy: delta. textFrame _ textFrame translateBy: delta. outerFrame _ outerFrame translateBy: delta. savedArea _ Form fromDisplay: outerFrame. Display fillBlack: barFrame; fillWhite: (barFrame insetBy: 2). Display fillBlack: textFrame; fillWhite: (textFrame insetBy: 2). captionText displayOn: Display at: textFrame topLeft + (4@4). range _ maxVal = minVal ifTrue: [1] ifFalse: [maxVal - minVal]. "Avoid div by 0" lastW _ 0. result _ workBlock value: "Supply the bar-update block for evaluation in the work block" [:barVal | w _ ((barFrame width-4) asFloat * ((barVal-minVal) asFloat / range min: 1.0)) asInteger. w ~= lastW ifTrue: [ Display fill: (barFrame topLeft + (2@2) extent: w@16) fillColor: Color gray. lastW _ w]]. savedArea displayOn: Display at: outerFrame topLeft. ^ result! ! !String methodsFor: 'printing' stamp: 'sma 6/1/2000 09:48'! printOn: aStream "Print inside string quotes, doubling inbedded quotes." self storeOn: aStream! ! !String methodsFor: 'internet' stamp: 'sma 3/11/2000 20:40'! isoToSqueak ^ self collect: [:each | each isoToSqueak]! ! !String methodsFor: 'internet' stamp: 'ls 10/27/1998 00:52'! withSqueakLineEndings "assume the string is textual, and that CR, LF, and CRLF are all valid line endings. Replace each occurence with a single CR" | cr lf input c crlf inPos outPos outString lineEndPos newOutPos | cr _ Character cr. lf _ Character linefeed. crlf _ CharacterSet new. crlf add: cr; add: lf. inPos _ 1. outPos _ 1. outString _ String new: self size. [ lineEndPos _ self indexOfAnyOf: crlf startingAt: inPos ifAbsent: [0]. lineEndPos ~= 0 ] whileTrue: [ newOutPos _ outPos + (lineEndPos - inPos + 1). outString replaceFrom: outPos to: newOutPos - 2 with: self startingAt: inPos. outString at: newOutPos-1 put: cr. outPos _ newOutPos. ((self at: lineEndPos) = cr and: [ lineEndPos < self size and: [ (self at: lineEndPos+1) = lf ] ]) ifTrue: [ "CRLF ending" inPos _ lineEndPos + 2 ] ifFalse: [ "CR or LF ending" inPos _ lineEndPos + 1 ]. ]. "no more line endings. copy the rest" newOutPos _ outPos + (self size - inPos + 1). outString replaceFrom: outPos to: newOutPos-1 with: self startingAt: inPos. ^outString copyFrom: 1 to: newOutPos-1 ! ! !String methodsFor: 'testing' stamp: 'ls 7/4/1998 19:17'! isAllSeparators "whether the receiver is composed entirely of separators" self do: [ :c | c isSeparator ifFalse: [ ^false ] ]. ^true! ! !String methodsFor: 'testing' stamp: 'sw 11/5/1998 17:41'! lastSpacePosition "Answer the character position of the final space or other separator character in the receiver, and 0 if none" self size to: 1 by: -1 do: [:i | ((self at: i) isSeparator) ifTrue: [^ i]]. ^ 0 " 'fred the bear' lastSpacePosition 'ziggie' lastSpacePosition 'elvis ' lastSpacePosition 'wimpy ' lastSpacePosition '' lastSpacePosition "! ! !String methodsFor: 'paragraph support' stamp: 'RAA 8/30/1998 15:20'! indentationIfBlank: aBlock "Answer the number of leading tabs in the receiver. If there are no visible characters, pass the number of tabs to aBlock and return its value." | reader leadingTabs lastSeparator cr tab ch | cr _ Character cr. tab _ Character tab. reader _ ReadStream on: self. leadingTabs _ 0. [reader atEnd not and: [(ch _ reader next) == tab]] whileTrue: [leadingTabs _ leadingTabs + 1]. lastSeparator _ leadingTabs + 1. [reader atEnd not and: [ch isSeparator and: [ch ~~ cr]]] whileTrue: [lastSeparator _ lastSeparator + 1. ch _ reader next]. lastSeparator = self size | (ch == cr) ifTrue: [^aBlock value: leadingTabs]. ^leadingTabs! ! !String methodsFor: 'Object Explorer' stamp: 'RAA 6/21/1999 11:34'! asExplorerString ^self asString! ! !String methodsFor: 'Object Explorer' stamp: 'RAA 6/21/1999 11:28'! hasContentsInExplorer ^false! ! !String methodsFor: 'Dakota' stamp: 'RAA 7/22/2000 08:52'! getInteger32: location | integer | <primitive: 'getInteger' module: 'IntegerPokerPlugin'> "^IntegerPokerPlugin doPrimitive: #getInteger" "the following is about 7x faster than interpreting the plugin if not compiled" integer := ((self byteAt: location) bitShift: 24) + ((self byteAt: location+1) bitShift: 16) + ((self byteAt: location+2) bitShift: 8) + (self byteAt: location+3). integer > 1073741824 ifTrue: [ ^1073741824 - integer ]. ^integer ! ! !String methodsFor: 'Dakota' stamp: 'RAA 7/31/2000 16:06'! putInteger32: anInteger at: location | integer | <primitive: 'putInteger' module: 'IntegerPokerPlugin'> "IntegerPokerPlugin doPrimitive: #putInteger" "the following is close to 20x faster than the above if the primitive is not compiled" "PUTCOUNTER _ PUTCOUNTER + 1." integer _ anInteger. integer < 0 ifTrue: [integer := 1073741824 - integer. ]. self byteAt: location+3 put: (integer \\ 256). self byteAt: location+2 put: (integer bitShift: -8) \\ 256. self byteAt: location+1 put: (integer bitShift: -16) \\ 256. self byteAt: location put: (integer bitShift: -24) \\ 256. "Smalltalk at: #PUTCOUNTER put: 0"! ! !String methodsFor: 'system primitives' stamp: 'di 11/15/1998 16:27'! findSubstring: key in: body startingAt: start matchTable: matchTable "Answer the index in the string body at which the substring key first occurs, at or beyond start. The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches. If no match is found, zero will be returned. The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter." | index | <primitive: 246> self var: #key declareC: 'unsigned char *key'. self var: #body declareC: 'unsigned char *body'. self var: #matchTable declareC: 'unsigned char *matchTable'. key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index _ 1. [(matchTable at: (body at: startIndex+index-1) asciiValue + 1) = (matchTable at: (key at: index) asciiValue + 1)] whileTrue: [index = key size ifTrue: [^ startIndex]. index _ index+1]]. ^ 0 " ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7 "! ! !String methodsFor: 'system primitives' stamp: 'di 4/3/1999 00:37'! numArgs "Answer either the number of arguments that the receiver would take if considered a selector. Answer -1 if it couldn't be a selector. Note that currently this will answer -1 for anything begining with an uppercase letter even though the system will accept such symbols as selectors. It is intended mostly for the assistance of spelling correction." | firstChar numColons | firstChar _ self at: 1. firstChar isLetter ifTrue: [ firstChar isUppercase ifTrue: [ ^ -1 ]. numColons _ 0. self do: [ :ch | ch tokenish ifFalse: [ ^ -1 ]. (ch = $:) ifTrue: [numColons _ numColons + 1] ]. ^ (self last = $:) ifTrue: [ numColons > 0 ifTrue: [ numColons ] ifFalse: [ -1 ] ] ifFalse: [ numColons > 0 ifTrue: [ -1 ] ifFalse: [ 0 ] ] ]. firstChar isSpecial ifTrue: [self size = 1 ifTrue: [^ 1]. 2 to: self size do: [:i | (self at: i) isSpecial ifFalse: [^ -1]]. ^ 1]. ^ -1.! ! !String class methodsFor: 'instance creation' stamp: 'ls 9/10/1998 22:29'! crlf "Answer a string containing a carriage return and a linefeed." ^ self with: Character cr with: Character lf ! ! !String class methodsFor: 'instance creation' stamp: 'sw 6/15/1999 22:59'! tab "Answer a string containing a single tab character." ^ self with: Character tab ! ! !String class methodsFor: 'initialization' stamp: 'di 9/20/1998 14:09'! initialize "String initialize" | order | AsciiOrder _ (0 to: 255) as: ByteArray. CaseInsensitiveOrder _ AsciiOrder copy. ($a to: $z) do: [:c | CaseInsensitiveOrder at: c asciiValue + 1 put: (CaseInsensitiveOrder at: c asUppercase asciiValue +1)]. "Case-sensitive compare sorts space, digits, letters, all the rest..." CaseSensitiveOrder _ ByteArray new: 256 withAll: 255. order _ -1. ' 0123456789' do: "0..10" [:c | CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. ($a to: $z) do: "11-64" [:c | CaseSensitiveOrder at: c asUppercase asciiValue + 1 put: (order _ order+1). CaseSensitiveOrder at: c asciiValue + 1 put: (order _ order+1)]. 1 to: CaseSensitiveOrder size do: [:i | (CaseSensitiveOrder at: i) = 255 ifTrue: [CaseSensitiveOrder at: i put: (order _ order+1)]]. order = 255 ifFalse: [self error: 'order problem']. "a table for translating to lower case" LowercasingTable _ String new: 256. Character allCharacters do: [ :c | LowercasingTable at: (c asciiValue+1) put: c asLowercase ]. "CR and LF--characters that terminate a line" CSLineEnders _ CharacterSet empty. CSLineEnders add: Character cr. CSLineEnders add: Character lf. "separators and non-separators" CSSeparators _ CharacterSet separators. CSNonSeparators _ CSSeparators complement.! ! !String class methodsFor: 'initialization' stamp: 'jm 5/24/2003 13:52'! initializeHtmlEntities "String initializeHtmlEntities" HtmlEntities _ (Dictionary new: 128) at: 'amp' put: $&; at: 'lt' put: $<; at: 'gt' put: $>; at: 'quot' put: $"; at: 'euro' put: (Character value: 219); yourself. #('nbsp' 'iexcl' 'cent' 'pound' 'curren' 'yen' 'brvbar' 'sect' 'uml' 'copy' 'ordf' 'laquo' 'not' 'shy' 'reg' 'hibar' 'deg' 'plusmn' 'sup2' 'sup3' 'acute' 'micro' 'para' 'middot' 'cedil' 'sup1' 'ordm' 'raquo' 'frac14' 'frac12' 'frac34' 'iquest' 'Agrave' 'Aacute' 'Acirc' 'Atilde' 'Auml' 'Aring' 'AElig' 'Ccedil' 'Egrave' 'Eacute' 'Ecirc' 'Euml' 'Igrave' 'Iacute' 'Icirc' 'Iuml' 'ETH' 'Ntilde' 'Ograve' 'Oacute' 'Ocirc' 'Otilde' 'Ouml' 'times' 'Oslash' 'Ugrave' 'Uacute' 'Ucirc' 'Uuml' 'Yacute' 'THORN' 'szlig' 'agrave' 'aacute' 'acirc' 'atilde' 'auml' 'aring' 'aelig' 'ccedil' 'egrave' 'eacute' 'ecirc' 'euml' 'igrave' 'iacute' 'icirc' 'iuml' 'eth' 'ntilde' 'ograve' 'oacute' 'ocirc' 'otilde' 'ouml' 'divide' 'oslash' 'ugrave' 'uacute' 'ucirc' 'uuml' 'yacute' 'thorn' 'yuml' ) withIndexDo: [:each :index | HtmlEntities at: each put: (index + 159) asCharacter isoToSqueak]! ! !String class methodsFor: 'primitives' stamp: 'ls 9/14/1998 07:50'! findFirstInString: aString inSet: inclusionMap startingAt: start | i stringSize | <primitive: 244> self var: #aString declareC: 'unsigned char *aString'. self var: #inclusionMap declareC: 'char *inclusionMap'. inclusionMap size ~= 256 ifTrue: [ ^0 ]. i _ start. stringSize _ aString size. [ i <= stringSize and: [ (inclusionMap at: (aString at: i) asciiValue+1) = 0 ] ] whileTrue: [ i _ i + 1 ]. i > stringSize ifTrue: [ ^0 ]. ^i! ! !String class methodsFor: 'primitives' stamp: 'jm 10/12/1998 18:21'! indexOfAscii: anInteger inString: aString startingAt: start | stringSize | <primitive: 245> self var: #aCharacter declareC: 'int anInteger'. self var: #aString declareC: 'unsigned char *aString'. stringSize _ aString size. start to: stringSize do: [:pos | (aString at: pos) asciiValue = anInteger ifTrue: [^ pos]]. ^ 0 ! ! !String class methodsFor: 'primitives' stamp: 'ls 8/15/1998 12:15'! translate: aString from: start to: stop table: table "translate the characters in the string by the given table, in place" <primitive: 243> self var: #table declareC: 'unsigned char *table'. self var: #aString declareC: 'unsigned char *aString'. start to: stop do: [ :i | aString at: i put: (table at: (aString at: i) asciiValue+1) ]! ! !StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:36'! embeddedInMorphicWindowLabeled: labelString | window | window _ (SystemWindow labelled: labelString) model: self. window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents: readSelection: nil menu: #codePaneMenu:shifted:) frame: (0@0 corner: 1@1). ^ window! ! !StringHolder methodsFor: 'initialize-release' stamp: 'sw 10/16/1998 11:37'! openAsMorphLabel: labelString "Workspace new openAsMorphLabel: 'Workspace'" (self embeddedInMorphicWindowLabeled: labelString) openInWorld! ! !StringHolder methodsFor: 'initialize-release' stamp: 'sw 8/4/1998 18:21'! openAsMorphLabel: labelString inWorld: aWorld "Workspace new openAsMorphLabel: 'Workspace'" | window | window _ (SystemWindow labelled: labelString) model: self. window addMorph: (PluggableTextMorph on: self text: #contents accept: #acceptContents: readSelection: nil menu: #codePaneMenu:shifted:) frame: (0@0 corner: 1@1). window openInWorld: aWorld! ! !StringHolder methodsFor: 'initialize-release' stamp: 'sw 12/22/1998 00:16'! openLabel: aString "Create a standard system view of the model, me, a StringHolder and open it. If in mvc, terminate the active controller so that the new window will immediately be activated." self openLabel: aString andTerminate: true! ! !StringHolder methodsFor: 'initialize-release' stamp: 'sma 4/30/2000 10:15'! openLabel: aString andTerminate: terminateBoolean "Create a standard system view of the model, me, a StringHolder and open it.; do not terminate the active process if in mvc" | topView codeView | Smalltalk isMorphic ifTrue: [^ self openAsMorphLabel: aString]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. topView label: aString. topView minimumSize: 100 @ 50. codeView _ PluggableTextView on: self text: #contents accept: #acceptContents: readSelection: #contentsSelection menu: #codePaneMenu:shifted:. codeView window: (0@0 extent: 200@200). topView addSubView: codeView. "self contents size > 0 ifTrue: [ codeView hasUnacceptedEdits: true]. Is it already saved or not??" terminateBoolean ifTrue: [topView controller open] ifFalse: [topView controller openNoTerminate]! ! !StringHolder methodsFor: 'accessing' stamp: 'sw 1/12/1999 11:47'! contents: textOrString "Set textOrString to be the contents of the receiver." contents _ textOrString "asString"! ! !StringHolder methodsFor: 'accessing' stamp: 'sw 9/27/1999 14:16'! contentsChanged self changed: #contents! ! !StringHolder methodsFor: 'accessing' stamp: 'di 11/23/1998 15:21'! textContents: aStringOrText "Set aStringOrText to be the contents of the receiver." contents _ aStringOrText! ! !StringHolder methodsFor: 'code pane menu' stamp: 'sw 11/8/1999 17:56'! codePaneMenu: aMenu shifted: shifted "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items in a text pane" | donorMenu | donorMenu _ shifted ifTrue: [ParagraphEditor shiftedYellowButtonMenu] ifFalse: [ParagraphEditor yellowButtonMenu]. ^ aMenu labels: donorMenu labelString lines: donorMenu lineArray selections: donorMenu selections! ! !StringHolder methodsFor: 'code pane menu' stamp: 'wod 5/29/1998 16:35'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (self respondsTo: selector) ifTrue: [^ self perform: selector] ifFalse: [^ otherTarget perform: selector]! ! !StringHolder methodsFor: 'code pane menu' stamp: 'di 9/7/1999 11:27'! spawn: contentsString (Workspace new contents: contentsString) openLabel: 'Workspace' ! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 10/12/1999 17:42'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | (selector _ self selectedMessageName) ifNotNil: [class _ self selectedClassOrMetaClass. VersionsBrowser browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass meta: class isMeta category: self selectedMessageCategoryName selector: selector]! ! !StringHolder methodsFor: 'message list menu' stamp: 'jm 9/25/2006 21:59'! classListKey: aChar from: view "Respond to a Command key. I am a model with a list of classes and a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." aChar == $f ifTrue: [^ self findMethod]. aChar == $r ifTrue: [^ self recent]. aChar == $x ifTrue: [^ self removeClass]. ^ self messageListKey: aChar from: view ! ! !StringHolder methodsFor: 'message list menu' stamp: 'di 4/28/1999 11:34'! copyName "Copy the current selector to the clipboard" | selector | (selector _ self selectedMessageName) ifNotNil: [ParagraphEditor clipboardTextPut: selector asString asText]! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 5/8/2000 02:59'! messageListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." | sel class | (class _ self selectedClassOrMetaClass) ifNil: [^ self arrowKey: aChar from: view]. sel _ self selectedMessageName. aChar == $b ifTrue: [^ Browser fullOnClass: class selector: sel]. aChar == $N ifTrue: [^ self browseClassRefs]. aChar == $i ifTrue: [^ self methodHierarchy]. aChar == $h ifTrue: [^ self classHierarchy]. sel ifNotNil: [aChar == $m ifTrue: [^ Smalltalk browseAllImplementorsOf: sel]. aChar == $n ifTrue: [^ Smalltalk browseAllCallsOn: sel]. aChar == $v ifTrue: [^ self browseVersions]. aChar == $O ifTrue: [^ self openSingleMessageBrowser]. aChar == $x ifTrue: [^ self removeMessage]]. ^ self arrowKey: aChar from: view! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 1/13/2000 12:19'! messageListSelectorTitle | selector aString aStamp | Preferences timeStampsInMenuTitles ifFalse: [^ nil]. (selector _ self selectedMessageName) ifNotNil: [aString _ selector truncateWithElipsisTo: 28. ^ (aStamp _ self timeStamp) size > 0 ifTrue: [aString, String cr, aStamp] ifFalse: [aString]]. ^ nil! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 9/21/1999 11:35'! openSingleMessageBrowser | msgName title | "Create and schedule a message list browser populated only by the currently selected message" (msgName _ self selectedMessageName) ifNil: [^ self]. Smalltalk browseMessageList: (Array with: (title _ self selectedClassOrMetaClass name, ' ', msgName)) name: title autoSelect: nil! ! !StringHolder methodsFor: 'message list menu' stamp: 'RAA 12/10/1999 09:36'! packageListKey: aChar from: view "Respond to a Command key in the package pane in the PackageBrowser" aChar == $f ifTrue: [^ self findClass]. ^ self classListKey: aChar from: view ! ! !StringHolder methodsFor: 'message list menu' stamp: 'di 6/17/1998 10:58'! removeFromCurrentChanges "Tell the changes mgr to forget that the current msg was changed." Smalltalk changes removeSelectorChanges: self selectedMessageName class: self selectedClassOrMetaClass.! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 1/28/1999 12:34'! 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 okToChange ifFalse: [^ self]. self revertToPreviousVersion. self removeFromCurrentChanges. self contentsChanged ! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 10/10/1999 22:05'! revertToPreviousVersion "Revert to the previous version of the current method" | aClass aSelector changeRecords | self okToChange ifFalse: [^ self]. aClass _ self selectedClassOrMetaClass. aClass ifNil: [^ self changed: #flash]. aSelector _ self selectedMessageName. changeRecords _ aClass changeRecordsAt: aSelector. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [self changed: #flash. ^ self beep]. changeRecords second fileIn. self contentsChanged ! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 5/4/2000 13:32'! selectMessageAndEvaluate: aBlock "Allow the user to choose one selector, chosen from the currently selected message's selector, as well as those of all messages sent by it, and evaluate aBlock on behalf of chosen selector. If there is only one possible choice, simply make it; if there are multiple choices, put up a menu, and evaluate aBlock on behalf of the the chosen selector, doing nothing if the user declines to choose any" | selector method messages | (selector _ self selectedMessageName) ifNil: [^ self]. method _ self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: []. (method isNil or: [(messages _ method messages) size == 0]) ifTrue: [^ aBlock value: selector]. (messages size == 1 and: [messages includes: selector]) ifTrue: [^ aBlock value: selector]. "If only one item, there is no choice" Smalltalk showMenuOf: messages withFirstItem: selector ifChosenDo: [:sel | aBlock value: sel]! ! !StringHolder methodsFor: 'message list menu' stamp: 'sw 1/26/1999 09:18'! systemCatListKey: aChar from: view "Respond to a Command key. I am a model with a code pane, and I also have a listView that has a list of methods. The view knows how to get the list and selection." aChar == $f ifTrue: [^ self findClass]. ^ self classListKey: aChar from: view! ! !StringHolder methodsFor: 'message list menu' stamp: 'di 4/2/1999 15:54'! timeStamp | selector aMethod | (selector _ self selectedMessageName) ifNotNil: [aMethod _ self selectedClassOrMetaClass compiledMethodAt: selector ifAbsent: [nil]. aMethod ifNotNil: [^ Utilities timeStampForMethod: aMethod]]. ^ String new! ! !StringHolder methodsFor: 'as yet unclassified' stamp: 'sw 9/27/1999 14:10'! showDiffs "For backward compatibility during transition only, lest browsers be unusable for a spell" ^ false ! ! I represent a ParagraphEditor for a single paragraph of text, omitting alignment commands. I provide items in the yellow button menu so that the text selection can be evaluated and so that the contents of the model can be stored or restored. doIt evaluate the text selection as an expression printIt same as doIt but insert a description of the result after the selection accept store the contents of the StringHolder into the model cancel store the contents of the model into the StringHolder! !StringHolderController methodsFor: 'edit flag' stamp: 'di 10/9/1998 15:41'! hasUnacceptedEdits: aBoolean ^ view hasUnacceptedEdits: aBoolean! ! I am a View of a String that is an aspect of a more structured object. This String should not be changed by any editing unless the user issues the accept command. Thus my instances provide a working copy of the String. This copy is edited. When the user issues the accept command, the String is copied from the working version; or if the user issues the cancel command, the working version is restored from the String. StringHolderController is my default controller. It is initialized specially by passing the string viewed which is then converted to a Paragraph for editing.! !StringHolderView methodsFor: 'updating' stamp: 'ar 5/25/2000 19:52'! promptForCancel "Ask if it is OK to cancel changes to text" | okToCancel stripes | self topView isCollapsed ifTrue: [(self confirm: 'Changes have not been saved. Is it OK to cancel those changes?') ifTrue: [model clearUserEditFlag]. ^ self]. stripes _ (Form extent: 16@16 fromStipple: 16r36C9) bits. Display border: self insetDisplayBox width: 4 rule: Form reverse fillColor: stripes. okToCancel _ self confirm: 'Changes have not been saved. Is it OK to cancel those changes?'. Display border: self insetDisplayBox width: 4 rule: Form reverse fillColor: stripes. okToCancel ifTrue: [self updateDisplayContents. model clearUserEditFlag]. ! ! !StringHolderView methodsFor: 'model access' stamp: 'sma 5/28/2000 23:25'! getMenu: shiftKeyState ^ nil! ! !StringHolderView class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'! open: aStringHolder label: labelString "NOTE this should be in the model class, and all senders so redirected, in order that the view class can be discarded in a morphic world." "Create a standard system view of the model, aStringHolder, as viewed by an instance of me. The label of the view is aString." | aStringHolderView topView | Smalltalk isMorphic ifTrue: [^ aStringHolder openAsMorphLabel: labelString]. aStringHolderView _ self container: aStringHolder. topView _ StandardSystemView new. topView model: aStringHolderView model. topView addSubView: aStringHolderView. topView label: labelString. topView minimumSize: 100 @ 50. topView controller open! ! I am a simple, one-line string that displays all characters in a single font. See TextMorph if you need multiple fonts or styles in the same string or multiple lines. ! !StringMorph methodsFor: 'initialization' stamp: 'jm 6/23/2003 09:09'! initWithContents: aString font: aFont emphasis: emphasisCode self initialize. font _ aFont. emphasis _ emphasisCode. self contents: aString. ! ! !StringMorph methodsFor: 'initialization' stamp: 'jm 6/23/2003 09:09'! initialize super initialize. color _ Color black. font _ nil. emphasis _ 0. hasFocus _ false. "self contents: is slow, so initialize it this way:" contents _ 'StringMorph'. self extent: 72@12. "determined empirically; depends on conents and font" ! ! !StringMorph methodsFor: 'accessing' stamp: 'sw 9/17/1999 16:29'! contents: newContents newContents isText ifTrue: [emphasis _ newContents emphasisAt: 1. contents _ newContents string] ifFalse: [contents = newContents ifTrue: [^ self]. "no substantive change" contents _ newContents]. self fitContents. self changed ! ! !StringMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 23:11'! emphasis: emphasisCode emphasis _ emphasisCode. self fitContents. ! ! !StringMorph methodsFor: 'accessing' stamp: 'ar 5/18/2000 18:34'! fitContents | scanner | scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse. self extent: (((scanner stringWidth: contents) max: self minimumWidth) @ scanner lineHeight). self changed! ! !StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:12'! font: aFont ^ self font: aFont emphasis: 0! ! !StringMorph methodsFor: 'accessing' stamp: 'di 4/2/1999 16:11'! font: aFont emphasis: emphasisCode font _ aFont. emphasis _ emphasisCode. self fitContents. " in inspector say, self font: (TextStyle default fontAt: 2) emphasis: 1 "! ! !StringMorph methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:15'! fontToUse | fontToUse | fontToUse _ font == nil ifTrue: [TextStyle defaultFont] ifFalse: [font]. (emphasis == nil or: [emphasis = 0]) ifTrue: [^ fontToUse] ifFalse: [^ fontToUse emphasized: emphasis]! ! !StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:26'! hasFocus ^ hasFocus! ! !StringMorph methodsFor: 'accessing' stamp: 'sw 9/8/1999 11:10'! interimContents: aString "The receiver is under edit and aString represents the string the user sees as she edits, which typically will not have been accepted and indeed may be abandoned" self contents: aString! ! !StringMorph methodsFor: 'accessing' stamp: 'jm 3/15/2003 20:23'! minimumWidth "Answer the minimum width that the receiver can have. A nonzero value here keeps the receiver from degenerating into something that cannot ever be seen or touched again!! Obeyed by fitContents." ^ 5 ! ! !StringMorph methodsFor: 'accessing' stamp: 'sw 12/6/1999 13:16'! setWidth: width self extent: width @ (font ifNil: [TextStyle defaultFont]) height! ! !StringMorph methodsFor: 'drawing' stamp: 'di 9/6/1999 22:43'! drawOn: aCanvas aCanvas text: contents bounds: bounds font: self fontToUse color: color.! ! !StringMorph methodsFor: 'editing' stamp: 'jm 11/1/2002 10:43'! acceptContents "The message is sent when the user hits enter or cmd-S. Accept the current contents and end editing. This default implementation does nothing." ! ! !StringMorph methodsFor: 'editing' stamp: 'sw 9/17/1999 13:27'! cancelEdits self doneWithEdits! ! !StringMorph methodsFor: 'editing' stamp: 'di 9/6/1999 22:44'! doneWithEdits hasFocus _ false! ! !StringMorph methodsFor: 'editing' stamp: 'jm 10/15/2002 17:23'! handlesMouseDown: evt ^ (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick]) ifTrue: [self uncoveredAt: evt cursorPoint] ifFalse: [super handlesMouseDown: evt]. ! ! !StringMorph methodsFor: 'editing' stamp: 'sw 9/7/1999 16:13'! launchMiniEditor: evt | textMorph | hasFocus _ true. "Really only means edit in progress for this morph" textMorph _ StringMorphEditor new contentsAsIs: contents. textMorph beAllFont: self fontToUse. textMorph bounds: (self bounds expandBy: 0@2). self addMorphFront: textMorph. evt hand newMouseFocus: textMorph. evt hand newKeyboardFocus: textMorph. textMorph editor selectFrom: 1 to: textMorph paragraph text string size! ! !StringMorph methodsFor: 'editing' stamp: 'jm 3/15/2003 21:04'! lostFocusWithoutAccepting "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus without having accepted the current edits. In This case, we just accept the edits." self acceptContents. ! ! !StringMorph methodsFor: 'editing' stamp: 'di 9/5/1999 17:25'! mouseDown: evt "If the shift key is pressed, make this string the keyboard input focus." (evt shiftPressed and: [self wantsKeyboardFocusOnShiftClick]) ifTrue: [self launchMiniEditor: evt] ifFalse: [super mouseDown: evt]. ! ! !StringMorph methodsFor: 'editing' stamp: 'jm 10/15/2002 17:22'! wantsKeyboardFocusOnShiftClick ^ owner wantsKeyboardFocusFor: self ! ! !StringMorph methodsFor: 'menu' stamp: 'jm 6/15/2003 23:03'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu addLine. aCustomMenu add: 'set font' action: #fontMenu. aCustomMenu add: 'set font style' action: #emphasisMenu. ! ! !StringMorph methodsFor: 'menu' stamp: 'jm 6/15/2003 23:30'! emphasisMenu | menu bit | menu _ CustomMenu new. #(bold italic underlined narrow 'struck out') with: #(1 2 4 8 16) do: [:label :mask | menu add: 'toggle ', label action: mask]. (bit _ menu startUp) ifNil: [^ self]. emphasis ifNil: [emphasis _ 0]. self emphasis: (emphasis bitXor: bit). ! ! !StringMorph methodsFor: 'menu' stamp: 'jm 6/15/2003 23:16'! fontMenu | menu fName fSize | menu _ CustomMenu new. (StrikeFont familyNames copyWithout: 'DefaultTextStyle') do: [:fn | menu add: fn action: fn]. (fName _ menu startUp) ifNil: [^ self]. menu _ CustomMenu new. (StrikeFont sizesForFamilyName: fName) do: [:sz | menu add: sz printString action: sz]. (fSize _ menu startUp) ifNil: [^ self]. self font: (StrikeFont familyName: fName size: fSize). ! ! !StringMorph methodsFor: 'printing' stamp: 'jm 11/1/2002 10:42'! printOn: aStream super printOn: aStream. aStream nextPutAll: '['''. aStream nextPutAll: (contents copyFrom: 1 to: (contents size min: 10)). contents size > 10 ifTrue: [aStream nextPutAll: '...']. aStream nextPutAll: ''']'. ! ! !StringMorph methodsFor: 'object i/o' stamp: 'jm 10/10/2003 09:40'! closeEditor "Be sure that any StringMorphEditors on me have been removed." self doneWithEdits. submorphs size = 0 ifTrue: [^ self]. submorphs copy do: [:m | (m isKindOf: StringMorphEditor) ifTrue: [m delete]]. ! ! !StringMorph class methodsFor: 'instance creation' stamp: 'jm 6/23/2003 09:16'! contents: aString "Create an instance of me with the given contents." ^ self basicNew initWithContents: aString font: nil emphasis: 0 ! ! !StringMorph class methodsFor: 'instance creation' stamp: 'jm 6/23/2003 09:16'! contents: aString font: aFont "Create an instance of me with the given contents and font." ^ self basicNew initWithContents: aString font: aFont emphasis: 0 ! ! !StringMorph class methodsFor: 'instance creation' stamp: 'jm 6/23/2003 09:15'! contents: aString font: aFont emphasis: emphasisCode "Create an instance of me with the given contents, font, and emphasis." ^ self basicNew initWithContents: aString font: aFont emphasis: emphasisCode ! ! !StringMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:03'! includeInNewMorphMenu ^ true ! ! !StringMorph class methodsFor: 'testing' stamp: 'jm 6/15/2003 10:35'! test2 "Return a morph with lots of strings for testing display speed." "StringMorph test2 openInWorld" | c r | c _ AlignmentMorph newColumn. SystemOrganization categories do: [:cat | c addMorphBack: (StringMorph new contents: cat)]. r _ BorderedMorph new extent: c fullBounds extent. r color: Color white. c submorphsDo: [:m | r addMorph: m]. ^ r ! ! I am a textMorph used as a pop-up editor for StringMorphs. I present a yellow background and I go away when a CR is typed or when the user clicks elsewhere.! !StringMorphEditor methodsFor: 'all' stamp: 'LY 7/3/2003 11:25'! drawOn: aCanvas "aCanvas frameRectangle: self bounds width: 3 color: Color yellow." aCanvas fillRectangle: self bounds color: (Color r: 0.6 g: 0.0 b: 0.8 alpha: 0.3). ^ super drawOn: aCanvas! ! !StringMorphEditor methodsFor: 'all' stamp: 'di 5/15/2000 16:33'! keyStroke: evt "This is hugely inefficient, but it seems to work, and it's unlikely it will ever need to be any more efficient -- it's only intended to edit single-line strings." | char priorEditor oldSel newSel | (((char _ evt keyCharacter) = Character enter) or: [(char = Character cr) or: [char = $s and: [evt commandKeyPressed]]]) ifTrue: [owner acceptContents; doneWithEdits. evt hand newKeyboardFocus: nil. ^ self delete]. (char = $l and: [evt commandKeyPressed]) ifTrue: "cancel" [owner cancelEdits. evt hand newKeyboardFocus: nil. ^ self delete]. oldSel _ self editor selectionInterval. super keyStroke: evt. owner interimContents: self contents asString. newSel _ self editor selectionInterval. priorEditor _ self editor. "Save editor state" self releaseParagraph. "Release paragraph so it will grow with selection." self paragraph. "Re-instantiate to set new bounds" self installEditorToReplace: priorEditor. "restore editor state" oldSel = newSel ifTrue: ["There is a bug that causes characters to be misplaced when the second character typed is wider than the first. This fixes it (ugh)." self editor selectFrom: newSel first + 1 to: newSel last + 1]. ! ! !StringMorphEditor methodsFor: 'all' stamp: 'jm 10/10/2003 09:36'! keyboardFocusChange: aBoolean | hadFocus | hadFocus _ owner ifNil: [false] ifNotNil: [owner hasFocus]. super keyboardFocusChange: aBoolean. aBoolean ifFalse: [ hadFocus ifTrue: [ owner lostFocusWithoutAccepting; doneWithEdits]. self delete]. ! ! I encode monophonic sampled sounds in Sun audio (.au) file format. Sun audio files have a very simple format but can store both compressed and uncompressed sample data. I can write this format either directly into a file or onto any writable binary stream. ! !SunAudioFileWriter methodsFor: 'initialization' stamp: 'jm 11/16/2001 17:51'! setStream: aBinaryStream "Initialize myself for writing on the given stream." stream _ aBinaryStream. headerStart _ aBinaryStream position. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 18:02'! appendBytes: aByteArray "Append the given sample data to my stream." stream nextPutAll: aByteArray. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 22:53'! appendSamples: aSoundBuffer "Append the given SoundBuffer to my stream." | swapBytes s | (stream isKindOf: StandardFileStream) ifTrue: [ "optimization: write sound buffer directly to file" swapBytes _ Smalltalk endianness == #little. swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "make big endian" stream next: (aSoundBuffer size // 2) putAll: aSoundBuffer startingAt: 1. "size in words" swapBytes ifTrue: [aSoundBuffer reverseEndianness]. "revert to little endian" ^ self]. "for non-file streams:" s _ WriteStream on: (ByteArray new: 2 * aSoundBuffer monoSampleCount). 1 to: aSoundBuffer monoSampleCount do: [:i | s int16: (aSoundBuffer at: i)]. self appendBytes: s contents. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 22:09'! closeFile "Update the Sun audio file header to reflect the final size of the sound data. If my stream is a file stream, close it and, on a Macintosh, set the file type and creator to that used by SoundApp for Sun Audio files. (This does nothing on other platforms.)" self ensureOpen. self updateHeaderDataSize. (stream isKindOf: StandardFileStream) ifTrue: [ stream close. FileDirectory default setMacFileNamed: stream name type: 'ULAW' creator: 'SCPL']. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 18:28'! ensureOpen "Ensure that my stream is open." (stream respondsTo: #closed) ifFalse: [^ self]. stream closed ifTrue: [stream reopen; binary]. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 17:55'! updateHeaderDataSize "Update the Sun audio file header to reflect the final size of the sound data." | byteCount | byteCount _ stream position - (headerStart + 24). stream position: headerStart + 8. stream uint32: byteCount. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 17:55'! writeHeaderSamplingRate: samplingRate "Write a Sun audio file header for 16-bit linear format." self writeHeaderSamplingRate: samplingRate format: 3. ! ! !SunAudioFileWriter methodsFor: 'other' stamp: 'jm 11/16/2001 22:10'! writeHeaderSamplingRate: samplingRate format: audioFormat "Write a Sun audio file header for the given sampling rate and format. Currently, only monophonic files are supported." self ensureOpen. stream position: headerStart. stream nextPutAll: '.snd' asByteArray. stream uint32: 24. "header size in bytes" stream uint32: 0. "sample data size in bytes; fill in later" stream uint32: audioFormat. stream uint32: samplingRate truncated. stream uint32: 1. "channel count" ! ! !SunAudioFileWriter class methodsFor: 'instance creation' stamp: 'jm 11/16/2001 17:49'! onFileNamed: fileName "Answer an instance of me on a newly created file with the given name." | file | file _ (FileStream newFileNamed: fileName) binary. ^ self new setStream: file ! ! !SunAudioFileWriter class methodsFor: 'instance creation' stamp: 'jm 11/16/2001 17:50'! onStream: aBinaryStream "Answer an instance of me on the given binary stream." ^ self new setStream: aBinaryStream ! ! !SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'jm 11/21/2001 15:42'! codecForFormatCode: formatCode "Answer the codec for the given Sun audio file format number." formatCode = 1 ifTrue: [^ MuLawCodec new]. formatCode = 3 ifTrue: [^ nil]. "uncompressed" formatCode = 23 ifTrue: [^ ADPCMCodec newBitsPerSample: 4]. formatCode = 25 ifTrue: [^ ADPCMCodec newBitsPerSample: 3]. formatCode = 26 ifTrue: [^ ADPCMCodec newBitsPerSample: 5]. formatCode = 610 ifTrue: [^ GSMCodec new]. self error: 'unsupported Sun audio format' ! ! !SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'jm 11/21/2001 15:42'! formatCodeForCompressionType: aString "Answer the Sun audio file format number for the given compression type name." | lowercase | lowercase _ aString asLowercase. 'mulaw' = lowercase ifTrue: [^ 1]. 'none' = lowercase ifTrue: [^ 3]. 'adpcm3' = lowercase ifTrue: [^ 25]. 'adpcm4' = lowercase ifTrue: [^ 23]. 'adpcm5' = lowercase ifTrue: [^ 26]. 'gsm' = lowercase ifTrue: [^ 610]. self error: 'unknown compression style' ! ! !SunAudioFileWriter class methodsFor: 'sound storing' stamp: 'jm 12/16/2001 21:37'! storeSampledSound: aSampledSound onFileNamed: fileName compressionType: aString "Store the samples of the given sampled sound on a file with the given name using the given type of compression. See formatCodeForCompressionType: for the list of compression types." | fmt codec f compressed | fmt _ self formatCodeForCompressionType: aString. codec _ self codecForFormatCode: fmt. f _ self onFileNamed: fileName. f writeHeaderSamplingRate: aSampledSound originalSamplingRate format: fmt. codec ifNil: [f appendSamples: aSampledSound samples] ifNotNil: [ compressed _ codec encodeSoundBuffer: aSampledSound samples. f appendBytes: compressed]. f closeFile. ! ! I represent a selection setting and actions to take depending on a change in the setting. An instance has three attributes: state, which is either on or off; on action; and off action. The on and off actions are blocks of code that execute whenever the instance changes state. I am typically used as a menu item in conjunction with a SwitchView and a SwitchController. 1/24/96 sw: made this a subclass of Model, for faster dependents handling! I represent Strings that are created uniquely. Thus, someString asSymbol == someString asSymbol.! !Symbol methodsFor: 'accessing' stamp: 'sma 2/5/2000 12:32'! precedence "Answer the receiver's precedence, assuming it is a valid Smalltalk message selector or 0 otherwise. The numbers are 1 for unary, 2 for binary and 3 for keyword selectors." self size = 0 ifTrue: [^ 0]. self first isLetter ifFalse: [^ 2]. self last = $: ifTrue: [^ 3]. ^ 1! ! !Symbol methodsFor: 'comparing' stamp: 'di 4/11/2000 16:18'! = another "Use == between two symbols..." self == another ifTrue: [^ true]. "Was == " another class == Symbol ifTrue: [^ false]. "Was not == " "Otherwise use string =..." ^ super = another! ! !Symbol methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'! clone "Answer with the receiver, because Symbols are unique."! ! !Symbol methodsFor: 'printing' stamp: 'di 4/25/2000 12:32'! storeOn: aStream aStream nextPut: $#. (Scanner isLiteralSymbol: self) ifTrue: [aStream nextPutAll: self] ifFalse: [super storeOn: aStream]! ! !Symbol methodsFor: 'system primitives' stamp: 'di 1/2/1999 17:00'! flushCache "Tell the interpreter to remove all entries with this symbol as a selector from its method lookup cache, if it has one. This primitive must be called whenever a method is defined or removed. NOTE: Only one of the two selective flush methods needs to be used. Squeak 2.3 and later uses 116 (See CompiledMethod flushCache)." <primitive: 119> ! ! !Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:32'! isInfix "Answer whether the receiver is an infix message selector." ^ self precedence == 2! ! !Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'! isKeyword "Answer whether the receiver is a message keyword." ^ self precedence == 3! ! !Symbol methodsFor: 'testing' stamp: 'di 4/25/2000 12:32'! isLiteral "Answer whether the receiver is a valid Smalltalk literal." ^ true! ! !Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:13'! isPvtSelector "Answer whether the receiver is a private message selector, that is, begins with 'pvt' followed by an uppercase letter, e.g. pvtStringhash." ^ (self beginsWith: 'pvt') and: [self size >= 4 and: [(self at: 4) isUppercase]]! ! !Symbol methodsFor: 'testing' stamp: 'sma 2/5/2000 12:34'! isUnary "Answer whether the receiver is an unary message selector." ^ self precedence == 1! ! !Symbol class methodsFor: 'instance creation' stamp: 'sma 2/26/2000 20:17'! intern: aString "Answer a unique Symbol whose characters are those of aString." | ascii table mainTable index sym numArgs symbol lastNilIndex | aString size = 0 ifTrue: [ascii _ 0] ifFalse: [ascii _ (aString at: 1) asciiValue. aString size = 1 ifTrue: [ascii < 128 ifTrue: [^ SingleCharSymbols at: ascii + 1]]]. table _ ((ascii >= "$a asciiValue" 97) and: [(ascii <= "$z asciiValue" 122) and: [(numArgs _ aString numArgs) >= 0]]) ifTrue: [(mainTable _ SelectorTables at: (numArgs + 1 min: SelectorTables size)) at: (index _ ascii - "($a asciiValue - 1)" 96)] ifFalse: [(mainTable _ OtherTable) at: (index _ aString stringhash \\ OtherTable size + 1)]. 1 to: table size do: [:i | symbol _ table at: i. symbol isNil ifTrue:[lastNilIndex _ i] ifFalse:[(aString size = symbol size and:[aString = symbol]) ifTrue:[^symbol]] ]. sym _ (aString isMemberOf: Symbol) ifTrue: [aString] "putting old symbol in new table" ifFalse: [(Symbol new: aString size) string: aString]. "create a new one" lastNilIndex isNil ifTrue:[mainTable at: index put: (table copyWith: sym)] ifFalse:[table at: lastNilIndex put: sym]. ^sym ! ! !Symbol class methodsFor: 'instance creation' stamp: 'di 10/11/1999 00:02'! readFrom: strm "Symbol readFromString: '#abc'" strm peek = $# ifFalse: [self error: 'Symbols must be introduced by #']. ^ (Scanner new scan: strm) advance "Just do what the code scanner does"! ! !Symbol class methodsFor: 'instance creation' stamp: 'jm 5/24/2003 13:59'! rehash "Rebuild the hash table, reclaiming unreferenced Symbols." "Symbol rehash" | count oldCount | SelectorTables _ (1 to: 6) collect: [:i | (1 to: 26) collect: [:j | Array new: 0]]. OtherTable _ (1 to: 51) collect: [:i | Array new: 0]. oldCount _ Symbol instanceCount. count _ 0. 'Rebuilding Symbol Tables...' displayProgressAt: Sensor cursorPoint from: 0 to: oldCount during: [:bar | Smalltalk garbageCollect. Symbol allInstancesDo: [:sym | self intern: sym. bar value: (count _ count + 1)]]. ^ (oldCount - count) printString, ' reclaimed' ! ! !Symbol class methodsFor: 'private' stamp: 'ar 5/1/1999 04:56'! hasInterned: aString ifTrue: symBlock "Answer with false if aString hasnt been interned (into a Symbol), otherwise supply the symbol to symBlock and return true." | table ascii numArgs symbol | ascii _ (aString at: 1) asciiValue. aString size = 1 ifTrue: [ascii < 128 ifTrue: [symBlock value: (SingleCharSymbols at: ascii + 1). ^true]]. table _ ((ascii >= "$a asciiValue" 97) and: [(ascii <= "$z asciiValue" 122) and: [(numArgs _ aString numArgs) >= 0]]) ifTrue: [(SelectorTables at: (numArgs + 1 min: SelectorTables size)) at: ascii - "($a asciiValue - 1)" 96] ifFalse: [OtherTable at: aString stringhash \\ OtherTable size + 1]. 1 to: table size do: [:i | symbol _ table at: i. (symbol notNil and:[aString size = symbol size and: [aString = symbol]]) ifTrue: [ symBlock value: symbol. ^true] ]. ^false! ! !Symbol class methodsFor: 'access' stamp: 'tk 2/11/2000 21:16'! otherThatStarts: leadingCharacters skipping: skipSym "Answer a selector symbol with leadingCharacters that starts with an uppercase letter. Ignore case in aKeyword. If skipSym is not nil, it is a previous answer; start searching after it. If no symbols are found, answer nil. Used by Alt-q (Command-q) routines." | key size table candidate ii skip | key _ leadingCharacters asLowercase. size _ key size. skip _ skipSym ~~ nil. (1 to: OtherTable size) do: [:jj | table _ OtherTable at: jj. 1 to: table size do: [:tt | ((candidate _ table at: tt) == nil or: [skip and: [skip _ candidate ~~ skipSym. true]]) ifFalse: [candidate size >= size ifTrue: [ii _ size. "test last character first" [ii > 0 and: [(candidate at: ii) asLowercase == (key at: ii)]] whileTrue: [ii _ ii - 1]. ii = 0 ifTrue: [^candidate]]]]]. ^nil "Symbol otherThatStarts: 'morph' skipping: nil" "Symbol otherThatStarts: 'morph' skipping: #'Morphic-Support'" "Symbol otherThatStarts: 'rect' skipping: #'rectangle functions'" ! ! !Symbol class methodsFor: 'access' stamp: 'tk 8/11/1998 22:12'! possibleSelectorsFor: misspelled "Answer an ordered collection of possible corrections for the misspelled selector in order of likelyhood." | numArgs table lookupString list binary | lookupString _ misspelled asLowercase. "correct uppercase selectors to lowercase" numArgs _ lookupString numArgs. numArgs < 0 ifTrue: [ ^ OrderedCollection new: 0 ]. table _ (SelectorTables at: (numArgs + 1 min: SelectorTables size)) at: (lookupString at: 1) asciiValue - "($a asciiValue - 1)" 96. list _ lookupString correctAgainst: table. ((misspelled last ~~ $:) and: [misspelled size > 1]) ifTrue: [ binary _ misspelled, ':'. "try for missing colon" Symbol hasInterned: binary ifTrue: [:him | list addFirst: him]]. ^ list! ! !Symbol class methodsFor: 'access' stamp: 'bf 10/13/1999 09:57'! selectorsContaining: aString "Answer a list of selectors that contain aString within them. Case-insensitive." | size table candidate selectorList selectorTable ascii | selectorList _ OrderedCollection new. (size _ aString size) = 0 ifTrue: [^ selectorList]. aString size = 1 ifTrue: [ascii _ aString first asciiValue. ascii < 128 ifTrue: [selectorList add: (SingleCharSymbols at: ascii + 1)]]. aString first isLetter ifFalse: [ aString size == 2 ifTrue: [Symbol hasInterned: aString ifTrue: [:s | selectorList add: s]]. ^ selectorList]. (SelectorTables size to: 1 by: -1) do: [:j | selectorTable _ SelectorTables at: j. 1 to: 26 do: [:index | table _ selectorTable at: index. 1 to: table size do: [:t | ((candidate _ table at: t) == nil) ifFalse: [candidate size >= size ifTrue: [((candidate findString: aString startingAt: 1 caseSensitive: false) > 0) ifTrue: [selectorList add: candidate]]]]]]. ^ selectorList "Symbol selectorsContaining: 'scon' "! ! !Symbol class methodsFor: 'access' stamp: 'tk 2/11/2000 21:30'! thatStarts: leadingCharacters skipping: skipSym "Answer a selector symbol that starts with leadingCharacters. Symbols beginning with a lower-case letter handled directly here. Ignore case after first char. If skipSym is not nil, it is a previous answer; start searching after it. If no symbols are found, answer nil. Used by Alt-q (Command-q) routines." | key size index table candidate i skip firstTable | key _ leadingCharacters asLowercase. index _ key first asciiValue - "($a asciiValue - 1)" 96. ((index >= 1) and: [(index <= 26) and: [leadingCharacters numArgs >= 0]]) ifFalse: [^ self otherThatStarts: leadingCharacters skipping: skipSym]. size _ key size. skip _ skipSym ~~ nil. firstTable _ skip ifTrue: [skipSym numArgs + 1 min: SelectorTables size] "can't be in a later table" ifFalse: [SelectorTables size]. "could be in any table; favor longer identifiers" (firstTable to: 1 by: -1) do: [:j | table _ (SelectorTables at: j) at: index. 1 to: table size do: [:t | ((candidate _ table at: t) == nil or: [skip and: [skip _ candidate ~~ skipSym. true]]) ifFalse: [candidate size >= size ifTrue: [i _ size. "test last character first" [i > 1 and: [(candidate at: i) asLowercase == (key at: i)]] whileTrue: [i _ i - 1]. i = 1 ifTrue: "don't need to compare first character" [^candidate]]]]]. ^nil "Symbol thatStarts: 'sf' skipping: nil" "Symbol thatStarts: 'sf' skipping: #sfpGetFile:with:with:with:with:with:with:with:with:" "Symbol thatStarts: 'candidate' skipping: nil" ! ! Represents a color and possibly a style attribute to be applied to a syntactic element for pretty-printing. The attributeList inst var is a cache.! !SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/17/1999 15:04'! attributeList "Answer a list of text attributes that characterize the receiver" attributeList ifNil: [attributeList _ OrderedCollection new: 2. color ifNotNil: [attributeList add: (TextColor color: color)]. emphasis ifNotNil: [attributeList add: (TextEmphasis perform: emphasis)]]. ^ attributeList! ! !SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'! color ^ color! ! !SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:21'! color: aTextColor color _ aTextColor. attributeList _ nil! ! !SyntaxAttribute methodsFor: 'accessing' stamp: 'djp 11/7/1999 14:52'! emphasis ^ emphasis! ! !SyntaxAttribute methodsFor: 'accessing' stamp: 'sw 11/16/1999 16:22'! emphasis: aTextEmphasis emphasis _ aTextEmphasis. attributeList _ nil! ! !SyntaxAttribute class methodsFor: 'as yet unclassified' stamp: 'sw 11/16/1999 12:01'! color: aColor emphasis: anEmphasis ^ self new color: aColor; emphasis: anEmphasis; yourself! ! !SyntaxError methodsFor: 'initialization' stamp: 'tk 5/6/1999 13:28'! setClass: aClass code: aString debugger: aDebugger doitFlag: flag | types printables badChar | class _ aClass. debugger _ aDebugger. selector _ aClass parserClass new parseSelector: aString. types _ Scanner classPool at: #TypeTable. "dictionary" printables _ '!!@#$%&*-_=+<>{}?/\,¥£¢¤¦»¼ÐÑÒÔÓÕÉò¾òøùÀÇÈ`~`' asSet. badChar _ aString detect: [:aChar | (types at: aChar asciiValue) == #xBinary and: [ (printables includes: aChar) not]] ifNone: [nil]. contents _ badChar ifNil: [aString] ifNotNil: ['<<<This string contains a character (ascii value ', badChar asciiValue printString, ') that is not normally used in code>>> ', aString]. category ifNil: [category _ aClass organization categoryOfElement: selector]. category ifNil: [category _ ClassOrganizer default]. doitFlag _ flag! ! !SyntaxError methodsFor: 'message list' stamp: 'tk 4/19/1999 08:08'! list "Answer an array of one element made up of the class name, message category, and message selector in which the syntax error was found. This is the single item in the message list of a view/browser on the receiver." selector ifNil: [^ Array with: (class name, ' ', category, ' ', '<none>')]. ^ Array with: (class name, ' ', category, ' ', selector) ! ! !SyntaxError methodsFor: 'other' stamp: 'di 10/9/1998 16:36'! contents: aString notifying: aController "Compile the code in aString and notify aController of any errors. If there are no errors, then automatically proceed." doitFlag ifTrue: [Compiler new evaluate: aString in: nil to: nil notifying: aController ifFail: [^ false]] ifFalse: [(class compile: aString classified: category notifying: aController) ifNil: [^ false]]. aController hasUnacceptedEdits: false. self proceed! ! !SyntaxError methodsFor: 'other' stamp: 'di 10/9/1998 16:51'! notify: error at: location in: source "Open a syntax error view, inserting the given error message into the given source at the given location. This message is sent to the 'requestor' when the parser or compiler finds a syntax error." | aClass aString | aClass _ thisContext sender receiver encoder classEncoding. aString _ source contents copyReplaceFrom: location to: location - 1 with: error. self setClass: aClass code: aString debugger: (Debugger context: thisContext) doitFlag: false. self class open: self. ! ! !SyntaxError class methodsFor: 'instance creation' stamp: 'di 8/17/1998 10:22'! buildMorphicViewOn: aSyntaxError "Answer an Morphic view on the given SyntaxError." | window | window _ (SystemWindow labelled: 'Syntax Error') model: aSyntaxError. window addMorph: (PluggableListMorph on: aSyntaxError list: #list selected: #listIndex changeSelected: nil menu: #listMenu:) frame: (0@0 corner: 1@0.15). window addMorph: (PluggableTextMorph on: aSyntaxError text: #contents accept: #contents:notifying: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (0@0.15 corner: 1@1). ^ window openInWorldExtent: 380@220! ! !SyntaxError class methodsFor: 'instance creation' stamp: 'di 10/9/1998 16:18'! errorInClass: aClass withCode: codeString doitFlag: doit "Open a view whose model is a syntax error. The error occurred when trying to add the given method code to the given class." self open: (self new setClass: aClass code: codeString debugger: (Debugger context: thisContext) doitFlag: doit). ! ! !SyntaxError class methodsFor: 'instance creation' stamp: 'sma 4/30/2000 10:15'! open: aSyntaxError "Answer a standard system view whose model is an instance of me." | topView | <primitive: 19> "Simulation guard" Smalltalk isMorphic ifTrue: [self buildMorphicViewOn: aSyntaxError. Project current spawnNewProcessIfThisIsUI: Processor activeProcess. ^ Processor activeProcess suspend]. topView _ self buildMVCViewOn: aSyntaxError. topView controller openNoTerminateDisplayAt: Display extent // 2. Cursor normal show. Processor activeProcess suspend. ! ! I represent a special dictionary that supports protocol for asking questions about the structure of the system. Other than class names, I contain (print this)... Smalltalk keys select: [:k | ((Smalltalk at: k) isKindOf: Class) not] thenCollect: [:k | k -> (Smalltalk at: k) class] ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 12:42'! associationAtOrAbove: varName ifAbsent: absentBlock "Compatibility with environment protocol." ^ self associationAt: varName ifAbsent: absentBlock! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/21/1999 12:00'! atOrAbove: key ifAbsent: absentBlock "Compatibility with environment protocol." ^ self at: key ifAbsent: absentBlock! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 13:43'! atOrBelow: key ifAbsent: absentBlock "Compatibility with environment protocol." ^ self at: key ifAbsent: absentBlock! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/6/1999 20:36'! environmentForCategory: catName "Default response for non-partitioned systems" ^ Smalltalk! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/21/1999 12:00'! includesKeyOrAbove: key "Compatibility with environment protocol." self atOrAbove: key ifAbsent: [^ false]. ^ true! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 2/16/2000 13:40'! kernelCategories ^ #(Kernel Collections Graphics System)! ! !SystemDictionary methodsFor: 'dictionary access' stamp: 'di 12/19/1999 21:17'! scopeFor: varName from: lower envtAndPathIfFound: envtAndPathBlock "Null compatibility with partitioning into environments." (self includesKey: varName) ifTrue: [^ envtAndPathBlock value: self value: String new] ifFalse: [^ nil]! ! !SystemDictionary methodsFor: 'browsing' stamp: 'di 5/4/1999 13:52'! browseAllObjectReferencesTo: anObject except: objectsToExclude ifNone: aBlock "Bring up a list inspector on the objects that point to anObject. If there are none, then evaluate aBlock on anObject. " | aList shortName | aList _ Smalltalk pointersTo: anObject except: objectsToExclude. aList size > 0 ifFalse: [^ aBlock value: anObject]. shortName _ (anObject name ifNil: [anObject printString]) contractTo: 20. OrderedCollectionInspector openOn: aList withEvalPane: false withLabel: 'Objects pointing to ', shortName.! ! !SystemDictionary methodsFor: 'browsing' stamp: 'sw 8/5/1998 18:41'! browseChangedMessages "Create and schedule a message browser on each method that has been changed." SystemChanges isEmpty ifTrue: [^ self inform: 'There are no changed messages in the current change set.']. ChangedMessageSet openFor: SystemChanges! ! !SystemDictionary methodsFor: 'browsing' stamp: 'sw 9/21/1999 11:38'! browseMessageList: messageList name: labelString autoSelect: autoSelectString | title aSize | "Create and schedule a MessageSet browser on the message list." messageList size = 0 ifTrue: [^ (PopUpMenu labels: ' OK ') startUpWithCaption: 'There are no ' , labelString]. title _ (aSize _ messageList size) > 1 ifFalse: [labelString] ifTrue: [ labelString, ' [', aSize printString, ']']. MessageSet openMessageList: messageList name: title autoSelect: autoSelectString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'di 11/23/1998 12:05'! browseMethodsWithSourceString: aString "Smalltalk browseMethodsWithSourceString: 'SourceString' " "Launch a browser on all methods whose source code contains aString as a substring." | caseSensitive suffix | (caseSensitive _ Sensor shiftPressed) ifTrue: [suffix _ ' (case-sensitive)'] ifFalse: [suffix _ ' (use shift for case-sensitive)']. ^ self browseMessageList: (self allMethodsWithSourceString: aString matchCase: caseSensitive) name: 'Methods containing ' , aString printString , suffix autoSelect: aString! ! !SystemDictionary methodsFor: 'browsing' stamp: 'di 11/23/1998 12:05'! browseMethodsWithString: aString "Launch a browser on all methods that contain string literals with aString as a substring. The search is case-insensitive, unless the shift key is pressed, in which case the search is case-sensitive." | caseSensitive suffix | (caseSensitive _ Sensor shiftPressed) ifTrue: [suffix _ ' (case-sensitive)'] ifFalse: [suffix _ ' (use shift for case-sensitive)']. self browseAllSelect: [:method | method hasLiteralSuchThat: [:lit | lit class == String and: [lit includesSubstring: aString caseSensitive: caseSensitive]]] name: 'Methods with string ', aString printString, suffix autoSelect: aString. ! ! !SystemDictionary methodsFor: 'browsing' stamp: 'tk 6/24/1999 11:28'! browseObsoleteReferences "Smalltalk browseObsoleteReferences" | references | references _ OrderedCollection new. (Association allSubInstances select: [:x | ((x value isKindOf: Behavior) and: ['AnOb*' match: x value name]) or: ['AnOb*' match: x value class name]]) do: [:x | references addAll: (Smalltalk allCallsOn: x)]. Smalltalk browseMessageList: references name: 'References to Obsolete Classes'! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'jm 5/18/2003 15:03'! allBehaviorsDo: aBlock "Evaluate the argument, aBlock, for each kind of Behavior in the system (that is, Object and its subclasses)." "ar 7/15/1999: The code below will not enumerate any obsolete or anonymous behaviors for which the following can be executed: Smalltalk allObjectsDo: [:obj | obj isBehavior ifTrue: [aBlock value: obj]]. but what follows is way faster than enumerating all objects." aBlock value: Object. Object allSubclassesDo: aBlock. "Classes outside the Object hierarchy" Class subclassesDo: [:aClass | false & aClass isMeta ifTrue: [ "Enumerate the non-meta class and its subclasses" aBlock value: aClass soleInstance. aClass soleInstance allSubclassesDo: aBlock]]. ! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'! allCallsOn: aLiteral "Smalltalk browseAllCallsOn: #open:label:." "Answer a Collection of all the methods that call on aLiteral." | aCollection special thorough aList byte | #(23 48 'fred' (new open:label:)) size. "Example above should find #open:label:, though it is deeply embedded here." aCollection _ OrderedCollection new. special _ self hasSpecialSelector: aLiteral ifTrueSetByte: [:b | byte _ b ]. thorough _ (aLiteral isMemberOf: Symbol) and: ["Possibly search for symbols imbedded in literal arrays" Preferences thoroughSenders]. Cursor wait showWhile: [self allBehaviorsDo: [:class | aList _ thorough ifTrue: [(class thoroughWhichSelectorsReferTo: aLiteral special: special byte: byte)] ifFalse: [class whichSelectorsReferTo: aLiteral special: special byte: byte]. aList do: [:sel | sel ~~ #DoIt ifTrue: [aCollection add: class name , ' ' , sel]]]]. ^ aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'ls 10/10/1999 13:22'! allCallsOn: firstLiteral and: secondLiteral "Answer a SortedCollection of all the methods that call on both aLiteral and secondLiteral." | aCollection secondArray firstSpecial secondSpecial firstByte secondByte | aCollection _ SortedCollection new. firstSpecial _ self hasSpecialSelector: firstLiteral ifTrueSetByte: [:b | firstByte _ b]. secondSpecial _ self hasSpecialSelector: secondLiteral ifTrueSetByte: [:b | secondByte _ b]. Cursor wait showWhile: [self allBehaviorsDo: [:class | secondArray _ class whichSelectorsReferTo: secondLiteral special: secondSpecial byte: secondByte. ((class whichSelectorsReferTo: firstLiteral special: firstSpecial byte: firstByte) select: [:aSel | (secondArray includes: aSel)]) do: [:sel | aCollection add: class name , ' ' , sel]]]. ^aCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'bf 9/22/1999 16:56'! allImplementedMessages "Answer a Set of all the messages that are sent by a method in the system but are not implemented." | aSet | aSet _ IdentitySet new: Symbol instanceCount. Cursor wait showWhile: [self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | aSet add: aSelector]]]. ^aSet! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 11/23/1998 12:02'! allMethodsWithSourceString: aString matchCase: caseSensitive "Answer a SortedCollection of all the methods that contain, in source code, aString as a substring. The search is case-insensitive." | list classCount | list _ Set new. 'Searching all source code...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). (Array with: class with: class class) do: [:cl | cl selectorsDo: [:sel | ((cl sourceCodeAt: sel) findString: aString startingAt: 1 caseSensitive: caseSensitive) > 0 ifTrue: [sel == #DoIt ifFalse: [list add: cl name , ' ' , sel]]]]]]. ^ list asSortedCollection! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'bf 9/22/1999 16:39'! allSentMessages "Answer the set of selectors which are sent somewhere in the system." | sent | sent _ IdentitySet new: CompiledMethod instanceCount. Cursor execute showWhile: [self allBehaviorsDo: [:cl | cl selectorsDo: [:sel | "Include all sels, but not if sent by self" (cl compiledMethodAt: sel) literals do: [:m | (m isMemberOf: Symbol) ifTrue: "might be sent" [m == sel ifFalse: [sent add: m]]. (m isMemberOf: Array) ifTrue: "might be performed" [m do: [:x | (x isMemberOf: Symbol) ifTrue: [x == sel ifFalse: [sent add: x]]]]]]]. "The following may be sent without being in any literal frame" 1 to: self specialSelectorSize do: [:index | sent add: (self specialSelectorAt: index)]]. ^ sent! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'di 12/15/1998 21:47'! allUnSentMessagesIn: selectorSet "Answer the subset of selectorSet which are not sent anywhere in the system. Factored out from#allUnSentMessages " | all | all _ selectorSet copy. Cursor execute showWhile: [self allBehaviorsDo: [:cl | cl selectorsDo: [:sel | (cl compiledMethodAt: sel) literals do: [:lit | (lit isMemberOf: Symbol) "might be sent" ifTrue: [all remove: lit ifAbsent: []]. (lit isMemberOf: Array) "might be performed" ifTrue: [lit do: [:elt | (elt isMemberOf: Array) ifTrue: [elt do: [:e | all remove: e ifAbsent: []]] ifFalse: [all remove: elt ifAbsent: []]]]. ]]]. "The following may be sent without being in any literal frame" 1 to: self specialSelectorSize do: [:index | all remove: (self specialSelectorAt: index) ifAbsent: []]]. ^ all! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'jm 5/16/2003 10:01'! pointersTo: anObject except: objectsToExclude "Find all occurrences in the system of pointers to the argument anObject. Remove objects in the exclusion list from the results." | results anObj | Smalltalk garbageCollect. "big collection shouldn't grow, so it's contents array is always the same" results _ OrderedCollection new: 1000. "allObjectsDo: is expanded inline to keep spurious method and block contexts out of the results" anObj _ self someObject. [0 == anObj] whileFalse: [ (anObj pointsTo: anObject) ifTrue: [ "exclude the results collector and contexts in call chain" ((anObj ~~ results collector) and: [(anObj ~~ objectsToExclude) and: [(anObj ~~ thisContext) and: [(anObj ~~ thisContext sender) and: [anObj ~~ thisContext sender sender]]]]) ifTrue: [results add: anObj]]. anObj _ anObj nextObject]. objectsToExclude do: [:obj | results removeAllSuchThat: [:el | el == obj]]. ^ results asArray ! ! !SystemDictionary methodsFor: 'retrieving' stamp: 'jm 10/31/2002 10:43'! unimplemented "Answer an Array of each message that is sent by an expression in a method but is not implemented by any object in the system." | all unimplemented entry | all _ IdentitySet new: Symbol instanceCount * 2. Cursor wait showWhile: [self allBehaviorsDo: [:cl | cl selectorsDo: [:aSelector | all add: aSelector]]]. unimplemented _ IdentityDictionary new. Cursor execute showWhile: [ self allBehaviorsDo: [:cl | cl selectorsDo: [:sel | (cl compiledMethodAt: sel) messages do: [:m | (all includes: m) ifFalse: [ entry _ unimplemented at: m ifAbsent: [Array new]. entry _ entry copyWith: (cl name, '>', sel). unimplemented at: m put: entry]]]]]. "remove some clutter from the results:" #(DoItIn: primitiveFail uniformWindowColors macOptionKeyAllowed) do: [:sel | unimplemented removeKey: sel ifAbsent: []]. ^ unimplemented ! ! !SystemDictionary methodsFor: 'class names' stamp: 'di 3/26/2000 09:06'! classNamed: className "className is either a class name or a class name followed by ' class'. Answer the class or metaclass it names" | meta baseName baseClass | (className endsWith: ' class') ifTrue: [meta _ true. baseName _ className copyFrom: 1 to: className size - 6] ifFalse: [meta _ false. baseName _ className]. baseClass _ Smalltalk at: baseName asSymbol ifAbsent: [^ nil]. meta ifTrue: [^ baseClass class] ifFalse: [^ baseClass]! ! !SystemDictionary methodsFor: 'class names' stamp: 'jm 5/16/2003 09:58'! classNames "Answer a SortedCollection of all class names." | names | cachedClassNames ifNil: [ names _ OrderedCollection new: self size. self do: [:cl | ((cl isKindOf: Class) and: [(cl name beginsWith: 'AnObsolete') not]) ifTrue: [names add: cl name]]. cachedClassNames _ names asSortedCollection]. ^ cachedClassNames ! ! !SystemDictionary methodsFor: 'class names' stamp: 'di 2/16/2000 10:28'! flushClassNameCache "Smalltalk flushClassNameCache" "Forse recomputation of the cached list of class names." cachedClassNames _ nil! ! !SystemDictionary methodsFor: 'class names' stamp: 'di 2/3/1999 22:21'! removeClassFromSystem: aClass "Delete the class, aClass, from the system." aClass wantsChangeSetLogging ifTrue: [SystemChanges noteRemovalOf: aClass]. aClass acceptsLoggingOfCompilation ifTrue: [Smalltalk logChange: 'Smalltalk removeClassNamed: #', aClass name]. self removeClassFromSystemUnlogged: aClass ! ! !SystemDictionary methodsFor: 'class names' stamp: 'di 4/19/1999 10:29'! removeClassFromSystemUnlogged: aClass "Delete the class, aClass, from the system, but log the removal neither to the current change set nor to the changes log" SystemOrganization removeElement: aClass name. self removeFromStartUpList: aClass. self removeFromShutDownList: aClass. self removeKey: aClass name ifAbsent: []. self flushClassNameCache ! ! !SystemDictionary methodsFor: 'class names' stamp: 'di 2/3/1999 22:33'! renameClass: aClass as: newName "Rename the class, aClass, to have the title newName." | oldref i | SystemOrganization classify: newName under: aClass category. SystemOrganization removeElement: aClass name. SystemChanges renameClass: aClass as: newName. oldref _ self associationAt: aClass name. self removeKey: aClass name. oldref key: newName. self add: oldref. "Old association preserves old refs" (Array with: StartUpList with: ShutDownList) do: [:list | i _ list indexOf: aClass name ifAbsent: [0]. i > 0 ifTrue: [list at: i put: newName]]. self flushClassNameCache! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'wod 11/3/1998 15:41'! abandonSources "Smalltalk abandonSources" "Replaces every method by a copy with the 4-byte source pointer replaced by a string of all arg and temp names, followed by its length. These names can then be used to inform the decompiler. See stats below" "wod 11/3/1998: zap the organization before rather than after condensing changes." | oldCodeString argsAndTemps bTotal bCount oldMethods newMethods m | (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning source code files, hit Yes. If you have any doubts, hit No, to back out with no harm done.') == true ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts. oldMethods _ OrderedCollection new: CompiledMethod instanceCount. newMethods _ OrderedCollection new: CompiledMethod instanceCount. bTotal _ 0. bCount _ 0. Smalltalk allBehaviorsDo: [: b | bTotal _ bTotal + 1]. 'Saving temp names for better decompilation...' displayProgressAt: Sensor cursorPoint from: 0 to: bTotal during: [:bar | Smalltalk allBehaviorsDo: "for test: (Array with: Arc with: Arc class) do: " [:cl | bar value: (bCount _ bCount + 1). cl selectors do: [:selector | m _ cl compiledMethodAt: selector. m fileIndex > 0 ifTrue: [oldCodeString _ cl sourceCodeAt: selector. argsAndTemps _ (cl compilerClass new parse: oldCodeString in: cl notifying: nil) tempNames. oldMethods addLast: m. newMethods addLast: (m copyWithTempNames: argsAndTemps)]]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. Smalltalk allBehaviorsDo: [: b | b zapOrganization]. Smalltalk condenseChanges. Preferences disable: #warnIfNoSourcesFile. " In a system with 7780 methods, we got 83k of temp names, or around 100k with spaces between. The order of letter frequency was eatrnoislcmdgpSub, with about 60k falling in the first 11. This suggests that we could encode in 4 bits, with 0-11 beng most common chars, and 12-15 contributing 2 bits to the next nibble for 6 bits, enough to cover all alphaNumeric with upper and lower case. If we get 3/4 in 4 bits and 1/4 in 8, then we get 5 bits per char, or about 38% savings (=38k in this case). Summary: about 13 bytes of temp names per method, or 8 with simple compression, plus 1 for the size. This would be 5 bytes more than the current 4-byte trailer. "! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'jm 11/1/1998 08:31'! abandonTempNames "Replaces every method by a copy with no source pointer or encoded temp names." "Smalltalk abandonTempNames" | continue oldMethods newMethods n m | continue _ (self confirm: '-- CAUTION -- If you have backed up your system and are prepared to face the consequences of abandoning all source code, hit Yes. If you have any doubts, hit No, to back out with no harm done.'). continue ifFalse: [^ self inform: 'Okay - no harm done']. Smalltalk forgetDoIts; garbageCollect. oldMethods _ OrderedCollection new. newMethods _ OrderedCollection new. n _ 0. 'Removing temp names to save space...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | Smalltalk allBehaviorsDo: [:cl | cl selectors do: [:sel | bar value: (n _ n + 1). m _ cl compiledMethodAt: sel. oldMethods addLast: m. newMethods addLast: (m copyWithTrailerBytes: #(0))]]]. oldMethods asArray elementsExchangeIdentityWith: newMethods asArray. Smalltalk closeSourceFiles. Preferences disable: #warnIfNoChangesFile. Preferences disable: #warnIfNoSourcesFile. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 00:56'! discard3D "Discard 3D Support. Updated for 2.8 TPR" Smalltalk removeKey: #WonderlandConstants ifAbsent: []. Smalltalk removeKey: #AliceConstants ifAbsent: []. Smalltalk removeKey: #B3DEngineConstants ifAbsent: []. SystemOrganization removeCategoriesMatching: 'Morphic-Balloon3D'. SystemOrganization removeCategoriesMatching: 'Balloon3D-*'. SystemOrganization removeCategoriesMatching: 'Pooh-*' ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'! discardFlash "Discard Flash support." SystemOrganization removeCategoriesMatching: 'Balloon-MMFlash*' ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 23:36'! discardMVC "Smalltalk discardMVC" | keepers | Smalltalk isMorphic ifFalse: [PopUpMenu notify: 'You must be in a Morphic project to discard MVC.'. ^ self]. "Check that there are no MVC Projects" (Project allInstances inject: true into: [:ok :proj | ok & proj isMorphic]) ifFalse: [(self confirm: 'Would you like a chance to remove your MVC projects in an orderly manner?') ifTrue: [^ self]. (self confirm: 'If you wish, I can remove all MVC projects, make this project be the top project, and place all orphaned sub-projects of MVC parents here. Would you like be to do this and proceed to discard all MVC classes?') ifTrue: [self zapMVCprojects] ifFalse: [^ self]]. Smalltalk reclaimDependents. "Remove old Paragraph classes and View classes." (ChangeSet superclassOrder: Paragraph withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]. (ChangeSet superclassOrder: View withAllSubclasses asArray) reverseDo: [:c | c removeFromSystem]. "Get rid of ParagraphEditor's ScrollController dependence" #(markerDelta viewDelta scrollAmount scrollBar computeMarkerRegion) do: [:sel | ParagraphEditor removeSelector: sel]. ParagraphEditor compile: 'updateMarker'. ParagraphEditor superclass: MouseMenuController . "Get rid of all Controller classes not needed by ParagraphEditor and ScreenController" keepers _ TextMorphEditor withAllSuperclasses copyWith: ScreenController. (ChangeSet superclassOrder: Controller withAllSubclasses asArray) reverseDo: [:c | (keepers includes: c) ifFalse: [c removeFromSystem]]. SystemOrganization removeCategoriesMatching: 'ST80-Paths'. SystemOrganization removeCategoriesMatching: 'ST80-Pluggable Views'. Smalltalk removeClassNamed: 'FormButtonCache'. Smalltalk removeClassNamed: 'WindowingTransformation'. Smalltalk removeClassNamed: 'ControlManager'. Smalltalk removeClassNamed: 'DisplayTextView'. ScheduledControllers _ nil. Undeclared removeUnreferencedKeys. SystemOrganization removeEmptyCategories. Symbol rehash. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'jm 10/5/2002 07:12'! discardMorphic "Smalltalk discardMorphic" "Discard Morphic. Updated for 2.8 TPR" | subs | "Check that we are in an MVC Project and that there are no Morphic Projects or WorldMorphViews." Smalltalk discardFlash. Smalltalk discardTrueType. subs _ OrderedCollection new. Morph allSubclassesWithLevelDo: [:c :i | subs addFirst: c] startingLevel: 0. subs do: [:c | c removeFromSystem]. Smalltalk removeClassNamed: #CornerRounder. Smalltalk removeKey: #BalloonEngineConstants ifAbsent: []. SystemOrganization removeCategoriesMatching: 'Balloon-*'. SystemOrganization removeCategoriesMatching: 'Morphic-*'. SystemOrganization removeSystemCategory: 'Graphics-Transformations'. SystemOrganization removeSystemCategory: 'ST80-Morphic'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:48'! discardNetworking "Discard the support for TCP/IP networking." Smalltalk discardPluggableWebServer. SystemOrganization removeCategoriesMatching: 'Network-*'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'jm 6/15/2003 20:17'! discardOddsAndEnds "This method throws out lots of classes that are not frequently used." "Smalltalk discardOddsAndEnds" SystemOrganization removeSystemCategory: 'System-Serial Port'. SystemOrganization removeSystemCategory: 'ST80-Symbols'. SystemOrganization removeSystemCategory: 'Tools-File Contents Browser'. SystemOrganization removeSystemCategory: 'System-Compression'. SystemOrganization removeSystemCategory: 'Tools-Explorer'. SystemOrganization removeSystemCategory: 'System-Digital Signatures'. Smalltalk at: #FormView ifPresent: [:c | c compile: 'defaultControllerClass ^ NoController' classified: 'controller access']. Smalltalk removeClassNamed: #FormEditorView. Smalltalk removeClassNamed: #FormEditor. SystemOrganization removeSystemCategory: 'ST80-Paths'. "bit editor (remove Form editor first):" Form removeSelector: #bitEdit. Form removeSelector: #bitEditAt:scale:. StrikeFont removeSelector: #edit:. Smalltalk removeClassNamed: #FormButtonCache. Smalltalk removeClassNamed: #FormMenuController. Smalltalk removeClassNamed: #FormMenuView. Smalltalk removeClassNamed: #BitEditor. "inspector for Dictionaries of Forms" Dictionary removeSelector: #inspectFormsWithLabel:. SystemDictionary removeSelector: #viewImageImports. ScreenController removeSelector: #viewImageImports. Smalltalk removeClassNamed: #FormHolderView. Smalltalk removeClassNamed: #FormInspectView. "experimental hand-drawn character recoginizer:" ParagraphEditor removeSelector: #recognizeCharacters. ParagraphEditor removeSelector: #recognizer:. ParagraphEditor removeSelector: #recognizeCharactersWhileMouseIn:. Smalltalk removeClassNamed: #CharRecog. "experimental updating object viewer:" Object removeSelector: #evaluate:wheneverChangeIn:. Smalltalk removeClassNamed: #ObjectViewer. Smalltalk removeClassNamed: #ObjectTracer. "miscellaneous classes:" Smalltalk removeClassNamed: #Array2D. Smalltalk removeClassNamed: #DriveACar. Smalltalk removeClassNamed: #EventRecorder. Smalltalk removeClassNamed: #FindTheLight. Smalltalk removeClassNamed: #PluggableTest. Smalltalk removeClassNamed: #SystemMonitor. Smalltalk removeClassNamed: #DocLibrary. Smalltalk removeClassNamed: #ProtocolBrowser. Smalltalk removeClassNamed: #ObjectExplorerWrapper. Smalltalk removeClassNamed: #HierarchyBrowser. Smalltalk removeClassNamed: #LinkedMessageSet. Smalltalk removeClassNamed: #ObjectExplorer. Smalltalk removeClassNamed: #PackageBrowser. Smalltalk removeClassNamed: #AbstractHierarchicalList. Smalltalk removeClassNamed: #ChangeList. Smalltalk removeClassNamed: #VersionsBrowser. Smalltalk removeClassNamed: #ChangeRecord. Smalltalk removeClassNamed: #SelectorBrowser. Smalltalk removeClassNamed: #HtmlFileStream. Smalltalk removeClassNamed: #CrLfFileStream. Smalltalk removeClassNamed: #FXGrafPort. Smalltalk removeClassNamed: #FXBlt. Smalltalk at: #SampledSound ifPresent: [:c |c initialize]. #(Helvetica Palatino Courier ComicBold ComicPlain) do: [:k | TextConstants removeKey: k ifAbsent: []]. Preferences setButtonFontTo: (StrikeFont familyName: #NewYork size: 12). #(GZipConstants ZipConstants KlattResonatorIndices ) do: [:k | Smalltalk removeKey: k ifAbsent: []]. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'jm 6/7/2001 15:48'! discardPluggableWebServer "Discard the Pluggable Web Server." SystemOrganization removeCategoriesMatching: 'Network-Pluggable Web Server'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:21'! discardSoundSynthesis "Discard the sound synthesis facilities, and the methods and classes that use it. This also discards MIDI." Smalltalk discardMIDI. Smalltalk discardSpeech. SystemOrganization removeCategoriesMatching: 'Sound-Interface'. Smalltalk at: #GraphMorph ifPresent: [:graphMorph | #(playOnce readDataFromFile) do: [:sel | graphMorph removeSelector: sel]]. Smalltalk at: #TrashCanMorph ifPresent: [:trashMorph | trashMorph class removeSelector: #samplesForDelete. trashMorph class removeSelector: #samplesForMouseEnter. trashMorph class removeSelector: #samplesForMouseLeave]. SystemOrganization removeCategoriesMatching: 'Sound-Synthesis'. SystemOrganization removeCategoriesMatching: 'Sound-Scores'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/3/2000 19:21'! discardSpeech "Discard support for speech synthesis" SystemOrganization removeCategoriesMatching: 'Speech*'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'TPR 8/5/2000 01:32'! discardTrueType "Discard TrueType support." SystemOrganization removeCategoriesMatching: 'Balloon-TrueType*'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 1/12/2000 13:05'! lastRemoval "Smalltalk lastRemoval" #(abandonSources browseAllSelect: printSpaceAnalysis browseObsoleteReferences lastRemoval) do: [:sel | SystemDictionary removeSelector: sel]. [self removeAllUnSentMessages > 0] whileTrue. Set withAllSubclassesDo: [:cls | cls allInstances do: [:s | s rehash]]. Smalltalk allClassesDo: [:c | c zapOrganization]. Smalltalk changes initialize.! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'jm 10/30/2002 20:44'! majorShrink "Smalltalk majorShrink; abandonSources; lastRemoval" "This method throws out lots of the system that is not needed for, eg, operation in a hand-held PC. majorShrink produces a 999k image in Squeak 2.8" Smalltalk isMorphic ifTrue: [^ self error: 'You can only run majorShrink in MVC']. Project current isTopProject ifFalse: [^ self error: 'You can only run majorShrink in the top project']. (Smalltalk confirm: 'All sub-projects will be deleted from this image. You should already have made a backup copy, or you must save with a different name after shrinking. Shall we proceed to discard most of the content in this image?') ifFalse: [^ PopUpMenu notify: 'No changes have been made.']. "Remove all projects but the current one. - saves 522k" ProjectView allInstancesDo: [:pv | pv controller closeAndUnscheduleNoTerminate]. Project current setParent: Project current. MorphWorldView allInstancesDo: [:pv | pv topView controller closeAndUnscheduleNoTerminate]. Utilities classPool at: #ScrapsBook put: nil. Smalltalk discardSoundSynthesis. "544k" Smalltalk discardOddsAndEnds. "227k" Smalltalk discardNetworking. "234k" Smalltalk discard3D. "407k" Smalltalk discardMorphic. "1372k" Symbol rehash. "40k" "Above by itself saves about 4,238k" "Remove references to a few classes to be deleted, so that they won't leave obsolete versions around." FileList removeSelector: #fileIntoNewChangeSet. ChangeSet class compile: 'defaultName ^ ''Changes'' ' classified: 'initialization'. ScreenController removeSelector: #openChangeManager. ScreenController removeSelector: #exitProject. ScreenController removeSelector: #openProject. ScreenController removeSelector: #viewImageImports. "Now delete various other classes.." SystemOrganization removeSystemCategory: 'Graphics-Files'. SystemOrganization removeSystemCategory: 'System-Object Storage'. Smalltalk removeClassNamed: #ProjectController. Smalltalk removeClassNamed: #ProjectView. "Smalltalk removeClassNamed: #Project." Smalltalk removeClassNamed: #Environment. Smalltalk removeClassNamed: #Component1. Smalltalk removeClassNamed: #FormSetFont. Smalltalk removeClassNamed: #FontSet. Smalltalk removeClassNamed: #InstructionPrinter. Smalltalk removeClassNamed: #ChangeSorter. Smalltalk removeClassNamed: #DualChangeSorter. Smalltalk removeClassNamed: #EmphasizedMenu. Smalltalk removeClassNamed: #MessageTally. StringHolder class removeSelector: #originalWorkspaceContents. CompiledMethod removeSelector: #symbolic. RemoteString removeSelector: #makeNewTextAttVersion. Utilities class removeSelector: #absorbUpdatesFromServer. Smalltalk removeClassNamed: #PenPointRecorder. Smalltalk removeClassNamed: #Path. Smalltalk removeClassNamed: #Base64MimeConverter. Smalltalk removeClassNamed: #RWBinaryOrTextStream. Smalltalk removeClassNamed: #AttributedTextStream. Smalltalk removeClassNamed: #WordNet. Smalltalk removeClassNamed: #SelectorBrowser. TextStyle allSubInstancesDo: [:ts | ts newFontArray: (ts fontArray copyFrom: 1 to: (2 min: ts fontArray size))]. ListParagraph initialize. PopUpMenu initialize. StandardSystemView initialize. Smalltalk noChanges. ChangeSorter classPool at: #AllChangeSets put: (OrderedCollection with: Smalltalk changes). SystemDictionary removeSelector: #majorShrink. [Smalltalk removeAllUnSentMessages > 0] whileTrue: [Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]]. SystemOrganization removeEmptyCategories. Smalltalk allClassesDo: [:c | c zapOrganization]. MethodDictionary allInstances do: [:d | d rehash]. Smalltalk changes initialize. Symbol rehash.! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 6/20/1998 12:33'! printSpaceAnalysis "Smalltalk printSpaceAnalysis" ^ Smalltalk printSpaceAnalysis: 0 on: 'STspace.text' ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 9/26/1999 11:32'! printSpaceAnalysis: threshold on: fileName "Smalltalk printSpaceAnalysis: 1000 on: 'STspace.text0'" "If threshold > 0, then only those classes with more than that number of instances will be shown, and they will be sorted by total instance space. If threshold = 0, then all classes will appear, sorted by name." | f codeSpace instCount instSpace totalCodeSpace totalInstCount totalInstSpace eltSize n stats totalPercent percent | Smalltalk garbageCollect. totalCodeSpace _ totalInstCount _ totalInstSpace _ n _ 0. stats _ OrderedCollection new. 'Taking statistics...' displayProgressAt: Sensor cursorPoint from: 0 to: self classNames size during: [:bar | self allClassesDo: [:cl | codeSpace _ cl spaceUsed. bar value: (n _ n+1). Smalltalk garbageCollectMost. instCount _ cl instanceCount. instSpace _ (cl indexIfCompact > 0 ifTrue: [4] ifFalse: [8])*instCount. "Object headers" cl isVariable ifTrue: [eltSize _ cl isBytes ifTrue: [1] ifFalse: [4]. cl allInstancesDo: [:x | instSpace _ instSpace + (x basicSize*eltSize)]] ifFalse: [instSpace _ instSpace + (cl instSize*instCount*4)]. stats add: (Array with: cl name with: codeSpace) , (Array with: instCount with: instSpace). totalCodeSpace _ totalCodeSpace + codeSpace. totalInstCount _ totalInstCount + instCount. totalInstSpace _ totalInstSpace + instSpace]]. totalPercent _ 0.0. f _ FileStream newFileNamed: fileName. f timeStamp. f nextPutAll: ('Class' padded: #right to: 30 with: $ ); nextPutAll: ('code space' padded: #left to: 12 with: $ ); nextPutAll: ('# instances' padded: #left to: 12 with: $ ); nextPutAll: ('inst space' padded: #left to: 12 with: $ ); nextPutAll: ('percent' padded: #left to: 8 with: $ ); cr. threshold > 0 ifTrue: ["If inst count threshold > 0, then sort by space" stats _ (stats select: [:s | s third >= threshold or: [s fourth > (totalInstSpace // 500)]]) asSortedCollection: [:s :s2 | s fourth > s2 fourth]]. stats do: [:s | f nextPutAll: (s first padded: #right to: 30 with: $ ); nextPutAll: (s second printString padded: #left to: 12 with: $ ); nextPutAll: (s third printString padded: #left to: 12 with: $ ); nextPutAll: (s fourth printString padded: #left to: 14 with: $ ). percent _ s fourth*100.0/totalInstSpace roundTo: 0.1. totalPercent _ totalPercent + percent. percent >= 0.1 ifTrue: [f nextPutAll: (percent printString padded: #left to: 8 with: $ )]. f cr]. f cr; nextPutAll: ('Total' padded: #right to: 30 with: $ ); nextPutAll: (totalCodeSpace printString padded: #left to: 12 with: $ ); nextPutAll: (totalInstCount printString padded: #left to: 12 with: $ ); nextPutAll: (totalInstSpace printString padded: #left to: 14 with: $ ); nextPutAll: ((totalPercent roundTo: 0.1) printString padded: #left to: 8 with: $ ). f close! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 6/20/1998 12:37'! printSpaceDifferenceFrom: fileName1 to: fileName2 "For differential results, run printSpaceAnalysis twice with different fileNames, then run this method... Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'. --- do something that uses space here --- Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'. Smalltalk printSpaceDifferenceFrom: 'STspace.text1' to: 'STspace.text2' " | f coll1 coll2 item | f _ FileStream oldFileNamed: fileName1. coll1 _ OrderedCollection new. [f atEnd] whileFalse: [coll1 add: (f upTo: Character cr)]. f close. f _ FileStream oldFileNamed: fileName2. coll2 _ OrderedCollection new. [f atEnd] whileFalse: [item _ (f upTo: Character cr). ((coll1 includes: item) and: [(item endsWith: 'percent') not]) ifTrue: [coll1 remove: item] ifFalse: [coll2 add: item]]. f close. (StringHolder new contents: (String streamContents: [:s | s nextPutAll: fileName1; cr. coll1 do: [:x | s nextPutAll: x; cr]. s cr; cr. s nextPutAll: fileName2; cr. coll2 do: [:x | s nextPutAll: x; cr]])) openLabel: 'Differential Space Analysis'. ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 8/16/2000 14:20'! removeAllUnSentMessages "Smalltalk removeAllUnSentMessages" "[Smalltalk unusedClasses do: [:c | (Smalltalk at: c) removeFromSystem]. Smalltalk removeAllUnSentMessages > 0] whileTrue." "Remove all implementations of unsent messages." | sels n | sels _ self allUnSentMessages. "The following should be preserved for doIts, etc" #(browseAllSelect: printSpaceAnalysis lastRemoval scrollBarValue: scrollBarMenuButtonPressed: withSelectionFrom: to: removeClassNamed: dragon: hilberts: mandala: web test3 factorial tinyBenchmarks benchFib newDepth: restoreAfter: forgetDoIts zapAllMethods obsoleteClasses removeAllUnSentMessages abandonSources removeUnreferencedKeys reclaimDependents zapOrganization condenseChanges browseObsoleteReferences subclass:instanceVariableNames:classVariableNames:poolDictionaries:category: methodsFor:stamp: methodsFor:stamp:prior: instanceVariableNames: startTimerInterruptWatcher unusedClasses) do: [:sel | sels remove: sel ifAbsent: []]. "The following may be sent by perform: in dispatchOnChar..." (ParagraphEditor classPool at: #CmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. (ParagraphEditor classPool at: #ShiftCmdActions) asSet do: [:sel | sels remove: sel ifAbsent: []]. sels size = 0 ifTrue: [^ 0]. n _ 0. Smalltalk allBehaviorsDo: [:x | n _ n+1]. 'Removing ', sels size printString , ' messages . . .' displayProgressAt: Sensor cursorPoint from: 0 to: n during: [:bar | n _ 0. self allBehaviorsDo: [:class | bar value: (n _ n+1). sels do: [:sel | class removeSelectorSimply: sel]]]. ^ sels size! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 4/20/1999 12:24'! unusedClasses "Warning: Slow!! Enumerates all classes in the system and returns a list of those that are apparently unused. A class is considered in use if it (a) has subclasses (b) has instances or (c) is referred to by some method. Obsolete classes are not included in this list." "Smalltalk unusedClasses" | unused c n | unused _ SortedCollection new. 'Scanning for unused classes...' displayProgressAt: Sensor cursorPoint from: 0 to: Metaclass instanceCount during: [:bar | n _ 0. Metaclass allInstancesDo: [:meta | bar value: (n _ n+1). c _ meta soleInstance. ((c ~~ nil) and: [('AnOb*' match: c name asString) not]) ifTrue: [ ((c subclasses size = 0) and: [(c inheritsFrom: FileDirectory) not & (c instanceCount = 0) and: [(Smalltalk includesKey: c name) and: [(Smalltalk allCallsOn: (Smalltalk associationAt: c name)) size = 0]]]) ifTrue: [unused add: c name]]]]. ^ unused asArray ! ! !SystemDictionary methodsFor: 'shrinking' stamp: 'di 9/26/1999 21:44'! zapMVCprojects "Smalltalk zapMVCprojects" | window | Smalltalk garbageCollect. "So allInstances is precise" Project allSubInstancesDo: [:proj | proj isTopProject ifTrue: [proj isMorphic ifFalse: ["Root project is MVC -- we must become the root" Project current setParent: Project current]] ifFalse: [proj parent isMorphic ifFalse: [proj isMorphic ifTrue: ["Remove Morphic projects from MVC views" "... and add them back here." window _ (SystemWindow labelled: proj name) model: proj. window addMorph: (ProjectViewMorph on: proj) frame: (0@0 corner: 1.0@1.0). window openInWorld. proj setParent: Project current]]. proj isMorphic ifFalse: ["Remove MVC projects from Morphic views" Project allInstancesDo: [:p | p deletingProject: proj]. ProjectViewMorph allInstancesDo: [:p | p deletingProject: proj]]] ]! ! !SystemDictionary methodsFor: 'memory space' stamp: 'jm 10/14/2002 18:53'! lowSpaceThreshold "Return the low space threshold. When the amount of free memory (after garbage collection) falls below this limit, the system is in serious danger of completely exhausting memory and crashing. This limit should be made high enough to allow the user open a debugger to diagnose a problem or to save the image." ^ 250000 ! ! !SystemDictionary methodsFor: 'memory space' stamp: 'jm 10/4/2002 11:00'! lowSpaceWatcher "Wait until the low space semaphore is signalled, then take appropriate actions." self garbageCollectMost <= self lowSpaceThreshold ifTrue: [ self garbageCollect <= self lowSpaceThreshold ifTrue: [ "free space must be above threshold before starting low space watcher" ^ self beep]]. LowSpaceSemaphore _ Semaphore new. self primLowSpaceSemaphore: LowSpaceSemaphore. self primSignalAtBytesLeft: self lowSpaceThreshold. "enable low space interrupts" LowSpaceSemaphore wait. "wait for a low space condition..." self primSignalAtBytesLeft: 0. "disable low space interrupts" self primLowSpaceSemaphore: nil. LowSpaceProcess _ nil. "Note: user is now unprotected until the low space watcher is re-installed" Smalltalk isMorphic ifTrue: [Project current interruptName: 'Space is low'] ifFalse: [ScheduledControllers interruptName: 'Space is low']. ! ! !SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 21:15'! useUpMemoryWithArrays "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; useUpMemoryWithArrays" | b | "First use up most of memory." b _ String new: self bytesLeft - self lowSpaceThreshold - 100000. b _ b. "Avoid unused value warning" (1 to: 10000) collect: [:i | Array new: 10000]! ! !SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:49'! useUpMemoryWithContexts "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; useUpMemoryWithContexts" self useUpMemoryWithContexts! ! !SystemDictionary methodsFor: 'memory space' stamp: 'di 8/18/2000 16:50'! useUpMemoryWithTinyObjects "For testing the low space handler..." "Smalltalk installLowSpaceWatcher; useUpMemoryWithTinyObjects" | b | "First use up most of memory." b _ String new: self bytesLeft - self lowSpaceThreshold - 100000. b _ b. "Avoid unused value warning" (1 to: 10000) collect: [:i | BitBlt new]! ! !SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:36'! clearExternalObjects "Clear the array of objects that have been registered for use in non-Smalltalk code." "Smalltalk clearExternalObjects" ExternalSemaphoreTable clearExternalObjects ! ! !SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 21:01'! externalObjects "Return an array of objects that have been registered for use in non-Smalltalk code. Smalltalk objects should be referrenced by external code only via indirection through this array, thus allowing the objects to move during compaction. This array can be cleared when the VM re-starts, since variables in external code do not survive snapshots. Note that external code should not attempt to access a Smalltalk object, even via this mechanism, while garbage collection is in progress." "Smalltalk externalObjects" ^ ExternalSemaphoreTable externalObjects ! ! !SystemDictionary methodsFor: 'special objects' stamp: 'jm 10/7/2002 05:33'! recreateSpecialObjectsArray "Smalltalk recreateSpecialObjectsArray" "The Special Objects Array is an array of object pointers used by the Smalltalk virtual machine. Its contents are critical and unchecked, so don't even think of playing here unless you know what you are doing." | newArray | newArray _ Array new: 48. "Nil false and true get used throughout the interpreter" newArray at: 1 put: nil. newArray at: 2 put: false. newArray at: 3 put: true. "This association holds the active process (a ProcessScheduler)" newArray at: 4 put: (Smalltalk associationAt: #Processor). "Numerous classes below used for type checking and instantiation" newArray at: 5 put: Bitmap. newArray at: 6 put: SmallInteger. newArray at: 7 put: String. newArray at: 8 put: Array. newArray at: 9 put: Smalltalk. newArray at: 10 put: Float. newArray at: 11 put: MethodContext. newArray at: 12 put: BlockContext. newArray at: 13 put: Point. newArray at: 14 put: LargePositiveInteger. newArray at: 15 put: Display. newArray at: 16 put: Message. newArray at: 17 put: CompiledMethod. newArray at: 18 put: (self specialObjectsArray at: 18) "(low space Semaphore)". newArray at: 19 put: Semaphore. newArray at: 20 put: Character. newArray at: 21 put: #doesNotUnderstand:. newArray at: 22 put: #cannotReturn:. newArray at: 23 put: nil. "*unused*" "An array of the 32 selectors that are compiled as special bytecodes, paired alternately with the number of arguments each takes." newArray at: 24 put: #(+ 1 - 1 < 1 > 1 <= 1 >= 1 = 1 ~= 1 * 1 / 1 \\ 1 @ 1 bitShift: 1 // 1 bitAnd: 1 bitOr: 1 at: 1 at:put: 2 size 0 next 0 nextPut: 1 atEnd 0 == 1 class 0 blockCopy: 1 value 0 value: 1 do: 1 new 0 new: 1 x 0 y 0 ). "An array of the 255 Characters in ascii order." newArray at: 25 put: ((0 to: 255) collect: [:ascii | Character value: ascii]). newArray at: 26 put: #mustBeBoolean. newArray at: 27 put: ByteArray. newArray at: 28 put: Process. "An array of up to 31 classes whose instances will have compact headers" newArray at: 29 put: self compactClassesArray. newArray at: 30 put: (self specialObjectsArray at: 30) "(delay Semaphore)". newArray at: 31 put: (self specialObjectsArray at: 31) "(user input Semaphore)". "Prototype instances that can be copied for fast initialization" newArray at: 32 put: (Float new: 2). newArray at: 33 put: (LargePositiveInteger new: 4). newArray at: 34 put: Point new. newArray at: 35 put: #cannotInterpret:. "Note: This must be fixed once we start using context prototypes" newArray at: 36 put: (self specialObjectsArray at: 36). "(MethodContext new: CompiledMethod fullFrameSize)." newArray at: 37 put: nil. newArray at: 38 put: (self specialObjectsArray at: 38). "(BlockContext new: CompiledMethod fullFrameSize)." newArray at: 39 put: Array new. "array of objects referred to by external code" newArray at: 40 put: nil. "was PseudoContext" newArray at: 41 put: nil. "was TranslatedMethod" "finalization Semaphore" newArray at: 42 put: ((self specialObjectsArray at: 42) ifNil:[Semaphore new]). newArray at: 43 put: LargeNegativeInteger. "External objects for callout. Note: Written so that one can actually completely remove the FFI." newArray at: 44 put: (Smalltalk at: #ExternalAddress ifAbsent:[nil]). newArray at: 45 put: (Smalltalk at: #ExternalStructure ifAbsent:[nil]). newArray at: 46 put: (Smalltalk at: #ExternalData ifAbsent:[nil]). newArray at: 47 put: (Smalltalk at: #ExternalFunction ifAbsent:[nil]). newArray at: 48 put: (Smalltalk at: #ExternalLibrary ifAbsent:[nil]). "Now replace the interpreter's reference in one atomic operation" self specialObjectsArray become: newArray! ! !SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:39'! registerExternalObject: anObject "Register the given object in the external objects array and return its index. If it is already there, just return its index." ^ExternalSemaphoreTable registerExternalObject: anObject! ! !SystemDictionary methodsFor: 'special objects' stamp: 'JMM 6/6/2000 20:40'! unregisterExternalObject: anObject "Unregister the given object in the external objects array. Do nothing if it isn't registered." ExternalSemaphoreTable unregisterExternalObject: anObject! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 5/31/2003 17:08'! aboutThisSystem "Identify software version" ^ self inform: self systemInformationString ! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'di 2/11/2000 17:23'! assureStartupStampLogged "If there is a startup stamp not yet actually logged to disk, do it now." | changesFile | StartupStamp ifNil: [^ self]. (SourceFiles isNil or: [(changesFile _ SourceFiles at: 2) == nil]) ifTrue: [^ self]. changesFile setToEnd; cr; cr. changesFile nextChunkPut: StartupStamp asString; cr. StartupStamp _ nil. self forceChangesToDisk.! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/15/1999 16:32'! currentChangeSetString "Smalltalk currentChangeSetString" ^ 'Current Change Set: ', self changes name! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'tk 1/24/2000 23:01'! endianness | bytes word blt | "What endian-ness is the current hardware? The String '1234' will be stored into a machine word. On BigEndian machines (the Mac), $1 will be the high byte if the word. On LittleEndian machines (the PC), $4 will be the high byte." "Smalltalk endianness" bytes _ ByteArray withAll: #(0 0 0 0). "(1 2 3 4) or (4 3 2 1)" word _ WordArray with: 16r01020304. blt _ (BitBlt toForm: (Form new hackBits: bytes)) sourceForm: (Form new hackBits: word). blt combinationRule: Form over. "store" blt sourceY: 0; destY: 0; height: 1; width: 4. blt sourceX: 0; destX: 0. blt copyBits. "paste the word into the bytes" bytes first = 1 ifTrue: [^ #big]. bytes first = 4 ifTrue: [^ #little]. self error: 'Ted is confused'.! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'JMM 8/10/2000 15:15'! externalizeSources "Write the sources and changes streams onto external files." "Smalltalk externalizeSources" | sourcesName changesName aFile | sourcesName _ self sourcesName. (FileDirectory default fileExists: sourcesName) ifTrue: [^ self inform: 'Sorry, you must first move or remove the file named ', sourcesName]. changesName _ self changesName. (FileDirectory default fileExists: changesName) ifTrue: [^ self inform: 'Sorry, you must first move or remove the file named ', changesName]. aFile _ FileStream newFileNamed: sourcesName. aFile nextPutAll: SourceFiles first originalContents. aFile close. "On Mac, set the file type and creator (noop on other platforms)" FileDirectory default setMacFileNamed: sourcesName type: 'STch' creator: 'FAST'. SourceFiles at: 1 put: (FileStream readOnlyFileNamed: sourcesName). aFile _ FileStream newFileNamed: self changesName. aFile nextPutAll: SourceFiles last contents. aFile close. "On Mac, set the file type and creator (noop on other platforms)" FileDirectory default setMacFileNamed: self changesName type: 'STch' creator: 'FAST'. SourceFiles at: 2 put: (FileStream oldFileNamed: changesName). self inform: 'Sources successfully externalized'. ! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sma 2/12/2000 12:42'! lastUpdateString "Smalltalk lastUpdateString" | aNumber | aNumber _ (Smalltalk at: #ChangeSorter ifAbsent: [^ 'Update # unknown']) highestNumberedChangeSet. ^ (aNumber notNil and: [aNumber > 0]) ifTrue: ['latest update: #' , aNumber printString] ifFalse: ['No updates present.']! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/12/1999 17:18'! logChange: aStringOrText "Write the argument, aString, onto the changes file." | aString changesFile | (SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ self]. self assureStartupStampLogged. aStringOrText isText ifTrue: [aString _ aStringOrText string] ifFalse: [aString _ aStringOrText]. (aString isMemberOf: String) ifFalse: [self error: 'can''t log this change']. (aString findFirst: [:char | char isSeparator not]) = 0 ifTrue: [^ self]. "null doits confuse replay" (changesFile _ SourceFiles at: 2) setToEnd; cr; cr. changesFile nextChunkPut: aString. "If want style changes in DoIt, use nextChunkPutWithStyle:, and allow Texts to get here" self forceChangesToDisk.! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 10/7/2002 06:34'! newChanges: aChangeSet "Set the system ChangeSet to be the argument, aChangeSet. Tell the current project that aChangeSet is now its change set. When called from Project enter:, the setChangeSet: call is redundant but harmless; when called from code that changes the current change set from within a project, it's vital" SystemChanges _ aChangeSet. "following code still works after removal of Projects:" Smalltalk at: #Project ifPresent: [:projClass | projClass current setChangeSet: aChangeSet]. ! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'di 4/28/2000 13:01'! openSourceFiles self imageName = LastImageName ifFalse: ["Reset the author initials to blank when the image gets moved" LastImageName _ self imageName. Utilities setAuthorInitials: '']. FileDirectory openSources: self sourcesName andChanges: self changesName forImage: LastImageName. StandardSourceFileArray install! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:59'! recover: nCharacters "Schedule an editable text view on the last n characters of changes." self writeRecentCharacters: nCharacters toFileNamed: 'st80.recent'! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 5/31/2003 17:08'! systemInformationString "Identify the Squeak image version." "Smalltalk systemInformationString" ^ self version, String cr, self currentChangeSetString ! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 9/27/1999 10:41'! timeStamp: aStream "Writes system version and current time on stream aStream." | dateTime | dateTime _ Time dateAndTimeNow. aStream nextPutAll: 'From ', Smalltalk version, ' [', Smalltalk lastUpdateString, '] on ', (dateTime at: 1) printString, ' at ', (dateTime at: 2) printString! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 12/17/2003 21:20'! version "Answer the version of this release." "VersionString _ 'MicroSqueak 0.1 (December 17, 2003)'" ^ VersionString ! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 15:58'! writeRecentCharacters: nCharacters toFileNamed: aFilename "Schedule an editable text view on the last n characters of changes." | changes | changes _ SourceFiles at: 2. changes setToEnd; skip: nCharacters negated. (FileStream newFileNamed: aFilename) nextPutAll: (changes next: nCharacters); close; open; edit! ! !SystemDictionary methodsFor: 'sources, change log' stamp: 'sw 2/3/2000 16:17'! writeRecentToFile | numChars aDirectory aFileName | "Smalltalk writeRecentToFile" aDirectory _ FileDirectory default. aFileName _ Utilities keyLike: 'squeak-recent.01' withTrailing: '.log' satisfying: [:aKey | (aDirectory includesKey: aKey) not]. numChars _ ChangeList getRecentLocatorWithPrompt: 'copy logged source as far back as...'. numChars ifNotNil: [Smalltalk writeRecentCharacters: numChars toFileNamed: aFileName]! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/19/1999 22:36'! add: aClass toList: startUpOrShutDownList after: predecessor "Add the name of aClass to the startUp or shutDown list. Add it after the name of predecessor, or at the end if predecessor is nil." | name earlierName | name _ aClass name. (self at: name ifAbsent: [nil]) == aClass ifFalse: [self error: name , ' cannot be found in Smalltalk dictionary.']. predecessor == nil ifTrue: ["No-op if alredy in the list." (startUpOrShutDownList includes: name) ifFalse: [startUpOrShutDownList == StartUpList ifTrue: ["Add to end of startUp list" startUpOrShutDownList addLast: name] ifFalse: ["Add to front of shutDown list" startUpOrShutDownList addFirst: name]]] ifFalse: ["Add after predecessor, moving it if already there." earlierName _ predecessor name. (self at: earlierName) == predecessor ifFalse: [self error: earlierName , ' cannot be found in Smalltalk dictionary.']. (startUpOrShutDownList includes: earlierName) ifFalse: [self error: earlierName , ' cannot be found in the list.']. startUpOrShutDownList remove: name ifAbsent:[]. startUpOrShutDownList add: name after: earlierName]! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:38'! addToShutDownList: aClass "This will add a ref to this class at the BEGINNING of the shutDown list." self addToShutDownList: aClass after: nil! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! addToShutDownList: aClass after: predecessor self add: aClass toList: ShutDownList after: predecessor! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:37'! addToStartUpList: aClass "This will add a ref to this class at the END of the startUp list." self addToStartUpList: aClass after: nil! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:04'! addToStartUpList: aClass after: predecessor self add: aClass toList: StartUpList after: predecessor! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sma 4/30/2000 09:17'! isMorphic "Answer true if the user interface is running in Morphic rathern than MVC. By convention the gloabl variable World is set to nil when MVC is running. ScheduledControllers could be set to nil when Morphic is running, but this symmetry is not yet in effect." ^ World ~~ nil! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! processShutDownList: quitting "Send #shutDown to each class that needs to wrap up before a snapshot." self send: #shutDown: toClassesNamedIn: ShutDownList with: quitting. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:12'! processStartUpList: resuming "Send #startUp to each class that needs to run initialization after a snapshot." self send: #startUp: toClassesNamedIn: StartUpList with: resuming. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 5/31/2003 16:09'! readDocumentFile "Hook for starting up an application by double-clicking." StartupStamp _ '----STARTUP----', Time dateAndTimeNow printString, ' as ', Smalltalk imageName. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! removeFromShutDownList: aClass ShutDownList remove: aClass name ifAbsent: []! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/3/1999 22:22'! removeFromStartUpList: aClass StartUpList remove: aClass name ifAbsent: []! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 11/14/2003 10:47'! saveAs | dir newName newImageName newChangesName | dir _ FileDirectory default. newName _ FillInTheBlank request: 'New File Name?' initialAnswer: (FileDirectory localNameFor: self imageName). newName = '' ifTrue: [^self]. newName _ FileDirectory baseNameFor: newName asFileName. newImageName _ newName, '.image'. newChangesName _ newName, '.changes'. ((dir includesKey: newImageName) or: [dir includesKey: newChangesName]) ifTrue: [ ^ self notify: newName, ' is already in use. Please choose another name.']. dir copyFileNamed: self changesName toFileNamed: newChangesName. "On Mac, set the file type and creator (noop on other platforms)" FileDirectory default setMacFileNamed: newChangesName type: 'STch' creator: 'FAST'. self logChange: '----SAVEAS ', newName, '----', Date dateAndTimeNow printString. self imageName: (dir fullNameFor: newImageName). LastImageName _ self imageName. self closeSourceFiles; openSourceFiles. "so SNAPSHOT appears in new changes file" self snapshot: true andQuit: false. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'sw 2/8/1999 12:37'! saveSession self snapshot: true andQuit: false! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 11/16/1999 20:18'! send: startUpOrShutDown toClassesNamedIn: startUpOrShutDownList with: argument "Send the message #startUp: or #shutDown: to each class named in the list. The argument indicates if the system is about to quit (for #startUp:) or if the image is resuming (for #startUp:). If any name cannot be found, then remove it from the list." | removals class | removals _ OrderedCollection new. startUpOrShutDownList do: [:name | class _ self at: name ifAbsent: [nil]. class == nil ifTrue: [removals add: name] ifFalse: [class perform: startUpOrShutDown with: argument]]. "Remove any obsolete entries, but after the iteration" startUpOrShutDownList removeAll: removals! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 6/7/1999 21:33'! setGCParameters "Adjust the VM's default GC parameters to avoid premature tenuring." Smalltalk vmParameterAt: 5 put: 4000. "do an incremental GC after this many allocations" Smalltalk vmParameterAt: 6 put: 2000. "tenure when more than this many objects survive the GC" ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'di 2/4/1999 15:23'! shutDownSound "No longer used in the release, but retained for backward compatibility" Smalltalk at: #SoundPlayer ifPresent: [:class | class shutDown]. ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'jm 10/30/2002 18:27'! snapshot: save andQuit: quit "Mark the changes file and close all files. If save is true, save the current state of this Smalltalk in the image file. If quit is true, then exit to the outer shell. The latter part of this method runs when resuming a previously saved image. The resume logic checks for a document file to process when starting up." | resuming msg sourceLink | save & (SourceFiles at: 2) notNil ifTrue: [msg _ (quit ifTrue: ['----QUIT----'] ifFalse: ['----SNAPSHOT----']) , Date dateAndTimeNow printString. sourceLink _ ' priorSource: ' , LastQuitLogPosition printString. self assureStartupStampLogged. LastQuitLogPosition _ (SourceFiles at: 2) setToEnd; position. self logChange: msg , sourceLink. Transcript cr; show: msg]. self processShutDownList: quit. Cursor write show. save ifTrue: [resuming _ self snapshotPrimitive] "<-- PC frozen here on image file" ifFalse: [resuming _ false]. quit & resuming not ifTrue: [self quitPrimitive]. Cursor normal show. self setGCParameters. resuming ifTrue: [self clearExternalObjects]. self processStartUpList: resuming. resuming ifTrue: [self readDocumentFile]. Smalltalk isMorphic ifTrue: [SystemWindow wakeUpTopWindowUponStartup]. ^ resuming ! ! !SystemDictionary methodsFor: 'snapshot and quit' stamp: 'ar 3/26/2000 16:12'! unbindExternalPrimitives "Primitive. Force all external primitives to be looked up again afterwards. Since external primitives that have not found are bound for fast failure this method will force the lookup of all primitives again so that after adding some plugin the primitives may be found." <primitive: 570> "Do nothing if the primitive fails for compatibility with older VMs"! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'di 8/16/2000 10:08'! condenseChanges "Smalltalk condenseChanges" "Move all the changes onto a compacted sources file." | f oldChanges classCount | f _ FileStream fileNamed: 'ST80.temp'. f header; timeStamp. 'Condensing Changes File...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). class moveChangesTo: f. class class moveChangesTo: f]]. LastQuitLogPosition _ f position. f trailer; close. oldChanges _ SourceFiles at: 2. oldChanges close. FileDirectory default deleteFileNamed: oldChanges name , '.old'. FileDirectory default rename: oldChanges name toBe: oldChanges name , '.old'. FileDirectory default rename: f name toBe: oldChanges name. FileDirectory default setMacFileNamed: oldChanges name type: 'STch' creator: 'FAST'. SourceFiles at: 2 put: (StandardFileStream oldFileNamed: oldChanges name).! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'JMM 8/10/2000 15:13'! condenseSources "Smalltalk condenseSources" "Move all the changes onto a compacted sources file." | f classCount dir | dir _ FileDirectory default. "Write all sources with fileIndex 1" f _ FileStream newFileNamed: self sourcesName , '.temp'. f header; timeStamp. 'Condensing Sources File...' displayProgressAt: Sensor cursorPoint from: 0 to: Smalltalk classNames size during: [:bar | classCount _ 0. Smalltalk allClassesDo: [:class | bar value: (classCount _ classCount + 1). class fileOutOn: f moveSource: true toFile: 1]]. f trailer; close. "Make a new empty changes file" self closeSourceFiles. dir rename: self changesName toBe: self changesName , '.old'. (FileStream newFileNamed: self changesName) header; timeStamp; close. LastQuitLogPosition _ 0. dir rename: self sourcesName toBe: self sourcesName , '.old'. dir rename: self sourcesName , '.temp' toBe: self sourcesName. "On Mac, set the file type and creator (noop on other platforms)" FileDirectory default setMacFileNamed: self changesName type: 'STch' creator: 'FAST'. FileDirectory default setMacFileNamed: self sourcesName type: 'STch' creator: 'FAST'. self openSourceFiles. SelectionMenu notify: 'Source files have been rewritten!! Check that all is well, and then save/quit.'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 7/19/1999 23:00'! forgetDoIts "Smalltalk forgetDoIts" Smalltalk allBehaviorsDo: "get rid of old DoIt methods" [:cl | cl forgetDoIts] ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'ar 7/15/1999 16:05'! obsoleteBehaviors "Smalltalk obsoleteBehaviors inspect" "Find all obsolete behaviors including meta classes" | obs | obs _ OrderedCollection new. Smalltalk garbageCollect. self allObjectsDo:[:cl| (cl isBehavior and:[cl isObsolete]) ifTrue:[obs add: cl]]. ^ obs asArray! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'tk 6/24/1999 11:47'! reclaimDependents "Smalltalk reclaimDependents" "Reclaim unused entries in DependentsFields (DF)..." "NOTE: if <object>addDependent: is ever used to add something other than a view, this process will fail to reinstate that thing after clearing out DependentsFields. DF was only intended to be used as part of the MVC architecture." Object classPool at: #DependentsFields "Remove all entries from DF" put: IdentityDictionary new. Smalltalk garbageCollect. "If that was the only reference, they will go away" "Now if any views of non-models remain, they should be reinstated as dependent views..." View allSubInstancesDo: [:v | (v model==nil or: [v model isKindOf: Model]) ifFalse: [v model addDependent: v]]. SystemWindow allSubInstancesDo: [:v | (v model==nil or: [v model isKindOf: Model]) ifFalse: [v model addDependent: v]]. ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'di 4/24/2000 14:02'! recompileAllFrom: firstName "Recompile all classes, starting with given name." Smalltalk forgetDoIts. self allClassesDo: [:class | class name >= firstName ifTrue: [Transcript show: class name; cr. class compileAll]] "Smalltalk recompileAllFrom: 'AAABodyShop'." ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'di 10/16/1999 20:31'! removeAllLineFeeds "Smalltalk removeAllLineFeeds" "Scan all methods for source code with lineFeeds. Replaces all occurrences of <CR><LF> by <CR>, noted by beep. Halts with a message if any other LFs are found." | oldCodeString n crlf cr newCodeString oldStamp oldCategory m | crlf _ String with: Character cr with: Character lf. cr _ String with: Character cr. Smalltalk forgetDoIts. 'Scanning sources for LineFeeds. This will take a few minutes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. m _ 0. Smalltalk allBehaviorsDo: [:cls | cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString _ (cls sourceCodeAt: selector) asString. (oldCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [self beep. newCodeString _ oldCodeString copyReplaceAll: crlf with: cr asTokens: false. (newCodeString indexOf: Character lf startingAt: 1) > 0 ifTrue: [(self confirm: cls name , ' ' , (selector contractTo: 30) , ' has an isolated LineFeed (not part of CRLF). Shall I replace it?') ifFalse: [self halt]]. oldStamp _ Utilities timeStampForMethod: (cls compiledMethodAt: selector). oldCategory _ cls whichCategoryIncludesSelector: selector. cls compile: newCodeString classified: oldCategory withStamp: oldStamp notifying: nil. m _ m + 1]]]. ]. Transcript cr; show: m printString , ' methods stripped of LFs.'. ! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'di 6/8/1999 15:47'! removeEmptyMessageCategories "Smalltalk removeEmptyMessageCategories" Smalltalk garbageCollect. (ClassOrganizer allInstances copyWith: SystemOrganization) do: [:org | org removeEmptyCategories]! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'di 8/23/1998 14:35'! testDecompiler "Smalltalk testDecompiler" "Decompiles the source for every method in the system, and then compiles that source and verifies that it generates (and decompiles to) identical code. This currently fails in a number of places because some different patterns (esp involving conditionals where the first branch returns) decompile the same." | methodNode oldMethod newMethod badOnes oldCodeString n | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Decompiling all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldMethod _ cls compiledMethodAt: selector. oldCodeString _ (cls decompilerClass new decompile: selector in: cls method: oldMethod) decompileString. methodNode _ cls compilerClass new compile: oldCodeString in: cls notifying: nil ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldCodeString = (cls decompilerClass new decompile: selector in: cls method: newMethod) decompileString ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. Smalltalk browseMessageList: badOnes asSortedCollection name: 'Decompiler Discrepancies'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 11/9/1999 17:56'! testFormatter "Smalltalk testFormatter" "Reformats the source for every method in the system, and then compiles that source and verifies that it generates identical code. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting." | newCodeString methodNode oldMethod newMethod badOnes n | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. newCodeString _ (cls compilerClass new) format: (cls sourceCodeAt: selector) in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. methodNode _ cls compilerClass new compile: newCodeString in: cls notifying: nil ifFail: []. newMethod _ methodNode generate: #(0 0 0 0). oldMethod _ cls compiledMethodAt: selector. oldMethod = newMethod ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! ! !SystemDictionary methodsFor: 'housekeeping' stamp: 'sw 11/9/1999 17:56'! testFormatter2 "Smalltalk testFormatter2" "Reformats the source for every method in the system, and then verifies that the order of source tokens is unchanged. The formatting used will be either classic monochrome or fancy polychrome, depending on the setting of the preference #colorWhenPrettyPrinting." | newCodeString badOnes n oldCodeString oldTokens newTokens | badOnes _ OrderedCollection new. Smalltalk forgetDoIts. 'Formatting all classes...' displayProgressAt: Sensor cursorPoint from: 0 to: CompiledMethod instanceCount during: [:bar | n _ 0. Smalltalk allBehaviorsDo: [:cls | "Transcript cr; show: cls name." cls selectors do: [:selector | (n _ n+1) \\ 100 = 0 ifTrue: [bar value: n]. oldCodeString _ (cls sourceCodeAt: selector) asString. newCodeString _ (cls compilerClass new) format: oldCodeString in: cls notifying: nil decorated: Preferences colorWhenPrettyPrinting. oldTokens _ oldCodeString findTokens: Character separators. newTokens _ newCodeString findTokens: Character separators. oldTokens = newTokens ifFalse: [Transcript cr; show: '***' , cls name , ' ' , selector. badOnes add: cls name , ' ' , selector]]]. ]. Smalltalk browseMessageList: badOnes asSortedCollection name: 'Formatter Discrepancies'! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 7/10/1999 08:10'! extraVMMemory "Answer the current setting of the 'extraVMMemory' VM parameter. See the comment in extraVMMemory: for details." ^ Smalltalk vmParameterAt: 23 ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 7/10/1999 08:26'! extraVMMemory: extraBytesToReserve "Request that the given amount of extra memory be reserved for use by the virtual machine to leave extra C heap space available for things like plugins, network and file buffers, and so on. This request is stored when the image is saved and honored when the image is next started up. Answer the previous value of this parameter." extraBytesToReserve < 0 ifTrue: [self error: 'VM memory reservation must be non-negative']. ^ Smalltalk vmParameterAt: 23 put: extraBytesToReserve ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 11/27/1999 14:53'! getVMVersion "Smalltalk getVMVersion" "Return a string identifying the interpreter version" ^self getSystemAttribute: 1004.! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'di 9/23/1998 16:11'! handleUserInterrupt Preferences cmdDotEnabled ifTrue: [Smalltalk isMorphic ifTrue: [[Project current interruptName: 'User Interrupt'] fork] ifFalse: [[ScheduledControllers interruptName: 'User Interrupt'] fork]]! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'di 7/19/1999 15:44'! hasMorphic "Answer whether the Morphic classes are available in the system (they may have been stripped, such as by a call to Smalltalk removeMorphic" ^ ((Smalltalk at: #Morph ifAbsent: [nil]) isKindOf: Class)! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'tao 10/26/97 23:23'! jpegReaderClass "Answer, if present, a class to handle the importing of JPEG files from disk. If none, return nil. 9/18/96 sw" | aClass | ^ ((aClass _ self at: #JPEGReadWriter ifAbsent: [nil]) isKindOf: Class) ifTrue: [aClass] ifFalse: [nil]! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 5/16/2000 00:54'! listBuiltinModule: index "Return the name of the n-th builtin module. This list is not sorted!!" <primitive: 572> ^self primitiveFailed! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 6/5/2000 18:44'! listBuiltinModules "Smalltalk listBuiltinModules" "Return a list of all builtin modules (e.g., plugins). Builtin plugins are those that are compiled with the VM directly, as opposed to plugins residing in an external shared library. The list will include all builtin plugins regardless of whether they are currently loaded or not. Note that the list returned is not sorted!!" | modules index name | modules _ WriteStream on: Array new. index _ 1. [true] whileTrue:[ name _ self listBuiltinModule: index. name ifNil:[^modules contents]. modules nextPut: name. index _ index + 1. ].! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'TPR 5/16/2000 16:56'! listLoadedModule: index "Return the name of the n-th loaded module. This list is not sorted!!" <primitive: 573> ^self primitiveFailed! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 6/5/2000 18:43'! listLoadedModules "Smalltalk listLoadedModules" "Return a list of all currently loaded modules (e.g., plugins). Loaded modules are those that currently in use (e.g., active). The list returned will contain all currently active modules regardless of whether they're builtin (that is compiled with the VM) or external (e.g., residing in some external shared library). Note that the returned list is not sorted!!" | modules index name | modules _ WriteStream on: Array new. index _ 1. [true] whileTrue:[ name _ self listLoadedModule: index. name ifNil:[^modules contents]. modules nextPut: name. index _ index + 1. ].! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'di 12/6/1999 19:54'! logError: errMsg inContext: aContext to: aFilename "Log the error message and a stack trace to the given file." | ff ctx | FileDirectory default deleteFileNamed: aFilename ifAbsent: []. (ff _ FileStream fileNamed: aFilename) ifNil: [^ self "avoid recursive errors"]. ff print: Date today; space; print: Time now; cr. ff nextPutAll: errMsg; cr. "Note: The following is an open-coded version of ContextPart>>stackOfSize: since this method may be called during a low space condition and we might run out of space for allocating the full stack." ctx _ aContext. [ctx == nil] whileFalse:[ ff print: ctx; cr. ctx _ ctx sender]. ff close.! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 11/1/1998 11:38'! spaceForInstancesOf: aClass "Answer the number of bytes consumed by all instances of the given class, including thier object headers." | instCount isCompact instVarBytes bytesPerElement contentBytes headerBytes total | instCount _ aClass instanceCount. instCount = 0 ifTrue: [^ 0]. isCompact _ aClass indexIfCompact > 0. instVarBytes _ aClass instSize * 4. aClass isVariable ifTrue: [ bytesPerElement _ aClass isBytes ifTrue: [1] ifFalse: [4]. total _ 0. aClass allInstancesDo: [:inst | contentBytes _ instVarBytes + (inst size * bytesPerElement). headerBytes _ contentBytes > 255 ifTrue: [12] ifFalse: [isCompact ifTrue: [4] ifFalse: [8]]. total _ total + headerBytes + contentBytes]. ^ total] ifFalse: [ headerBytes _ instVarBytes > 255 ifTrue: [12] ifFalse: [isCompact ifTrue: [4] ifFalse: [8]]. ^ instCount * (headerBytes + instVarBytes)]. ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'jm 11/1/1998 11:45'! spaceTally "Answer a collection of tuples representing the memory space (in bytes) consumed by the code and instances of each class in the system. The tuples have the form: <class> <code size> <instance count> <space for instances> Code sizes do not currently report memory consumed by class variables. The arrays used to record these results consume a relatively insignificant amount of space." "(Smalltalk spaceTally asSortedCollection: [:a :b | a last > b last]) asArray" | results entry c | "pre-allocate array of entries for results" results _ OrderedCollection new: self size. self do: [:cl | (cl isKindOf: Class) ifTrue: [ entry _ Array new: 4. entry at: 1 put: cl. results add: entry]]. results _ results asArray. Smalltalk garbageCollect. 1 to: results size do: [:i | entry _ results at: i. c _ entry at: 1. entry at: 2 put: c spaceUsed. entry at: 3 put: c instanceCount. entry at: 4 put: (self spaceForInstancesOf: c). Smalltalk garbageCollectMost]. ^ results ! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'ar 3/10/2000 17:32'! unloadModule: aString "Primitive. Unload the given module. This primitive is intended for development only since some platform do not implement unloading of DLL's accordingly. Also, the mechanism for unloading may not be supported on all platforms." <primitive: 571> ^self primitiveFailed! ! !SystemDictionary methodsFor: 'miscellaneous' stamp: 'sw 9/21/1998 11:03'! verifyMorphicAvailability "If Morphic is available, return true; if not, put up an informer and return false" self hasMorphic ifFalse: [self beep. self inform: 'Sorry, Morphic must be present to use this feature'. ^ false]. ^ true! ! !SystemDictionary methodsFor: 'accessing' stamp: 'ar 7/11/1999 21:56'! organization "Return the organizer for the receiver" ^SystemOrganization! ! !SystemDictionary methodsFor: 'printing' stamp: 'sma 6/1/2000 09:53'! printElementsOn: aStream aStream nextPutAll:'(lots of globals)'! ! !SystemDictionary class methodsFor: 'initialization' stamp: 'jm 5/23/2003 13:24'! initialize "SystemDictionary initialize" | oldList | oldList _ StartUpList. StartUpList _ OrderedCollection new. "These get processed from the top down..." Smalltalk addToStartUpList: DisplayScreen. Smalltalk addToStartUpList: Cursor. Smalltalk addToStartUpList: InputSensor. Smalltalk addToStartUpList: ProcessorScheduler. "Starts low space watcher and bkground." Smalltalk addToStartUpList: Delay. Smalltalk addToStartUpList: FileDirectory. "Enables file stack dump and opens sources." Smalltalk addToStartUpList: CrLfFileStream. oldList ifNotNil: [oldList do: [:className | Smalltalk at: className ifPresent: [:theClass | Smalltalk addToStartUpList: theClass]]]. Smalltalk addToStartUpList: PasteUpMorph. Smalltalk addToStartUpList: ControlManager. oldList _ ShutDownList. ShutDownList _ OrderedCollection new. "These get processed from the bottom up..." Smalltalk addToShutDownList: DisplayScreen. Smalltalk addToShutDownList: Form. Smalltalk addToShutDownList: ControlManager. Smalltalk addToShutDownList: StrikeFont. Smalltalk addToShutDownList: Color. Smalltalk addToShutDownList: FileDirectory. Smalltalk addToShutDownList: Delay. Smalltalk addToShutDownList: SoundPlayer. oldList ifNotNil: [oldList reverseDo: [:className | Smalltalk at: className ifPresent: [:theClass | Smalltalk addToShutDownList: theClass]]]. ! ! My instances provide an organization for the classes in the system, just as a ClassOrganizer organizes the messages within a class. The only difference is the methods for fileIn/Out.! !SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'di 8/16/2000 10:03'! fileOut "SystemOrganization fileOut" (FileStream newFileNamed: (FileDirectory default nextNameFor: 'SystemOrganization' extension: 'st')) nextPutAll: 'SystemOrganization changeFromCategorySpecs: #('; cr; print: SystemOrganization; "ends with a cr" nextPutAll: ')!!'; cr; close.! ! !SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'jm 12/4/2003 21:25'! fileOutCategoriesMatching: aPattern on: aFileStream "Store on the given stream, all the classes in categories matching the given pattern string." "| s | s _ WriteStream on: String new. SystemOrganization fileOutCategoriesMatching: 'MSqueak-*' on: s. s contents" | first poolSet tempClass classes | classes _ OrderedCollection new. (self categories select: [:cat | aPattern match: cat]) do: [: cat | (self listAtCategoryNamed: cat) do: [:n | classes add: (Smalltalk at: n)]]. classes _ ChangeSet superclassOrder: classes. poolSet _ Set new. classes do: [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]]. poolSet size > 0 ifTrue: [ tempClass _ Class new. tempClass shouldFileOutPools ifTrue: [ poolSet _ poolSet select: [:aPool | tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)]. poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]]. first _ true. classes do: [:class | first ifTrue: [first _ false] ifFalse: [aFileStream cr; nextPut: Character newPage; cr]. class fileOutOn: aFileStream moveSource: false toFile: 0 initializing: false]. classes do: [:cls | cls fileOutInitializerOn: aFileStream].! ! !SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:33'! fileOutCategory: category asHtml: useHtml "FileOut all the classes in the named system category." | fileStream | fileStream _ useHtml ifTrue: [(FileStream newFileNamed: category , '.html') asHtml] ifFalse: [FileStream newFileNamed: category , '.st']. self fileOutCategory: category on: fileStream initializing: true. fileStream close! ! !SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:28'! fileOutCategory: category on: aFileStream "Store on the file associated with aFileStream, all the classes associated with the category and any requested shared pools." ^self fileOutCategory: category on: aFileStream initializing: true! ! !SystemOrganizer methodsFor: 'fileIn/Out' stamp: 'ar 12/22/1999 17:28'! fileOutCategory: category on: aFileStream initializing: aBool "Store on the file associated with aFileStream, all the classes associated with the category and any requested shared pools." | first poolSet tempClass classes | classes _ (self superclassOrder: category). poolSet _ Set new. classes do: [:class | class sharedPools do: [:eachPool | poolSet add: eachPool]]. poolSet size > 0 ifTrue: [tempClass _ Class new. tempClass shouldFileOutPools ifTrue: [poolSet _ poolSet select: [:aPool | tempClass shouldFileOutPool: (Smalltalk keyAtIdentityValue: aPool)]. poolSet do: [:aPool | tempClass fileOutPool: aPool onFileStream: aFileStream]]]. first _ true. classes do: [:class | first ifTrue: [first _ false] ifFalse: [aFileStream cr; nextPut: Character newPage; cr]. class fileOutOn: aFileStream moveSource: false toFile: 0 initializing: false]. aBool ifTrue:[classes do:[:cls| cls fileOutInitializerOn: aFileStream]].! ! !SystemOrganizer methodsFor: 'remove' stamp: 'di 9/10/1999 09:37'! removeSystemCategory: category "remove all the classes associated with the category" (self superclassOrder: category) reverseDo: [:class | class removeFromSystem]. self removeEmptyCategories! ! !SystemWindow methodsFor: 'initialization' stamp: 'kfr 4/27/2000 20:56'! addCloseBox self addMorph: (closeBox _ SimpleButtonMorph new borderWidth: 0; label: 'X' font: Preferences standardButtonFont; color: Color transparent; actionSelector: #delete; target: self; extent: 14@14)! ! !SystemWindow methodsFor: 'initialization' stamp: 'jm 10/16/2002 06:57'! addMenuControl self addMorph: (menuBox _ IconicButton new borderWidth: 0; labelGraphic: self menuButtonIcon; color: Color transparent; actWhen: #buttonDown; actionSelector: #offerWindowMenu; target: self; setBalloonText: 'window menu') "NB: for the moment, we always supply balloon help for this control, until people get used to it; eventually, we mays switch to showing this balloon help only in novice mode, as we do for the other standard window controls."! ! !SystemWindow methodsFor: 'initialization' stamp: 'jm 6/15/2003 16:56'! initialize | aFont | super initialize. allowReframeHandles := true. labelString ifNil: [labelString _ 'Untitled Window']. isCollapsed _ false. activeOnlyOnTop _ true. paneMorphs _ Array new. paneRects _ Array new. borderColor _ #raised. borderWidth _ 1. color _ Color black. aFont _ Preferences standardButtonFont. stripes _ Array with: (BorderedMorph newBounds: bounds color: Color gray) "see extent:" with: (BorderedMorph newBounds: bounds color: Color gray). self addMorph: (stripes first borderWidth: 1). self addMorph: (stripes second borderWidth: 2). self addMorph: (label _ StringMorph new contents: labelString; font: Preferences windowTitleFont emphasis: 1). self setLabelWidgetAllowance. self addCloseBox. self addMenuControl. self addMorph: (collapseBox _ SimpleButtonMorph new borderWidth: 0; label: 'O' font: aFont; color: Color transparent; actionSelector: #collapseOrExpand; target: self; extent: 14@14). Preferences noviceMode ifTrue: [closeBox ifNotNil: [closeBox setBalloonText: 'close window']. menuBox ifNotNil: [menuBox setBalloonText: 'window menu']. collapseBox ifNotNil: [collapseBox setBalloonText: 'collapse/expand window']]. self extent: 300@200. mustNotClose _ false. updatablePanes _ Array new.! ! !SystemWindow methodsFor: 'initialization' stamp: 'jm 11/25/2002 15:51'! menuButtonIcon MenuButtonIcon ifNil: [ MenuButtonIcon _ (Form extent: 8@9 depth: 1 fromArray: #(4278190080 2164260864 3170893824 2164260864 3170893824 2164260864 3170893824 2164260864 4278190080) offset: 0@0)]. ^ MenuButtonIcon ! ! !SystemWindow methodsFor: 'accessing' stamp: 'jm 10/3/2002 17:54'! model ^ model ! ! !SystemWindow methodsFor: 'accessing' stamp: 'jm 10/3/2002 17:55'! model: anObject model _ anObject. ! ! !SystemWindow methodsFor: 'geometry' stamp: 'sr 1/14/2000 03:59'! extent: newExtent | inner labelRect | isCollapsed ifTrue: [super extent: newExtent x @ (self labelHeight + 2)] ifFalse: [super extent: newExtent]. inner _ self innerBounds. labelRect _ self labelRect. stripes first bounds: (labelRect insetBy: 1). stripes second bounds: (labelRect insetBy: 3). self setStripeColorsFrom: self paneColorToUse. closeBox ifNotNil: [closeBox align: closeBox topLeft with: inner topLeft + (4 @ 1)]. menuBox ifNotNil: [menuBox align: menuBox topLeft with: inner topLeft + (19 @ 1)]. collapseBox align: collapseBox topRight with: inner topRight - (4 @ -1). label fitContents; setWidth: (label width min: bounds width - self labelWidgetAllowance). label align: label bounds topCenter with: inner topCenter. isCollapsed ifTrue: [collapsedFrame _ self bounds] ifFalse: [self setBoundsOfPaneMorphs. fullFrame _ self bounds]! ! !SystemWindow methodsFor: 'geometry' stamp: 'di 6/16/1998 07:56'! labelRect ^ self innerBounds withHeight: self labelHeight. ! ! !SystemWindow methodsFor: 'geometry' stamp: 'sw 2/16/1999 15:23'! paneMorphs "Nominally private but a need for obtaining this from the outside arose" ^ paneMorphs copy! ! !SystemWindow methodsFor: 'geometry' stamp: 'sma 2/5/2000 14:09'! panelRect "Answer the area below the title bar which is devoted to panes." ^ self innerBounds insetBy: (0 @ self labelHeight corner: 0 @ 0)! ! !SystemWindow methodsFor: 'geometry' stamp: 'sw 10/8/1998 13:41'! setBoundsOfPaneMorphs | panelRect | panelRect _ self panelRect. paneMorphs with: paneRects do: [:m :frame | "m color: paneColor." m bounds: (((frame scaleBy: panelRect extent) translateBy: panelRect topLeft)) truncated]! ! !SystemWindow methodsFor: 'geometry' stamp: 'di 10/23/1998 09:39'! setPaneRectsFromBounds "Reset proportional specs from actual bounds, eg, after reframing panes" | panelRect | panelRect _ self panelRect. paneRects _ paneMorphs collect: [:m | (m bounds translateBy: panelRect topLeft negated) scaleBy: (1.0 asPoint / panelRect extent)]! ! !SystemWindow methodsFor: 'label' stamp: 'sr 1/14/2000 02:39'! getRawLabel ^ label! ! !SystemWindow methodsFor: 'label' stamp: 'jm 10/15/2002 18:07'! labelDisplayBox "For compatability with StandardSystemView." ^ self position extent: 200@30! ! !SystemWindow methodsFor: 'label' stamp: 'sw 9/28/1999 13:39'! labelHeight ^ label height + 1 max: collapseBox height! ! !SystemWindow methodsFor: 'label' stamp: 'jm 10/10/2002 20:17'! labelText "For compatability with StandardSystemView." ^ labelString asParagraph ! ! !SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'! labelWidgetAllowance ^ labelWidgetAllowance ifNil: [self setLabelWidgetAllowance]! ! !SystemWindow methodsFor: 'label' stamp: 'di 11/4/1999 13:24'! relabel | newLabel | newLabel _ FillInTheBlank request: 'New title for this window' initialAnswer: labelString. newLabel isEmpty ifTrue: [^self]. (model windowReqNewLabel: newLabel) ifTrue: [self setLabel: newLabel]! ! !SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:25'! setLabel: aString labelString _ aString. label ifNil: [^ self]. label contents: aString. self labelWidgetAllowance. "Sets it if not already" self isCollapsed ifTrue: [self extent: (label width + labelWidgetAllowance) @ (self labelHeight + 2)] ifFalse: [label fitContents; setWidth: (label width min: bounds width - labelWidgetAllowance). label align: label bounds topCenter with: bounds topCenter + (0@borderWidth). collapsedFrame ifNotNil: [collapsedFrame _ collapsedFrame withWidth: label width + labelWidgetAllowance]]! ! !SystemWindow methodsFor: 'label' stamp: 'sw 9/29/1999 07:22'! setLabelWidgetAllowance ^ labelWidgetAllowance _ 75! ! !SystemWindow methodsFor: 'label' stamp: 'ar 5/18/2000 18:35'! widthOfFullLabelText ^ (DisplayScanner quickPrintOn: Display box: Display boundingBox font: (Preferences windowTitleFont emphasized: 1)) stringWidth: labelString! ! !SystemWindow methodsFor: 'open/close' stamp: 'jm 10/15/2002 15:24'! delete | thisWorld | self mustNotClose ifTrue: [^ self]. model okToChange ifFalse: [^ self]. thisWorld _ self world. super delete. model windowIsClosing; release. model _ nil. SystemWindow noteTopWindowIn: thisWorld. ! ! !SystemWindow methodsFor: 'open/close' stamp: 'sw 9/28/1999 13:32'! mustNotClose ^ mustNotClose == true! ! !SystemWindow methodsFor: 'open/close' stamp: 'sw 8/12/1998 14:40'! openInWorld: aWorld "This msg and its callees result in the window being activeOnlyOnTop" self bounds: (RealEstateAgent initialFrameFor: self). aWorld addMorph: self. self activate. aWorld startSteppingSubmorphsOf: self! ! !SystemWindow methodsFor: 'open/close' stamp: 'di 5/8/2000 10:02'! openInWorld: aWorld extent: extent "This msg and its callees result in the window being activeOnlyOnTop" self position: (RealEstateAgent initialFrameFor: self) topLeft; extent: extent. aWorld addMorph: self. self activate. aWorld startSteppingSubmorphsOf: self.! ! !SystemWindow methodsFor: 'open/close' stamp: 'di 5/8/2000 10:02'! openInWorldExtent: extent "This msg and its callees result in the window being activeOnlyOnTop" Smalltalk isMorphic ifFalse: [^ self openInMVCExtent: extent]. self openInWorld: World extent: extent! ! !SystemWindow methodsFor: 'open/close' stamp: 'sw 10/15/1998 11:13'! positionSubmorphs "Feels like overkill, but effect needed" super positionSubmorphs. self submorphsDo: [:aMorph | aMorph positionSubmorphs]! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:19'! collapse self isCollapsed ifFalse:[self collapseOrExpand]! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'jm 10/15/2002 15:26'! collapseOrExpand isCollapsed ifTrue: ["Expand -- restore panes to morphics structure" isCollapsed _ false. collapsedFrame _ self bounds. "First save latest collapsedFrame" self bounds: fullFrame. paneMorphs reverseDo: [:m | self addMorph: m. self world startSteppingSubmorphsOf: m]. self activate "-- mainly for findWindow"] ifFalse: ["Collapse -- remove panes from morphics structure" isCollapsed _ true. fullFrame _ self bounds. "First save latest fullFrame" paneMorphs do: [:m | m delete; releaseCachedState]. model modelSleep. collapsedFrame _ (RealEstateAgent assignCollapseFrameFor: self). self bounds: collapsedFrame]. self layoutChanged! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 3/27/2000 09:05'! doFastWindowReframe: ptName | newBounds | "For fast display, only higlight the rectangle during loop" newBounds _ self bounds newRectFrom: [:f | f withSideOrCorner: ptName setToPoint: (self pointFromWorld: Sensor cursorPoint) minExtent: self minimumExtent]. self bounds: newBounds! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'ar 2/10/1999 04:20'! expand self isCollapsed ifTrue:[self collapseOrExpand]! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'jm 10/15/2002 15:24'! fastFramingOn ^ Preferences fastDragWindowForMorphic ! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/21/1998 16:12'! paneWithLongestSide: sideBlock near: aPoint | thePane theSide theLen box | theLen _ 0. paneMorphs do: [:pane | box _ pane bounds. box forPoint: aPoint closestSideDistLen: [:side :dist :len | (dist <= 5 and: [len > theLen]) ifTrue: [thePane _ pane. theSide _ side. theLen _ len]]]. sideBlock value: theSide. ^ thePane! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'di 10/22/1998 22:55'! reframePanesAdjoining: growingPane along: side to: aDisplayBox | delta newRect minDim theMin horiz | growingPane ifNil: [^ self]. "As from click outside" newRect _ aDisplayBox. horiz _ #(left right) includes: side. theMin _ horiz ifTrue: [40] ifFalse: [20]. "First check that this won't make any pane smaller than theMin screen dots" minDim _ (((paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side]) collect: [:pane | pane bounds adjustTo: newRect along: side]) copyWith: aDisplayBox) inject: 999 into: [:was :rect | was min: (horiz ifTrue: [rect width] ifFalse: [rect height])]. "If so, amend newRect as required" minDim > theMin ifFalse: [delta _ minDim - theMin. newRect _ newRect withSide: side setTo: ((newRect perform: side) > (growingPane bounds perform: side) ifTrue: [(newRect perform: side) + delta] ifFalse: [(newRect perform: side) - delta])]. "Now adjust all adjoining panes for real" paneMorphs do: [:pane | (pane bounds bordersOn: growingPane bounds along: side) ifTrue: [pane bounds: (pane bounds adjustTo: newRect along: side)]]. "And adjust the growing pane itself" growingPane bounds: newRect. "Finally force a recomposition of the whole window" self setPaneRectsFromBounds. self extent: self extent! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'bf 1/5/2000 19:38'! spawnPaneFrameHandle: event | resizer localPt side growingPane newBounds adjoiningPanes limit | (self world firstSubmorph isKindOf: NewHandleMorph) ifTrue: [ ^ self "Prevent multiple handles"]. ((self innerBounds withHeight: self labelHeight+4) containsPoint: event cursorPoint) ifTrue: [^ self "in label or top of top pane"]. growingPane _ self paneWithLongestSide: [:s | side _ s] near: event cursorPoint. growingPane ifNil: [^ self]. adjoiningPanes _ paneMorphs select: [:pane | pane bounds bordersOn: growingPane bounds along: side]. limit _ adjoiningPanes isEmpty ifFalse: [ (adjoiningPanes collect: [:pane | pane bounds perform: side]) perform: ((#(top left) includes: side) ifTrue: [#max] ifFalse: [#min])] ifTrue: [self bounds perform: side]. resizer _ NewHandleMorph new followHand: event hand forEachPointDo: [:p | localPt _ self pointFromWorld: p. newBounds _ growingPane bounds withSideOrCorner: side setToPoint: localPt minExtent: 40@20 limit: limit. self fastFramingOn ifTrue: ["For fast display, only higlight the rectangle during loop" newBounds _ growingPane bounds newRectFrom: [:f | growingPane bounds withSideOrCorner: side setToPoint: (self pointFromWorld: Sensor cursorPoint) minExtent: 40@20 limit: limit]. self reframePanesAdjoining: growingPane along: side to: newBounds] ifFalse: [self reframePanesAdjoining: growingPane along: side to: newBounds]] lastPointDo: [:p | ]. event hand world addMorph: resizer. resizer startStepping! ! !SystemWindow methodsFor: 'resize/collapse' stamp: 'jlb 3/27/2000 09:05'! spawnReframeHandle: event "The mouse has crossed a pane border. Spawn a reframe handle." | resizer localPt pt ptName newBounds | allowReframeHandles ifFalse: [^ self]. owner ifNil: [^ self "Spurious mouseLeave due to delete"]. (self isActive not or: [self isCollapsed]) ifTrue: [^ self]. ((self world ifNil: [^ self]) firstSubmorph isKindOf: NewHandleMorph) ifTrue: [^ self "Prevent multiple handles"]. paneMorphs do: [:p | ((p fullBounds insetBy: 1) containsPoint: event cursorPoint) ifTrue: [^ self "Don't activate resizer if in a scrollbar"]]. pt _ event cursorPoint. self bounds forPoint: pt closestSideDistLen: [:side :dist :len | "Check for window side adjust" dist <= 2 ifTrue: [ptName _ side]]. ptName ifNil: ["Check for pane border adjust" ^ self spawnPaneFrameHandle: event]. #(topLeft bottomRight bottomLeft topRight) do: [:corner | "Check for window corner adjust" (pt dist: (self bounds perform: corner)) < 20 ifTrue: [ptName _ corner]]. resizer _ NewHandleMorph new followHand: event hand forEachPointDo: [:p | localPt _ self pointFromWorld: p. newBounds _ self bounds withSideOrCorner: ptName setToPoint: localPt minExtent: self minimumExtent. self fastFramingOn ifTrue: [self doFastWindowReframe: ptName] ifFalse: [self bounds: newBounds. (Preferences roundedWindowCorners and: [#(bottom right bottomRight) includes: ptName]) ifTrue: ["Complete kluge: causes rounded corners to get painted correctly, in spite of not working with top-down displayWorld." ptName = #bottom ifFalse: [self invalidRect: (self bounds topRight - (6@0) extent: 7@7)]. ptName = #right ifFalse: [self invalidRect: (self bounds bottomLeft - (0@6) extent: 7@7)]. self invalidRect: (self bounds bottomRight - (6@6) extent: 7@7)]]] lastPointDo: [:p | ]. event hand world addMorph: resizer. resizer startStepping! ! !SystemWindow methodsFor: 'top window' stamp: 'jm 7/19/2003 15:32'! activate "Bring me to the front and make me able to respond to mouse and keyboard." | oldTop | self owner ifNil: [^ self "avoid spurious activate when dropped into trash"]. oldTop _ TopWindow. TopWindow _ self. oldTop ifNotNil: [oldTop passivate]. self owner firstSubmorph == self ifFalse: [ "bring me to the front if not already" self owner addMorphFront: self]. self submorphsDo: [:m | m isLocked: false]. self setStripeColorsFrom: self paneColorToUse. self isCollapsed ifFalse: [ model modelWakeUpIn: self. self positionSubmorphs]. ! ! !SystemWindow methodsFor: 'top window' stamp: 'sw 5/10/1999 15:42'! activateAndForceLabelToShow self activate. bounds top < 0 ifTrue: [self position: (self position x @ 0)]! ! !SystemWindow methodsFor: 'top window' stamp: 'sw 10/25/1999 23:51'! passivate "Make me unable to respond to mouse and keyboard" self setStripeColorsFrom: self paneColorToUse. model modelSleep. self submorphsDo: [:m | (m == closeBox or: [m == collapseBox]) ifTrue: ["Control boxes remain active, except in novice mode" Preferences noviceMode ifTrue: [m lock]] ifFalse: [m lock]]. self world ifNotNil: "clean damage now, so dont merge this rect with new top window" [self world == World ifTrue: [self world displayWorld]]! ! !SystemWindow methodsFor: 'panes' stamp: 'di 10/13/1999 22:03'! addMorph: aMorph frame: relFrame | panelRect | self addMorph: aMorph. paneMorphs _ paneMorphs copyReplaceFrom: 1 to: 0 with: (Array with: aMorph). paneRects _ paneRects copyReplaceFrom: 1 to: 0 with: (Array with: relFrame). panelRect _ self panelRect. (aMorph isKindOf: BorderedMorph) ifTrue: [aMorph borderWidth: 1]. aMorph color: self paneColor; bounds: ((relFrame scaleBy: panelRect extent) translateBy: panelRect topLeft) truncated. ! ! !SystemWindow methodsFor: 'panes' stamp: 'jm 6/15/2003 17:07'! existingPaneColor "Answer the existing pane color for the window, obtaining it from the first paneMorph if any/ Fall back on using the second stripe color if necessary." | aColor | paneMorphs isEmptyOrNil ifFalse: [ ((aColor _ paneMorphs first color) isKindOf: Color) ifTrue: [^ aColor]]. ^ stripes second color ! ! !SystemWindow methodsFor: 'panes' stamp: 'jm 5/16/2003 09:33'! paneColor Display depth > 2 ifTrue: [ model ifNotNil: [^ Color colorFrom: model defaultBackgroundColor]. paneMorphs isEmptyOrNil ifFalse: [^ paneMorphs first color]]. ^ Color white ! ! !SystemWindow methodsFor: 'panes' stamp: 'jm 6/15/2003 17:09'! paneColorToUse ^ Display depth <= 2 ifTrue: [Color white] ifFalse: [self existingPaneColor ifNil: [self paneColor]] ! ! !SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:44'! paneMorphSatisfying: aBlock ^ paneMorphs detect: [:aPane | aBlock value: aPane] ifNone: [nil]! ! !SystemWindow methodsFor: 'panes' stamp: 'sw 10/26/1999 00:36'! restoreDefaultPaneColor "Useful when changing from monochrome to color display" self setStripeColorsFrom: self paneColor. paneMorphs do: [:p | p color: self paneColor]. ! ! !SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:50'! setUpdatablePanesFrom: getSelectors | aList aPane | "Set my updatablePanes inst var to the list of panes which are list panes with the given get-list selectors. Order is important here!! Note that the method is robust in the face of panes not found, but a warning is printed in the transcript in each such case" aList _ OrderedCollection new. getSelectors do: [:sel | aPane _ self paneMorphSatisfying: [:pane | (pane isKindOf: PluggableListMorph) and: [pane getListSelector == sel]]. aPane ifNotNil: [aList add: aPane] ifNil: [Transcript cr; show: 'Warning: pane ', sel, ' not found.']]. updatablePanes _ aList asArray! ! !SystemWindow methodsFor: 'panes' stamp: 'sw 10/19/1999 09:53'! updatablePanes "Answer the list of panes, in order, which should be sent the #verifyContents message" ^ updatablePanes ifNil: [updatablePanes _ #()]! ! !SystemWindow methodsFor: 'panes' stamp: 'sw 10/25/1999 23:52'! updatePaneColors "Useful when changing from monochrome to color display" self setStripeColorsFrom: self paneColorToUse. paneMorphs do: [:p | p color: self paneColorToUse]. ! ! !SystemWindow methodsFor: 'events' stamp: 'jm 7/19/2003 15:43'! doFastFrameDrag "Drag me to a new position and make sure I'm in front." | offset newBounds | offset _ self position - Sensor cursorPoint. newBounds _ self bounds newRectFrom: [:f | Sensor cursorPoint + offset extent: self extent]. self position: newBounds topLeft. self owner firstSubmorph == self ifFalse: [ "bring me to the front if not already" self owner addMorphFront: self]. ! ! !SystemWindow methodsFor: 'events' stamp: 'di 10/28/1999 13:22'! handlesMouseDown: evt "If I am not the topWindow, then I will only respond to dragging by the title bar. Any other click will only bring me to the top" (self fastFramingOn and: [self labelRect containsPoint: evt cursorPoint]) ifTrue: [^ true]. ^ self activeOnlyOnTop and: [self ~~ TopWindow]! ! !SystemWindow methodsFor: 'events' stamp: 'jm 10/10/2002 15:53'! handlesMouseOver: evt ^ true ! ! !SystemWindow methodsFor: 'events' stamp: 'jm 10/15/2002 17:26'! mouseDown: evt | cp | TopWindow == self ifFalse: [self activate]. (Sensor redButtonPressed and: [self labelRect containsPoint: evt cursorPoint]) ifTrue: [ "if mouse still down after activate:" ^ self isSticky ifFalse: [ self fastFramingOn ifTrue: [self doFastFrameDrag] ifFalse: [evt hand grabMorph: self]]]. model windowActiveOnFirstClick ifTrue: [ "Normally, window keeps control of first click. Need explicit transmission for first-click activity." cp _ evt cursorPoint. submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseDown: evt]]] ! ! !SystemWindow methodsFor: 'events' stamp: 'jm 10/10/2002 15:54'! mouseEnter: evt self spawnReframeHandle: evt. ! ! !SystemWindow methodsFor: 'events' stamp: 'jm 10/10/2002 15:54'! mouseLeave: evt self spawnReframeHandle: evt. ! ! !SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'! mouseMove: evt | cp | model windowActiveOnFirstClick ifTrue: ["Normally window takes control on first click. Need explicit transmission for first-click activity." cp _ evt cursorPoint. submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseMove: evt]]]! ! !SystemWindow methodsFor: 'events' stamp: 'di 6/10/1998 14:41'! mouseUp: evt | cp | model windowActiveOnFirstClick ifTrue: ["Normally window takes control on first click. Need explicit transmission for first-click activity." cp _ evt cursorPoint. submorphs do: [:m | (m containsPoint: cp) ifTrue: [m mouseUp: evt]]]! ! !SystemWindow methodsFor: 'events' stamp: 'di 10/23/1998 09:22'! paneTransition: event "Mouse has entered or left a pane" ^ self spawnReframeHandle: event! ! !SystemWindow methodsFor: 'events' stamp: 'sw 12/22/1999 18:31'! wantsHalo ^ false! ! !SystemWindow methodsFor: 'events' stamp: 'sw 4/18/2000 09:06'! wantsHaloFromClick ^ true! ! !SystemWindow methodsFor: 'events' stamp: 'sw 5/9/2000 02:33'! willingToBeEmbeddedUponLanding ^ Preferences systemWindowEmbedOK! ! !SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 09:30'! amendSteppingStatus "Circumstances having changed, find out whether stepping is wanted and assure that the new policy is carried out" self wantsSteps ifTrue: [self arrangeToStartStepping] ifFalse: [self stopStepping]! ! !SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:16'! step model ifNotNil: [model stepIn: self]! ! !SystemWindow methodsFor: 'stepping' stamp: 'sw 10/20/1999 15:48'! stepAt: millisecondClockValue model ifNotNil: [model stepAt: millisecondClockValue in: self]! ! !SystemWindow methodsFor: 'stepping' stamp: 'sw 10/19/1999 08:22'! stepTime ^ model ifNotNil: [model stepTimeIn: self] ifNil: [200] "milliseconds"! ! !SystemWindow methodsFor: 'stepping' stamp: 'jm 10/7/2002 07:54'! wantsSteps "Return true if the model wants its view to be stepped." self isPartsDonor ifTrue: [^ false]. ^ model wantsStepsIn: self ! ! !SystemWindow methodsFor: 'drawing' stamp: 'di 8/16/1998 01:14'! areasRemainingToFill: aRectangle | areas | (areas _ super areasRemainingToFill: aRectangle) isEmpty ifTrue: [^ areas "good news -- complete occlusion"]. "Check for special case that this is scrollbar damage" ((bounds topLeft - (14@0) corner: bounds bottomRight) containsRect: aRectangle) ifTrue: [paneMorphs do: [:p | ((p isKindOf: ScrollPane) and: [p scrollBarFills: aRectangle]) ifTrue: [^ Array new]]]. ^ areas! ! !SystemWindow methodsFor: 'drawing' stamp: 'sw 11/29/1999 18:01'! fullDrawOn: aCanvas Preferences roundedWindowCorners ifTrue: [CornerRounder roundCornersOf: self on: aCanvas displayBlock: [aCanvas drawMorph: self. self basicFullDrawOn: aCanvas] borderWidth: 2] ifFalse: [super fullDrawOn: aCanvas]! ! !SystemWindow methodsFor: 'drawing' stamp: 'mir 5/30/2000 17:20'! makeMeVisible self world extent > (0@0) ifFalse: [^ self]. ((self world bounds insetBy: (0@0 corner: self labelHeight asPoint)) containsPoint: self position) ifTrue: [^ self "OK -- at least my top left is visible"]. "window not on screen (probably due to reframe) -- move it now" self isCollapsed ifTrue: [self position: (RealEstateAgent assignCollapsePointFor: self)] ifFalse: [self position: (RealEstateAgent initialFrameFor: self initialExtent: self extent) topLeft].! ! !SystemWindow methodsFor: 'drawing' stamp: 'di 3/25/2000 10:55'! wantsRoundedCorners ^ Preferences roundedWindowCorners or: [super wantsRoundedCorners]! ! !SystemWindow methodsFor: 'menu' stamp: 'di 5/10/1999 23:37'! addCustomMenuItems: aCustomMenu hand: aHandMorph super addCustomMenuItems: aCustomMenu hand: aHandMorph. "template..." aCustomMenu addLine. aCustomMenu add: 'edit label...' action: #relabel.. ! ! !SystemWindow methodsFor: 'menu' stamp: 'jm 10/11/2002 07:08'! buildWindowMenu | aMenu | aMenu _ MenuMorph new defaultTarget: self. aMenu add: 'change title...' action: #relabel. aMenu addLine. aMenu add: 'send to back' action: #sendToBack. aMenu addLine. self mustNotClose ifFalse: [aMenu add: 'make unclosable' action: #makeUnclosable] ifTrue: [aMenu add: 'make closable' action: #makeClosable]. aMenu add: (self isSticky ifTrue: ['make draggable'] ifFalse: ['make undraggable']) action: #toggleStickiness. aMenu addLine. aMenu add: 'full screen' action: #fullScreen. self isCollapsed ifFalse: [aMenu add: 'window color...' action: #setWindowColor]. ^aMenu! ! !SystemWindow methodsFor: 'menu' stamp: 'jm 10/5/2002 07:20'! fullScreen self bounds: self world bounds. ! ! !SystemWindow methodsFor: 'menu' stamp: 'sw 9/28/1999 13:53'! makeClosable mustNotClose _ false. closeBox ifNil: [self addCloseBox. self extent: self extent]! ! !SystemWindow methodsFor: 'menu' stamp: 'sw 9/28/1999 13:52'! makeUnclosable mustNotClose _ true. closeBox ifNotNil: [closeBox delete. closeBox _ nil]! ! !SystemWindow methodsFor: 'menu' stamp: 'sma 6/5/2000 13:34'! offerWindowMenu | aMenu | aMenu _ self buildWindowMenu. model ifNotNil: [model addModelItemsToWindowMenu: aMenu]. aMenu popUpEvent: self currentEvent! ! !SystemWindow methodsFor: 'menu' stamp: 'jm 10/11/2002 07:08'! sendToBack | aWorld nextWindow | aWorld _ self world. nextWindow _ aWorld submorphs detect: [:m | (m isKindOf: SystemWindow) and: [m ~~ self]] ifNone: [^ self]. nextWindow activate. aWorld addMorphBack: self. ! ! !SystemWindow methodsFor: 'menu' stamp: 'sw 10/26/1999 00:00'! setWindowColor ColorPickerMorph new sourceHand: self activeHand; target: self; selector: #setWindowColor:; originalColor: self paneColorToUse; addToWorld: self world near: self fullBounds! ! !SystemWindow methodsFor: 'menu' stamp: 'sw 10/27/1999 11:28'! setWindowColor: incomingColor | existingColor aColor | incomingColor ifNil: [^ self]. "it happens" aColor _ incomingColor asNontranslucentColor. (aColor = ColorPickerMorph perniciousBorderColor or: [aColor = Color black]) ifTrue: [^ self]. existingColor _ self paneColorToUse. existingColor ifNil: [^ self beep]. (self allMorphs copyWithout: self) do: [:aMorph | ((aMorph isKindOf: PluggableButtonMorph) and: [aMorph offColor = existingColor]) ifTrue: [aMorph onColor: aColor darker offColor: aColor]. aMorph color = existingColor ifTrue: [aMorph color: aColor]]. self setStripeColorsFrom: aColor ! ! !SystemWindow methodsFor: '-- all --' stamp: 'jm 7/19/2003 15:41'! justDroppedInto: aMorph event: anEvent isCollapsed ifTrue: [ self position: ((self position max: 0@0) grid: 8@8). collapsedFrame _ self bounds] ifFalse: [ fullFrame _ self bounds. TopWindow ~~ self ifTrue: [self activate]]. ! ! !SystemWindow class methodsFor: 'top window' stamp: 'jm 10/11/2002 08:20'! clearTopWindow TopWindow _ nil. ! ! !SystemWindow class methodsFor: 'top window' stamp: 'di 9/26/1999 22:48'! noteTopWindowIn: aWorld | newTop | "TopWindow must be nil or point to the top window in this project." TopWindow _ nil. aWorld ifNil: [^ self]. newTop _ nil. aWorld submorphsDo: [:m | (m isKindOf: SystemWindow) ifTrue: [(newTop == nil and: [m activeOnlyOnTop]) ifTrue: [newTop _ m]. (m model isKindOf: Project) ifTrue: ["This really belongs in a special ProjWindow class" m label ~= m model name ifTrue: [m setLabel: m model name]]]]. newTop == nil ifFalse: [newTop activate]! ! !SystemWindow class methodsFor: 'top window' stamp: 'sw 1/4/2000 15:22'! wakeUpTopWindowUponStartup TopWindow ifNotNil: [TopWindow isCollapsed ifFalse: [TopWindow model ifNotNil: [TopWindow model modelWakeUpIn: TopWindow]]]! ! !SystemWindow class methodsFor: 'top window' stamp: 'jm 10/15/2002 15:30'! windowsIn: aWorld satisfying: windowBlock | windows | windows _ OrderedCollection new. aWorld submorphs do: [:m | ((m isKindOf: SystemWindow) and: [windowBlock value: m]) ifTrue: [windows addLast: m]]. ^ windows ! ! !TAssignmentNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:14'! bindVariableUsesIn: aDictionary "Do NOT bind the variable on the left-hand-side of an assignment statement." expression _ expression bindVariablesIn: aDictionary. ! ! !TAssignmentNode methodsFor: 'all'! bindVariablesIn: aDictionary variable _ variable bindVariablesIn: aDictionary. expression _ expression bindVariablesIn: aDictionary.! ! !TAssignmentNode methodsFor: 'all'! copyTree ^self class new setVariable: variable copyTree expression: expression copyTree! ! !TAssignmentNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen | sel | self isVariableUpdatingAssignment ifTrue: [ variable emitCCodeOn: aStream level: level generator: aCodeGen. sel _ expression selector. sel = #+ ifTrue: [aStream nextPutAll: ' += '] ifFalse: [aStream nextPutAll: ' -= ']. expression args first emitCCodeOn: aStream level: level generator: aCodeGen. ] ifFalse: [ variable emitCCodeOn: aStream level: level generator: aCodeGen. aStream nextPutAll: ' = '. expression emitCCodeOn: aStream level: level generator: aCodeGen. ].! ! !TAssignmentNode methodsFor: 'all'! expression ^expression! ! !TAssignmentNode methodsFor: 'all'! inlineMethodsUsing: aDictionary variable inlineMethodsUsing: aDictionary. expression inlineMethodsUsing: aDictionary.! ! !TAssignmentNode methodsFor: 'all'! isAssignment ^true! ! !TAssignmentNode methodsFor: 'all'! isVariableUpdatingAssignment "Return true if this assignment statement is of one of the forms: var = var + ... var = var - ... Such assignments statements can exploit the C updating assignment operators. For example, 'x += 4' can be generated instead of 'x = x + 4'. This produces better code under some C compilers, most notably the CodeWarrior 68K compiler." | sel | (expression isSend and: [expression receiver isVariable]) ifFalse: [^ false]. sel _ expression selector. ^ (expression receiver name = variable name) and: [(sel = #+) or: [sel = #-]]! ! !TAssignmentNode methodsFor: 'all'! nodesDo: aBlock variable nodesDo: aBlock. expression nodesDo: aBlock. aBlock value: self.! ! !TAssignmentNode methodsFor: 'all'! printOn: aStream level: level variable printOn: aStream level: level. aStream nextPutAll: ' _ '. expression printOn: aStream level: level + 2.! ! !TAssignmentNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions expression removeAssertions! ! !TAssignmentNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [ variable _ variable replaceNodesIn: aDictionary. expression _ expression replaceNodesIn: aDictionary. self]! ! !TAssignmentNode methodsFor: 'all'! setVariable: varNode expression: expressionNode variable _ varNode. expression _ expressionNode.! ! !TAssignmentNode methodsFor: 'all'! variable ^variable! ! !TCaseStmtNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:26'! bindVariableUsesIn: aDictionary expression _ expression bindVariableUsesIn: aDictionary. cases _ cases collect: [ :c | c bindVariableUsesIn: aDictionary ].! ! !TCaseStmtNode methodsFor: 'all'! bindVariablesIn: aDictionary expression _ expression bindVariablesIn: aDictionary. cases _ cases collect: [ :c | c bindVariablesIn: aDictionary ].! ! !TCaseStmtNode methodsFor: 'all'! cases ^cases! ! !TCaseStmtNode methodsFor: 'all'! copyTree ^self class new setExpression: expression copyTree firsts: firsts copy lasts: lasts copy cases: (cases collect: [ :case | case copyTree ])! ! !TCaseStmtNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:27'! customizeCase: caseParseTree forVar: varName from: firstIndex to: lastIndex "Return a collection of copies of the given parse tree, each of which has the value of the case index substituted for the given variable." | newCases dict newCase | newCases _ OrderedCollection new. firstIndex to: lastIndex do: [ :caseIndex | dict _ Dictionary new. dict at: varName put: (TConstantNode new setValue: caseIndex). newCase _ caseParseTree copyTree bindVariableUsesIn: dict. self fixSharedCodeBlocksForCase: caseIndex in: newCase. newCases addLast: newCase. ]. ^ newCases! ! !TCaseStmtNode methodsFor: 'all' stamp: 'jm 12/11/1998 07:49'! customizeShortCasesForDispatchVar: varName "Make customized versions of a short bytecode methods, substituting a constant having the case index value for the given variable. This produces better code for short bytecodes such as instance variable pushes that encode the index of the instance variable in the bytecode." | newFirsts newLasts newCases l f case expanded | newFirsts _ OrderedCollection new. newLasts _ OrderedCollection new. newCases _ OrderedCollection new. 1 to: cases size do: [ :i | l _ lasts at: i. f _ firsts at: i. case _ cases at: i. expanded _ false. (l - f) > 1 ifTrue: [ "case code covers multiple cases" case nodeCount < 60 ifTrue: [ newFirsts addAll: (f to: l) asArray. newLasts addAll: (f to: l) asArray. newCases addAll: (self customizeCase: case forVar: varName from: f to: l). expanded _ true. ]. ]. expanded ifFalse: [ self fixSharedCodeBlocksForCase: f in: case. newFirsts addLast: f. newLasts addLast: l. newCases addLast: case. ]. ]. firsts _ newFirsts asArray. lasts _ newLasts asArray. cases _ newCases asArray. ! ! !TCaseStmtNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen | indent | indent _ (String new: level) collect: [ :ch | Character tab ]. aStream nextPutAll: 'switch ('. expression emitCCodeOn: aStream level: level generator: aCodeGen. aStream nextPutAll: ') {'; cr. 1 to: cases size do: [ :i | (firsts at: i) to: (lasts at: i) do: [ :caseIndex | aStream nextPutAll: indent, 'case ', caseIndex printString, ':'; cr. ]. (cases at: i) emitCCodeOn: aStream level: level + 1 generator: aCodeGen. aStream nextPutAll: indent; tab; nextPutAll: 'break;'. aStream cr. ]. level timesRepeat: [ aStream tab ]. aStream nextPutAll: '}'.! ! !TCaseStmtNode methodsFor: 'all'! expression ^expression! ! !TCaseStmtNode methodsFor: 'all' stamp: 'di 12/14/1998 22:22'! fixSharedCodeBlocksForCase: caseIndex in: caseParseTree "Process 'sharedCode' directives in the given parse tree. The sharedCode directive allows code replicated in different arms of a case statement to be shared. The replicated code must be the final code of the case so that it ends with a break out of the case statement. The replicated code will be generated in exactly one arm of the case statement; other instances of the shared code will be replaced by branches to that single instance of the code." "NOTE: I have made this work for the nested case (ie several shared entry points in the same case, but it does not really work for methods with arguments. A mechanism coud be added that would add a preamble of the form, innerSharedTemp = outerTemp; when they differed. There should at least be a test here." | copying oldStmts newStmts stmt codeBlockName | caseParseTree nodesDo: [ :node | node isStmtList ifTrue: [ copying _ true. oldStmts _ node statements asArray. newStmts _ nil. "becomes an OrderedCollection if sharedCode block is found" 1 to: oldStmts size do: [ :i | copying ifTrue: [ stmt _ oldStmts at: i. (stmt isSend and: [stmt selector = #sharedCodeNamed:inCase:]) ifTrue: [ newStmts == nil ifTrue: [newStmts _ (oldStmts copyFrom: 1 to: i - 1) asOrderedCollection] ifFalse: [newStmts removeLast "preserve any prior shared entry points - di"]. codeBlockName _ stmt args first value. (stmt args last value = caseIndex) ifTrue: [ newStmts add: (TLabeledCommentNode new setLabel: codeBlockName comment: ''). ] ifFalse: [ newStmts add: (TGoToNode new setLabel: codeBlockName). copying _ false. "don't copy remaining statements" ]. ] ifFalse: [ newStmts = nil ifFalse: [newStmts add: stmt]. ]. ] ifFalse: [ "ikp: this permits explicit returns before 'goto aSharedCodeLabel'" stmt _ oldStmts at: i. (stmt isLabel and: [stmt label ~= nil]) ifTrue: [newStmts add: stmt]. ]. ]. newStmts = nil ifFalse: [node setStatements: newStmts]. ]. ].! ! !TCaseStmtNode methodsFor: 'all'! inlineMethodsUsing: aDictionary expression inlineMethodsUsing: aDictionary. cases do: [ :c | c inlineMethodsUsing: aDictionary ].! ! !TCaseStmtNode methodsFor: 'all'! isCaseStmt ^true! ! !TCaseStmtNode methodsFor: 'all'! nodesDo: aBlock expression nodesDo: aBlock. cases do: [ :c | c nodesDo: aBlock ]. aBlock value: self.! ! !TCaseStmtNode methodsFor: 'all'! printOn: aStream level: level aStream crtab: level. aStream nextPutAll: 'select '. expression printOn: aStream level: level. aStream nextPutAll: ' in'. 1 to: cases size do: [ :i | (firsts at: i) to: (lasts at: i) do: [ :caseIndex | aStream crtab: level. aStream nextPutAll: 'case ', caseIndex printString, ':'. ]. aStream crtab: level + 1. (cases at: i) printOn: aStream level: level + 1. ]. aStream crtab: level. aStream nextPutAll: 'end select'.! ! !TCaseStmtNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions expression removeAssertions. cases do: [ :case | case removeAssertions ].! ! !TCaseStmtNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [ expression _ expression replaceNodesIn: aDictionary. cases _ cases collect: [ :c | c replaceNodesIn: aDictionary ]. self]! ! !TCaseStmtNode methodsFor: 'all'! setExpression: aNode firsts: firstsList lasts: lastsList cases: caseList expression _ aNode. firsts _ firstsList. lasts _ lastsList. cases _ caseList.! ! !TCaseStmtNode methodsFor: 'all'! setExpression: aNode selectors: selectorList "Initialize the node from the given set of selectors." "Note: Each case is a statement list with containing one statement, a send to self of a selector from the given selector list. Having statement list nodes makes inlining easier later." | selfNode stmt lastSel firstInRun sel | expression _ aNode. selfNode _ TVariableNode new setName: 'self'. firsts _ OrderedCollection new: 400. lasts _ OrderedCollection new: 400. cases _ OrderedCollection new: 400. lastSel _ selectorList first. firstInRun _ 0. 1 to: selectorList size do: [ :i | sel _ selectorList at: i. sel ~= lastSel ifTrue: [ firsts add: firstInRun. lasts add: i - 2. stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: #(). cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)). lastSel _ sel. firstInRun _ i - 1. ]. ]. firsts add: firstInRun. lasts add: selectorList size - 1. stmt _ TSendNode new setSelector: lastSel receiver: selfNode arguments: #(). cases add: (TStmtListNode new setArguments: #() statements: (Array with: stmt)).! ! !TConstantNode methodsFor: 'all'! copyTree ^self class new setValue: value! ! !TConstantNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen "Emit a C literal." aStream nextPutAll: (aCodeGen cLiteralFor: value).! ! !TConstantNode methodsFor: 'all'! isConstant ^true! ! !TConstantNode methodsFor: 'all'! isLeaf ^true! ! !TConstantNode methodsFor: 'all'! printOn: aStream level: level value storeOn: aStream.! ! !TConstantNode methodsFor: 'all'! setValue: anObject value _ anObject.! ! !TConstantNode methodsFor: 'all'! value ^value! ! !TGoToNode methodsFor: 'all'! copyTree ^self class new setLabel: label! ! !TGoToNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen "Emit a C goto statement." aStream nextPutAll: 'goto '. aStream nextPutAll: label.! ! !TGoToNode methodsFor: 'all'! isGoTo ^true! ! !TGoToNode methodsFor: 'all'! label ^label! ! !TGoToNode methodsFor: 'all'! printOn: aStream level: level aStream nextPutAll: 'goto '. aStream nextPutAll: label.! ! !TGoToNode methodsFor: 'all'! setLabel: aString label _ aString.! ! !TLabeledCommentNode methodsFor: 'all'! copyTree ^self class new setLabel: label comment: comment! ! !TLabeledCommentNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen "Emit a C comment with optional label." self printOptionalLabelOn: aStream. aStream nextPutAll: '/* '. aStream nextPutAll: comment. aStream nextPutAll: ' */'.! ! !TLabeledCommentNode methodsFor: 'all'! isComment "Answer true if the receiver is just a comment (i.e., it has no label)." ^label = nil! ! !TLabeledCommentNode methodsFor: 'all'! isLabel ^true! ! !TLabeledCommentNode methodsFor: 'all'! isLeaf ^true! ! !TLabeledCommentNode methodsFor: 'all'! label ^label! ! !TLabeledCommentNode methodsFor: 'all'! printOn: aStream level: level self printOptionalLabelOn: aStream. aStream nextPut: $". aStream nextPutAll: comment. aStream nextPut: $".! ! !TLabeledCommentNode methodsFor: 'all'! printOptionalLabelOn: aStream label ~= nil ifTrue: [ self unindentOneTab: aStream. aStream nextPutAll: label. aStream nextPut: $:. aStream tab. ].! ! !TLabeledCommentNode methodsFor: 'all'! setComment: commentString label _ nil. comment _ commentString.! ! !TLabeledCommentNode methodsFor: 'all'! setLabel: labelString label _ labelString.! ! !TLabeledCommentNode methodsFor: 'all'! setLabel: labelString comment: commentString label _ labelString. comment _ commentString.! ! !TLabeledCommentNode methodsFor: 'all'! unindentOneTab: aStream "Remove the last tab from the given stream if possible." (aStream isKindOf: ReadWriteStream) ifFalse: [ ^self ]. aStream position > 0 ifTrue: [ aStream position: aStream position - 1. "restore stream position if previous char was not a tab" aStream peek = Character tab ifFalse: [ aStream next ]. ].! ! !TMethod methodsFor: 'initialization' stamp: 'ar 9/18/1998 23:24'! setSelector: sel args: argList locals: localList block: aBlockNode primitive: aNumber "Initialize this method using the given information." selector _ sel. returnType _ 'int'. "assume return type is int for now" args _ argList asOrderedCollection collect: [:arg | arg key]. locals _ localList asOrderedCollection collect: [:arg | arg key]. declarations _ Dictionary new. primitive _ aNumber. parseTree _ aBlockNode asTranslatorNode. labels _ OrderedCollection new. complete _ false. "set to true when all possible inlining has been done" export _ self extractExportDirective. self removeFinalSelfReturn. self recordDeclarations. ! ! !TMethod methodsFor: 'initialization' stamp: 'jm 2/12/98 11:55'! setSelector: sel returnType: retType args: argList locals: localList declarations: decls primitive: primNumber parseTree: aNode labels: labelList complete: completeFlag "Initialize this method using the given information. Used for copying." selector _ sel. returnType _ retType. args _ argList. locals _ localList. declarations _ decls. primitive _ primNumber. parseTree _ aNode. labels _ labelList. complete _ completeFlag.! ! !TMethod methodsFor: 'accessing'! args "The arguments of this method." ^args! ! !TMethod methodsFor: 'accessing'! declarations "The type declaration dictionary of this method." ^declarations! ! !TMethod methodsFor: 'accessing' stamp: 'jm 11/24/1998 09:03'! export ^ export ! ! !TMethod methodsFor: 'accessing'! isComplete "A method is 'complete' if it does not contain any more inline-able calls." ^complete! ! !TMethod methodsFor: 'accessing'! labels ^labels! ! !TMethod methodsFor: 'accessing'! locals "The local variables of this method." ^locals! ! !TMethod methodsFor: 'accessing'! parseTree "The parse tree of this method." ^parseTree! ! !TMethod methodsFor: 'accessing'! parseTree: aNode "Set the parse tree of this method." parseTree _ aNode.! ! !TMethod methodsFor: 'accessing' stamp: 'jm 2/12/98 11:56'! primitive "The primitive number of this method; zero if not a primitive." ^ primitive ! ! !TMethod methodsFor: 'accessing'! returnType "The type of the values returned by this method. This string will be used in the C declaration of this function." ^returnType! ! !TMethod methodsFor: 'accessing'! selector "The Smalltalk selector of this method." ^selector! ! !TMethod methodsFor: 'accessing'! selector: newSelector selector _ newSelector.! ! !TMethod methodsFor: 'accessing'! statements parseTree isStmtList ifFalse: [ self error: 'expected method parse tree to be a TStmtListNode' ]. ((parseTree args = nil) or: [parseTree args isEmpty]) ifFalse: [ self error: 'expected method parse tree to have no args' ]. ^parseTree statements! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 16:39'! argConversionExprFor: varName stackIndex: stackIndex "Return the parse tree for an expression that fetches and converts the primitive argument at the given stack offset." | exprList expr decl stmtList | exprList _ OrderedCollection new. expr _ '(self stackValue: ( ', stackIndex printString, '))'. (declarations includesKey: varName) ifTrue: [ "array" decl _ declarations at: varName. (decl includes: $*) ifTrue: [ exprList add: (varName, ' _ self arrayValueOf: ', expr). exprList add: (varName, ' _ ', varName, ' - 1'). ] ifFalse: [ "must be a double" ((decl findString: 'double' startingAt: 1) = 0) ifTrue: [ self error: 'unsupported type declaration in a primitive method' ]. exprList add: (varName, ' _ self floatValueOf: ', expr). ]. ] ifFalse: [ "undeclared variables are taken to be integer" exprList add: (varName, ' _ self checkedIntegerValueOf: ', expr). ]. stmtList _ OrderedCollection new. exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)]. ^ stmtList ! ! !TMethod methodsFor: 'primitive compilation'! checkSuccessExpr "Return the parse tree for an expression that aborts the primitive if the successFlag is not true." | expr | expr _ 'successFlag ifFalse: [^ nil ]'. ^ self statementsFor: expr varName: '' ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 16:48'! covertToZeroBasedArrayReferences "Replace the index expressions in at: and at:put: messages with (<expr> - 1), since C uses zero-based array indexing." "Note: Up through release 1.31, generated primitives used the convention that array variables pointed to the first element. That meant that Smalltalk one-based index expressions had to have one subtracted to yield a zero-based index. Later, we decided to adjust the base address by -1 once in the primitive prolog rather on every array access. This resulted in a five percent performance increase for the bitmap compress/decompress primitives. This method is retained as documentation and in case we choose to revert the the previous scheme." | oldIndexExpr newIndexExpr | parseTree nodesDo: [ :n | (n isSend and: [(n selector = #at:) or: [ n selector = #at:put: ]]) ifTrue: [ oldIndexExpr _ n args first. oldIndexExpr isConstant ifTrue: [ "index expression is a constant: decrement the constant now" newIndexExpr _ TConstantNode new setValue: (n args first value - 1). ] ifFalse: [ "index expression is complex: build an expression to decrement result at runtime" newIndexExpr _ TSendNode new setSelector: #- receiver: oldIndexExpr arguments: (Array with: (TConstantNode new setValue: 1)). ]. n args at: 1 put: newIndexExpr. ]. ]. ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'ikp 1/4/98 00:01'! fetchRcvrExpr "Return the parse tree for an expression that fetches the receiver from the stack." | expr | expr _ 'rcvr _ self stackValue: (', args size printString, ')'. ^ self statementsFor: expr varName: '' ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/20/98 11:08'! fixUpReturns: argCount postlog: postlog "Replace each return statement in this method with (a) the given postlog, (b) code to pop the receiver and the given number of arguments, and (c) code to push the integer result and return." | newStmts | parseTree nodesDo: [:node | node isStmtList ifTrue: [ newStmts _ OrderedCollection new: 100. node statements do: [:stmt | stmt isReturn ifTrue: [ (stmt expression isSend and: ['primitiveFail' = stmt expression selector]) ifTrue: [ "failure return" newStmts addLast: stmt expression. newStmts addLast: (TReturnNode new setExpression: (TVariableNode new setName: 'null'))] ifFalse: [ "normal return" newStmts addAll: postlog. newStmts addAll: (self popArgsExpr: argCount + 1). newStmts addLast: (TSendNode new setSelector: #pushInteger: receiver: (TVariableNode new setName: 'self') arguments: (Array with: stmt expression)). newStmts addLast: (TReturnNode new setExpression: (TVariableNode new setName: 'null'))]] ifFalse: [ newStmts addLast: stmt]]. node setStatements: newStmts asArray]]. ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 16:39'! instVarGetExprFor: varName offset: instIndex "Return the parse tree for an expression that fetches and converts the value of the instance variable at the given offset." | exprList decl stmtList | exprList _ OrderedCollection new. (declarations includesKey: varName) ifTrue: [ decl _ declarations at: varName. (decl includes: $*) ifTrue: [ "array" exprList add: (varName, ' _ self fetchArray: ', instIndex printString, ' ofObject: rcvr'). exprList add: (varName, ' _ ', varName, ' - 1'). ] ifFalse: [ "must be a double" ((decl findString: 'double' startingAt: 1) = 0) ifTrue: [ self error: 'unsupported type declaration in a primitive method' ]. exprList add: (varName, ' _ self fetchFloat: ', instIndex printString, ' ofObject: rcvr'). ]. ] ifFalse: [ "undeclared variables are taken to be integer" exprList add: (varName, ' _ self fetchInteger: ', instIndex printString, ' ofObject: rcvr'). ]. stmtList _ OrderedCollection new. exprList do: [:e | stmtList addAll: (self statementsFor: e varName: varName)]. ^ stmtList ! ! !TMethod methodsFor: 'primitive compilation'! instVarPutExprFor: varName offset: instIndex "Return the parse tree for an expression that saves the value of the integer instance variable at the given offset." | expr | (declarations includesKey: varName) ifTrue: [ self error: 'a primitive method can only modify integer instance variables'. ]. expr _ 'self storeInteger: ', instIndex printString, ' ofObject: rcvr withValue: ', varName. ^ self statementsFor: expr varName: varName ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/12/98 14:42'! popArgsExpr: argCount "Return the parse tree for an expression that pops the given number of arguments from the stack." | expr | expr _ 'self pop: ', argCount printString. ^ self statementsFor: expr varName: '' ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'ar 10/10/1998 23:36'! preparePrimitiveInClass: aClass "Add a prolog and postlog to a primitive method. The prolog copies any instance variables referenced by this primitive method into local variables. The postlog copies values of assigned-to variables back into the instance. The names of the new locals are added to the local variables list. The declarations dictionary defines the types of any non-integer variables (locals, arguments, or instance variables). In particular, it may specify the types: int * -- an array of 32-bit values (e.g., a BitMap) short * -- an array of 16-bit values (e.g., a SoundBuffer) char * -- an array of unsigned bytes (e.g., a String) double -- a double precision floating point number (e.g., 3.14159) Undeclared variables are taken to be integers and will be converted from Smalltalk to C ints." "Current restrictions: o method must not contain message sends o method must not allocate objects o method must not manipulate raw oops o method cannot access class variables o method can only return an integer" "ar 10/7/1998 -- Add the export directive for translated primitives. -- Use the name of the primitive if it's called by name." | prolog postlog instVarsUsed varsAssignedTo instVarList primArgCount varName endsWithReturn | prolog _ OrderedCollection new. postlog _ OrderedCollection new. instVarsUsed _ self freeVariableReferences asSet. varsAssignedTo _ self variablesAssignedTo asSet. instVarList _ aClass allInstVarNames. primArgCount _ args size. "add receiver fetch and arg conversions to prolog" prolog addAll: self fetchRcvrExpr. 1 to: args size do: [:argIndex | varName _ args at: argIndex. prolog addAll: (self argConversionExprFor: varName stackIndex: args size - argIndex)]. "add success check to postlog" postlog addAll: self checkSuccessExpr. "add instance variable fetches to prolog and instance variable stores to postlog" 1 to: instVarList size do: [:varIndex | varName _ instVarList at: varIndex. (instVarsUsed includes: varName) ifTrue: [ locals add: varName. prolog addAll: (self instVarGetExprFor: varName offset: varIndex - 1). (varsAssignedTo includes: varName) ifTrue: [ postlog addAll: (self instVarPutExprFor: varName offset: varIndex - 1)]]]. prolog addAll: self checkSuccessExpr. locals addAllFirst: args. locals addFirst: 'rcvr'. args _ args class new. locals asSet size = locals size ifFalse: [self error: 'local name conflicts with instance variable name']. endsWithReturn _ self endsWithReturn. self fixUpReturns: primArgCount postlog: postlog. "Check for pluggable primitive" primitive = 117 ifTrue:[ selector _ (aClass compiledMethodAt: selector) literals first at: 2. export _ true] ifFalse:[selector _ 'prim', aClass name, selector]. endsWithReturn ifTrue: [parseTree setStatements: prolog, parseTree statements] ifFalse: [ postlog addAll: (self popArgsExpr: primArgCount). parseTree setStatements: prolog, parseTree statements, postlog]. ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/12/98 15:30'! pushIntegerResultExpr: valueExpr "Return an expression to push an integer valued result." | conversionExpr | conversionExpr _ TSendNode new setSelector: #pushInteger: receiver: #self arguments: valueExpr. ^ TSendNode new setSelector: #push: receiver: #self arguments: conversionExpr ! ! !TMethod methodsFor: 'primitive compilation' stamp: 'jm 2/15/98 17:06'! replaceSizeMessages "Replace sends of the message 'size' with calls to sizeOfSTArrayFromCPrimitive." | argExpr | parseTree nodesDo: [:n | (n isSend and: [n selector = #size]) ifTrue: [ argExpr _ TSendNode new setSelector: #+ receiver: n receiver arguments: (Array with: (TConstantNode new setValue: 1)). n setSelector: #sizeOfSTArrayFromCPrimitive: receiver: (TVariableNode new setName: 'self') arguments: (Array with: argExpr)]]. ! ! !TMethod methodsFor: 'primitive compilation'! statementsFor: sourceText varName: varName "Return the parse tree for the given expression. The result is the statements list of the method parsed from the given source text." "Details: Various variables are declared as locals to avoid Undeclared warnings from the parser." | s | s _ WriteStream on: ''. s nextPutAll: 'temp'; cr; cr; tab. s nextPutAll: '| rcvr stackPointer successFlag ', varName,' |'; cr. s nextPutAll: sourceText. ^ ((Compiler new parse: s contents in: Object notifying: nil) asTMethodFromClass: Object) statements ! ! !TMethod methodsFor: 'transformations'! bindClassVariablesIn: constantDictionary "Class variables are used as constants. This method replaces all references to class variables in the body of this method with the corresponding constant looked up in the class pool dictionary of the source class. The source class class variables should be initialized before this method is called." parseTree _ parseTree bindVariablesIn: constantDictionary.! ! !TMethod methodsFor: 'transformations'! buildCaseStmt: aSendNode "Build a case statement node for the given send of dispatchOn:in:." "Note: the first argument is the variable to be dispatched on. The second argument is a constant node holding an array of unary selectors, which will be turned into sends to self." ((aSendNode args size = 2) and: [aSendNode args last isConstant and: [aSendNode args last value class = Array]]) ifFalse: [ self error: 'wrong node structure for a case statement'. ]. ^TCaseStmtNode new setExpression: aSendNode args first selectors: aSendNode args last value! ! !TMethod methodsFor: 'transformations' stamp: 'ar 10/7/1998 18:55'! extractExportDirective "Scan the top-level statements for an inlining directive of the form: self export: <boolean> and remove the directive from the method body. Return the argument of the directive or false if there is no export directive." | result newStatements | result _ false. newStatements _ OrderedCollection new: parseTree statements size. parseTree statements do: [ :stmt | (stmt isSend and: [stmt selector = #export:]) ifTrue: [ result _ stmt args first name = 'true'. ] ifFalse: [ newStatements add: stmt. ]. ]. parseTree setStatements: newStatements asArray. ^ result! ! !TMethod methodsFor: 'transformations'! prepareMethodIn: aCodeGen "Record sends of builtin operators and replace sends of the special selector dispatchOn:in: with case statement nodes." "Note: Only replaces top-level sends of dispatchOn:in:. Case statements must be top-level statements; they cannot appear in expressions." | stmts stmt | parseTree nodesDo: [ :node | node isSend ifTrue: [ "record sends of builtin operators" (aCodeGen builtin: node selector) ifTrue: [ node isBuiltinOperator: true ]. ]. node isStmtList ifTrue: [ "replace dispatchOn:in: with case statement node" stmts _ node statements. 1 to: stmts size do: [ :i | stmt _ stmts at: i. (stmt isSend and: [stmt selector = #dispatchOn:in:]) ifTrue: [ stmts at: i put: (self buildCaseStmt: stmt). ]. ]. ]. ].! ! !TMethod methodsFor: 'transformations'! recordDeclarations "Record C type declarations of the forms self returnTypeC: 'float'. self var: #foo declareC: 'float foo' and remove the declarations from the method body." | newStatements isDeclaration | newStatements _ OrderedCollection new: parseTree statements size. parseTree statements do: [ :stmt | isDeclaration _ false. stmt isSend ifTrue: [ stmt selector = #var:declareC: ifTrue: [ isDeclaration _ true. declarations at: stmt args first value asString put: stmt args last value. ]. stmt selector = #returnTypeC: ifTrue: [ isDeclaration _ true. returnType _ stmt args last value. ]. ]. isDeclaration ifFalse: [ newStatements add: stmt. ]. ]. parseTree setStatements: newStatements asArray.! ! !TMethod methodsFor: 'transformations' stamp: 'ikp 9/26/97 14:50'! removeAssertions parseTree removeAssertions! ! !TMethod methodsFor: 'transformations' stamp: 'jm 12/14/1998 08:35'! removeFinalSelfReturn "The Smalltalk parser automatically adds the statement '^self' to the end of methods without explicit returns. This method removes such statements, since the generated code has no notion of 'self' anyway." | stmtList lastStmt | stmtList _ parseTree statements asOrderedCollection. lastStmt _ stmtList last. ((lastStmt isReturn) and: [(lastStmt expression isVariable) and: ['self' = lastStmt expression name]]) ifTrue: [ stmtList removeLast. parseTree setStatements: stmtList. ].! ! !TMethod methodsFor: 'utilities'! allCalls "Answer a collection of selectors for the messages sent by this method." ^parseTree allCalls! ! !TMethod methodsFor: 'utilities' stamp: 'jm 2/12/98 11:55'! copy "Make a deep copy of this TMethod." ^ self class basicNew setSelector: selector returnType: returnType args: args copy locals: locals copy declarations: declarations copy primitive: primitive parseTree: parseTree copyTree labels: labels copy complete: complete ! ! !TMethod methodsFor: 'utilities'! freeVariableReferences "Answer a collection of variables referenced this method, excluding locals, arguments, and pseudovariables." | refs | refs _ Set new. parseTree nodesDo: [ :node | node isVariable ifTrue: [ refs add: node name asString ]. ]. args do: [ :var | refs remove: var asString ifAbsent: [] ]. locals do: [ :var | refs remove: var asString ifAbsent: [] ]. #('self' 'nil' 'true' 'false') do: [ :var | refs remove: var ifAbsent: [] ]. ^ refs asSortedCollection! ! !TMethod methodsFor: 'utilities'! hasNoCCode "Answer true if the receiver does not use inlined C or C declarations, which are not currently renamed properly by the the inliner." declarations isEmpty ifFalse: [ ^ false ]. parseTree nodesDo: [ :node | node isSend ifTrue: [ node selector = #cCode: ifTrue: [ ^ false ]. ]. ]. ^ true! ! !TMethod methodsFor: 'utilities'! nodeCount "Answer the number of nodes in this method's parseTree (a rough measure of its size)." | cnt | cnt _ 0. parseTree nodesDo: [ :n | cnt _ cnt + 1 ]. ^cnt! ! !TMethod methodsFor: 'utilities'! variablesAssignedTo "Answer a collection of variables assigned to by this method." | refs | refs _ Set new. parseTree nodesDo: [ :node | node isAssignment ifTrue: [ refs add: node variable name ]. ]. ^ refs! ! !TMethod methodsFor: 'inlining' stamp: 'jm 12/13/1998 10:06'! argAssignmentsFor: meth args: argList in: aCodeGen "Return a collection of assignment nodes that assign the given argument expressions to the formal parameter variables of the given method." "Optimization: If the actual parameters are either constants or local variables in the target method (the receiver), substitute them directly into the body of meth. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals." | stmtList substitutionDict | stmtList _ OrderedCollection new: 100. substitutionDict _ Dictionary new: 100. meth args with: argList do: [ :argName :exprNode | (self isSubstitutableNode: exprNode intoMethod: meth in: aCodeGen) ifTrue: [ substitutionDict at: argName asSymbol put: exprNode. locals remove: argName. ] ifFalse: [ stmtList add: (TAssignmentNode new setVariable: (TVariableNode new setName: argName) expression: exprNode copyTree). ]. ]. meth parseTree: (meth parseTree bindVariablesIn: substitutionDict). ^stmtList! ! !TMethod methodsFor: 'inlining'! checkForCompleteness: stmtLists in: aCodeGen "Set the complete flag if none of the given statement list nodes contains further candidates for inlining." complete _ true. stmtLists do: [ :stmtList | stmtList statements do: [ :node | (self inlineableSend: node in: aCodeGen) ifTrue: [ complete _ false. "more inlining to do" ^self ]. ]. ]. parseTree nodesDo: [ :n | (self inlineableFunctionCall: n in: aCodeGen) ifTrue: [ complete _ false. "more inlining to do" ^self ]. ].! ! !TMethod methodsFor: 'inlining'! exitVar: exitVar label: exitLabel "Replace each return statement in this method with an assignment to the exit variable followed by a goto to the given label. Return true if a goto was generated." "Optimization: If exitVar is nil, the return value of the inlined method is not being used, so don't add the assignment statement." | newStmts labelUsed | labelUsed _ false. parseTree nodesDo: [ :node | node isStmtList ifTrue: [ newStmts _ OrderedCollection new: 100. node statements do: [ :stmt | (stmt isReturn) ifTrue: [ exitVar = nil ifTrue: [ stmt expression isLeaf ifFalse: [ "evaluate return expression even though value isn't used" newStmts add: stmt expression. ]. ] ifFalse: [ "assign return expression to exit variable" newStmts add: (TAssignmentNode new setVariable: (TVariableNode new setName: exitVar) expression: stmt expression). ]. (stmt == parseTree statements last) ifFalse: [ "generate a goto (this return is NOT the last statement in the method)" newStmts add: (TGoToNode new setLabel: exitLabel). labelUsed _ true. ]. ] ifFalse: [ newStmts addLast: stmt. ]. ]. node setStatements: newStmts asArray. ]. ]. ^labelUsed! ! !TMethod methodsFor: 'inlining'! inlineCaseStatementBranchesIn: aCodeGen localizingVars: varsList | stmt sel meth newStatements maxTemp usedVars exitLabel v | maxTemp _ 0. parseTree nodesDo: [ :n | n isCaseStmt ifTrue: [ n cases do: [ :stmtNode | stmt _ stmtNode statements first. stmt isSend ifTrue: [ sel _ stmt selector. meth _ aCodeGen methodNamed: sel. ((meth ~= nil) and: [meth hasNoCCode and: [meth args size = 0]]) ifTrue: [ meth _ meth copy. maxTemp _ maxTemp max: (meth renameVarsForCaseStmt). meth hasReturn ifTrue: [ exitLabel _ self unusedLabelForInliningInto: self. meth exitVar: nil label: exitLabel. labels add: exitLabel. ] ifFalse: [ exitLabel _ nil ]. meth renameLabelsForInliningInto: self. meth labels do: [ :label | labels add: label ]. newStatements _ stmtNode statements asOrderedCollection. newStatements removeFirst. exitLabel ~= nil ifTrue: [ newStatements addFirst: (TLabeledCommentNode new setLabel: exitLabel comment: 'end case'). ]. newStatements addAllFirst: meth statements. newStatements addFirst: (TLabeledCommentNode new setComment: meth selector). stmtNode setStatements: newStatements. ]. ]. ]. ]. ]. usedVars _ (locals, args) asSet. 1 to: maxTemp do: [ :i | v _ ('t', i printString). (usedVars includes: v) ifTrue: [ self error: 'temp variable name conflicts with an existing local or arg' ]. locals addLast: v. ]. "make local versions of the given globals" varsList do: [ :var | (usedVars includes: var) ifFalse: [ locals addFirst: var asString ]. ]. ! ! !TMethod methodsFor: 'inlining'! inlineCodeOrNilForStatement: aNode in: aCodeGen "If the given statement node can be inlined, answer the statements that replace it. Otherwise, answer nil." | stmts | aNode isReturn ifTrue: [ (self inlineableSend: aNode expression in: aCodeGen) ifTrue: [ stmts _ self inlineSend: aNode expression directReturn: true exitVar: nil in: aCodeGen. ^stmts ]. ]. aNode isAssignment ifTrue: [ (self inlineableSend: aNode expression in: aCodeGen) ifTrue: [ ^self inlineSend: aNode expression directReturn: false exitVar: aNode variable name in: aCodeGen ]. ]. aNode isSend ifTrue: [ (self inlineableSend: aNode in: aCodeGen) ifTrue: [ ^self inlineSend: aNode directReturn: false exitVar: nil in: aCodeGen ]. ]. ^nil! ! !TMethod methodsFor: 'inlining' stamp: 'jm 12/13/1998 10:06'! inlineFunctionCall: aSendNode in: aCodeGen "Answer the body of the called function, substituting the actual parameters for the formal argument variables in the method body." "Assume caller has established that: 1. the method arguments are all substitutable nodes, and 2. the method to be inlined contains no additional embedded returns." | sel meth substitutionDict | sel _ aSendNode selector. meth _ (aCodeGen methodNamed: sel) copy. meth renameVarsForInliningInto: self in: aCodeGen. meth renameLabelsForInliningInto: self. self addVarsDeclarationsAndLabelsOf: meth. substitutionDict _ Dictionary new: 100. meth args with: aSendNode args do: [ :argName :exprNode | substitutionDict at: argName asSymbol put: exprNode. locals remove: argName. ]. meth parseTree bindVariablesIn: substitutionDict. ^meth statements first expression! ! !TMethod methodsFor: 'inlining'! inlineSend: aSendNode directReturn: directReturn exitVar: exitVar in: aCodeGen "Answer a collection of statments to replace the given send. directReturn indicates that the send is the expression of a return statement, so returns can be left in the body of the inlined method. If exitVar is nil, the value returned by the send is not used; thus, returns need not assign to the output variable." | sel meth exitLabel labelUsed inlineStmts | sel _ aSendNode selector. meth _ (aCodeGen methodNamed: sel) copy. meth renameVarsForInliningInto: self in: aCodeGen. meth renameLabelsForInliningInto: self. self addVarsDeclarationsAndLabelsOf: meth. meth hasReturn ifTrue: [ directReturn ifTrue: [ "propagate the return type, if necessary" returnType = meth returnType ifFalse: [ self halt ]. "caller's return type should be declared by user" returnType _ meth returnType. ] ifFalse: [ exitLabel _ self unusedLabelForInliningInto: self. labelUsed _ meth exitVar: exitVar label: exitLabel. labelUsed ifTrue: [ labels add: exitLabel ] ifFalse: [ exitLabel _ nil ]. ]. "propagate type info if necessary" ((exitVar ~= nil) and: [meth returnType ~= 'int']) ifTrue: [ declarations at: exitVar put: meth returnType, ' ', exitVar. ]. ]. inlineStmts _ OrderedCollection new: 100. inlineStmts add: (TLabeledCommentNode new setComment: 'begin ', sel). inlineStmts addAll: (self argAssignmentsFor: meth args: aSendNode args in: aCodeGen). inlineStmts addAll: meth statements. "method body" (directReturn and: [meth endsWithReturn not]) ifTrue: [ inlineStmts add: (TReturnNode new setExpression: (TVariableNode new setName: 'nil')). ]. exitLabel ~= nil ifTrue: [ inlineStmts add: (TLabeledCommentNode new setLabel: exitLabel comment: 'end ', meth selector). ]. ^inlineStmts! ! !TMethod methodsFor: 'inlining'! inlineableFunctionCall: aNode in: aCodeGen "Answer true if the given send node is a call to a 'functional' method--a method whose body is a single return statement of some expression and whose actual parameters can all be directly substituted." | m | aNode isSend ifFalse: [ ^false ]. m _ aCodeGen methodNamed: aNode selector. "nil if builtin or external function" ((m ~= nil) and: [m isFunctional and: [aCodeGen mayInline: m selector]]) ifTrue: [ aNode args do: [ :a | (self isSubstitutableNode: a intoMethod: m in: aCodeGen) ifFalse: [ ^false ]]. ^true ] ifFalse: [ ^false ].! ! !TMethod methodsFor: 'inlining'! inlineableSend: aNode in: aCodeGen "Answer true if the given send node is a call to a method that can be inlined." | m | aNode isSend ifFalse: [ ^false ]. m _ aCodeGen methodNamed: aNode selector. "nil if builtin or external function" ^(m ~= nil) and: [m isComplete and: [aCodeGen mayInline: m selector]]! ! !TMethod methodsFor: 'inlining'! isFunctional "Answer true if the receiver is a functional method. That is, if it consists of a single return statement of an expression that contains no other returns." (parseTree statements size = 1 and: [parseTree statements last isReturn]) ifFalse: [ ^false ]. parseTree statements last expression nodesDo: [ :n | n isReturn ifTrue: [ ^false ]]. ^true! ! !TMethod methodsFor: 'inlining'! isSubstitutableNode: aNode "Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted because the inlined method might depend on the exact ordering of side effects to the globals." aNode isConstant ifTrue: [ ^true ]. ^aNode isVariable and: [(locals includes: aNode name) or: [args includes: aNode name]]! ! !TMethod methodsFor: 'inlining'! isSubstitutableNode: aNode intoMethod: targetMeth in: aCodeGen "Answer true if the given parameter node is either a constant, a local variable, or a formal parameter of the receiver. Such parameter nodes may be substituted directly into the body of the method during inlining. Note that global variables cannot be subsituted into methods with possible side effects (i.e., methods that may assign to global variables) because the inlined method might depend on having the value of the global variable captured when it is passed in as an argument." | var | aNode isConstant ifTrue: [ ^ true ]. aNode isVariable ifTrue: [ var _ aNode name. ((locals includes: var) or: [args includes: var]) ifTrue: [ ^ true ]. (#(self true false nil) includes: var) ifTrue: [ ^ true ]. (targetMeth maySubstituteGlobal: var in: aCodeGen) ifTrue: [ ^ true ]. ]. "scan expression tree; must contain only constants, builtin ops, and inlineable vars" aNode nodesDo: [ :node | node isSend ifTrue: [ node isBuiltinOperator ifFalse: [ ^false ]. ]. node isVariable ifTrue: [ var _ node name. ((locals includes: var) or: [(args includes: var) or: [(#(self true false nil) includes: var) or: [targetMeth maySubstituteGlobal: var in: aCodeGen]]]) ifFalse: [ ^ false ]. ]. (node isConstant or: [node isVariable or: [node isSend]]) ifFalse: [ ^false ]. ]. ^ true! ! !TMethod methodsFor: 'inlining'! statementsListsForInlining "Answer a collection of statement list nodes that are candidates for inlining. Currently, we cannot inline into the argument blocks of and: and or: messages." | stmtLists | stmtLists _ OrderedCollection new: 10. parseTree nodesDo: [ :node | node isStmtList ifTrue: [ stmtLists add: node ]. ]. parseTree nodesDo: [ :node | node isSend ifTrue: [ ((node selector = #and:) or: [node selector = #or:]) ifTrue: [ "Note: the PP 2.3 compiler produces two arg nodes for these selectors" stmtLists remove: node args first ifAbsent: []. stmtLists remove: node args last ifAbsent: []. ]. ((node selector = #ifTrue:) or: [node selector = #ifFalse:]) ifTrue: [ stmtLists remove: node receiver ifAbsent: []. ]. ((node selector = #ifTrue:ifFalse:) or: [node selector = #ifFalse:ifTrue:]) ifTrue: [ stmtLists remove: node receiver ifAbsent: []. ]. ((node selector = #whileFalse:) or: [node selector = #whileTrue:]) ifTrue: [ stmtLists remove: node receiver ifAbsent: []. ]. (node selector = #to:do) ifTrue: [ stmtLists remove: node receiver ifAbsent: []. stmtLists remove: node args first ifAbsent: []. ]. (node selector = #to:do) ifTrue: [ stmtLists remove: node receiver ifAbsent: []. stmtLists remove: node args first ifAbsent: []. stmtLists remove: (node args at: 2) ifAbsent: []. ]. ]. node isCaseStmt ifTrue: [ "don't inline cases" node cases do: [: case | stmtLists remove: case ifAbsent: [] ]. ]. ]. ^stmtLists! ! !TMethod methodsFor: 'inlining' stamp: 'jm 12/13/1998 10:07'! tryToInlineMethodsIn: aCodeGen "Expand any (complete) inline methods called by this method. Set the complete bit when all inlining has been done. Return true if something was inlined." | stmtLists didSomething newStatements inlinedStmts sendsToInline | didSomething _ false. sendsToInline _ Dictionary new: 100. parseTree nodesDo: [ :n | (self inlineableFunctionCall: n in: aCodeGen) ifTrue: [ sendsToInline at: n put: (self inlineFunctionCall: n in: aCodeGen). ]. ]. sendsToInline isEmpty ifFalse: [ didSomething _ true. parseTree _ parseTree replaceNodesIn: sendsToInline. ]. didSomething ifTrue: [ possibleSideEffectsCache _ nil. ^didSomething ]. stmtLists _ self statementsListsForInlining. stmtLists do: [ :stmtList | newStatements _ OrderedCollection new: 100. stmtList statements do: [ :stmt | inlinedStmts _ self inlineCodeOrNilForStatement: stmt in: aCodeGen. (inlinedStmts = nil) ifTrue: [ newStatements addLast: stmt. ] ifFalse: [ didSomething _ true. newStatements addAllLast: inlinedStmts. ]. ]. stmtList setStatements: newStatements asArray. ]. didSomething ifTrue: [ possibleSideEffectsCache _ nil. ^didSomething ]. complete ifFalse: [ self checkForCompleteness: stmtLists in: aCodeGen. complete ifTrue: [ didSomething _ true ]. "marking a method complete is progress" ]. ^didSomething! ! !TMethod methodsFor: 'inlining'! unusedLabelForInliningInto: targetMethod | usedLabels | usedLabels _ labels asSet. usedLabels addAll: targetMethod labels. ^self unusedNamePrefixedBy: 'l' avoiding: usedLabels! ! !TMethod methodsFor: 'inlining support'! addVarsDeclarationsAndLabelsOf: methodToBeInlined "Prepare to inline the body of the given method into the receiver by making the args and locals of the argument to the receiver be locals of the receiver. Record any type declarations for these variables. Record labels. Assumes that the variables have already be renamed to avoid name clashes." methodToBeInlined args, methodToBeInlined locals do: [ :v | (locals includes: v) ifFalse: [ locals addLast: v ]. ]. methodToBeInlined declarations associationsDo: [ :assoc | declarations add: assoc. ]. methodToBeInlined labels do: [ :label | labels add: label. ].! ! !TMethod methodsFor: 'inlining support'! computePossibleSideEffectsIn: aCodeGen "Answer true if this method may have side effects. It has side effects if it assigns to a global variable. It may have side effects if it calls a non-built-in method." parseTree nodesDo: [ :node | node isSend ifTrue: [ node isBuiltinOperator ifFalse: [ ^true ]. ]. ]. ^ false! ! !TMethod methodsFor: 'inlining support'! endsWithReturn "Answer true if the last statement of this method is a return." ^ parseTree statements last isReturn! ! !TMethod methodsFor: 'inlining support'! extractInlineDirective "Scan the top-level statements for an inlining directive of the form: self inline: <boolean> and remove the directive from the method body. Return the argument of the directive or #dontCare if there is no inlining directive." | result newStatements | result _ #dontCare. newStatements _ OrderedCollection new: parseTree statements size. parseTree statements do: [ :stmt | (stmt isSend and: [stmt selector = #inline:]) ifTrue: [ result _ stmt args first name = 'true'. ] ifFalse: [ newStatements add: stmt. ]. ]. parseTree setStatements: newStatements asArray. ^ result! ! !TMethod methodsFor: 'inlining support'! hasReturn "Answer true if this method contains a return statement." parseTree nodesDo: [ :n | n isReturn ifTrue: [ ^ true ]]. ^ false! ! !TMethod methodsFor: 'inlining support' stamp: 'ikp 9/26/97 14:50'! isAssertion ^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! ! !TMethod methodsFor: 'inlining support'! maySubstituteGlobal: globalVar in: aCodeGen "Answer true if this method does or may have side effects on the given global variable." possibleSideEffectsCache = nil ifTrue: [ "see if this calls any other method and record the result" possibleSideEffectsCache _ self computePossibleSideEffectsIn: aCodeGen. ]. possibleSideEffectsCache ifTrue: [ ^ false ]. parseTree nodesDo: [ :node | node isAssignment ifTrue: [ node variable name = globalVar ifTrue: [ ^ false ]. ]. ]. "if we get here, receiver calls no other method and does not itself assign to the given global variable" ^ true! ! !TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:06'! renameLabelsForInliningInto: destMethod "Rename any labels that would clash with those of the destination method." | destLabels usedLabels labelMap newLabelName | destLabels _ destMethod labels asSet. usedLabels _ destLabels copy. "usedLabels keeps track of labels in use" usedLabels addAll: labels. labelMap _ Dictionary new: 100. self labels do: [ :l | (destLabels includes: l) ifTrue: [ newLabelName _ self unusedNamePrefixedBy: 'l' avoiding: usedLabels. labelMap at: l put: newLabelName. ]. ]. self renameLabelsUsing: labelMap.! ! !TMethod methodsFor: 'inlining support'! renameLabelsUsing: aDictionary "Rename all labels according to the old->new mappings of the given dictionary." labels _ labels collect: [ :label | (aDictionary includesKey: label) ifTrue: [ aDictionary at: label ] ifFalse: [ label ]. ]. parseTree nodesDo: [ :node | (node isGoTo and: [aDictionary includesKey: node label]) ifTrue: [ node setLabel: (aDictionary at: node label). ]. (node isLabel and: [aDictionary includesKey: node label]) ifTrue: [ node setLabel: (aDictionary at: node label). ]. ].! ! !TMethod methodsFor: 'inlining support'! renameVariablesUsing: aDictionary "Rename all variables according to old->new mappings of the given dictionary." | newDecls | "map args and locals" args _ args collect: [ :arg | (aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ]. ]. locals _ locals collect: [ :v | (aDictionary includesKey: v) ifTrue: [ aDictionary at: v ] ifFalse: [ v ]. ]. "map declarations" newDecls _ declarations species new. declarations associationsDo: [ :assoc | (aDictionary includesKey: assoc key) ifTrue: [ newDecls at: (aDictionary at: assoc key) put: assoc value ] ifFalse: [ newDecls add: assoc ]. ]. declarations _ newDecls. "map variable names in parse tree" parseTree nodesDo: [ :node | (node isVariable and: [aDictionary includesKey: node name]) ifTrue: [ node setName: (aDictionary at: node name). ]. (node isStmtList and: [node args size > 0]) ifTrue: [ node setArguments: (node args collect: [ :arg | (aDictionary includesKey: arg) ifTrue: [ aDictionary at: arg ] ifFalse: [ arg ]. ]). ]. ].! ! !TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'! renameVarsForCaseStmt "Rename the arguments and locals of this method with names like t1, t2, t3, etc. Return the number of variable names assigned. This is done to allow registers to be shared among the cases." | i varMap | i _ 1. varMap _ Dictionary new: 100. args, locals do: [ :v | varMap at: v put: ('t', i printString) asSymbol. i _ i + 1. ]. self renameVariablesUsing: varMap. ^ i - 1! ! !TMethod methodsFor: 'inlining support' stamp: 'jm 12/13/1998 10:07'! renameVarsForInliningInto: destMethod in: aCodeGen "Rename any variables that would clash with those of the destination method." | destVars usedVars varMap newVarName | destVars _ aCodeGen globalsAsSet copy. destVars addAll: destMethod locals. destVars addAll: destMethod args. usedVars _ destVars copy. "keeps track of names in use" usedVars addAll: args; addAll: locals. varMap _ Dictionary new: 100. args, locals do: [ :v | (destVars includes: v) ifTrue: [ newVarName _ self unusedNamePrefixedBy: v avoiding: usedVars. varMap at: v put: newVarName. ]. ]. self renameVariablesUsing: varMap.! ! !TMethod methodsFor: 'inlining support'! unusedNamePrefixedBy: aString avoiding: usedNames "Choose a unique variable or label name with the given string as a prefix, avoiding the names in the given collection. The selected name is added to usedNames." | n newVarName | n _ 1. newVarName _ aString, n printString. [usedNames includes: newVarName] whileTrue: [ n _ n + 1. newVarName _ aString, n printString. ]. usedNames add: newVarName. ^ newVarName! ! !TMethod methodsFor: 'C code generation'! emitCCodeOn: aStream generator: aCodeGen "Emit C code for this method onto the given stream. All calls to inlined methods should already have been expanded." self emitCHeaderOn: aStream generator: aCodeGen. parseTree emitCCodeOn: aStream level: 1 generator: aCodeGen. aStream nextPutAll: '}'; cr.! ! !TMethod methodsFor: 'C code generation' stamp: 'jm 9/24/2006 16:05'! emitCFunctionPrototype: aStream generator: aCodeGen "Emit a C function header for this method onto the given stream." | arg | self hasReturn ifFalse: [returnType _ 'void']. export ifTrue:[aStream nextPutAll:'EXPORT('; nextPutAll: returnType; nextPutAll:') '] ifFalse:[aStream nextPutAll: returnType; space]. aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('. args isEmpty ifTrue: [ aStream nextPutAll: 'void' ]. 1 to: args size do: [ :i | arg _ args at: i. (declarations includesKey: arg) ifTrue: [ aStream nextPutAll: (declarations at: arg). ] ifFalse: [ aStream nextPutAll: 'int ', (args at: i). ]. i < args size ifTrue: [ aStream nextPutAll: ', ' ]. ]. aStream nextPutAll: ')'.! ! !TMethod methodsFor: 'C code generation'! emitCHeaderOn: aStream generator: aCodeGen "Emit a C function header for this method onto the given stream." aStream cr. self emitCFunctionPrototype: aStream generator: aCodeGen. aStream nextPutAll: ' {'; cr. locals do: [ :var | aStream nextPutAll: ' '. aStream nextPutAll: (declarations at: var ifAbsent: [ 'int ', var]), ';'; cr. ]. locals isEmpty ifFalse: [ aStream cr ].! ! !TMethod methodsFor: 'C code generation' stamp: 'ar 9/18/1998 23:25'! emitProxyFunctionPrototype: aStream generator: aCodeGen "Emit an indirect C function header for this method onto the given stream." | arg | aStream nextPutAll: returnType; space. aStream nextPutAll: '(*', (aCodeGen cFunctionNameFor: selector), ')('. args isEmpty ifTrue: [ aStream nextPutAll: 'void' ]. 1 to: args size do: [ :i | arg _ args at: i. (declarations includesKey: arg) ifTrue: [ aStream nextPutAll: (declarations at: arg). ] ifFalse: [ aStream nextPutAll: 'int ', (args at: i). ]. i < args size ifTrue: [ aStream nextPutAll: ', ' ]. ]. aStream nextPutAll: ')'.! ! !TMethod methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'TMethod(', selector, ')'.! ! !TParseNode methodsFor: 'all'! allCalls "Answer a collection of selectors for the messages sent in this parse tree." | calls | calls _ Set new: 100. self nodesDo: [ :node | node isSend ifTrue: [ calls add: node selector ]. ]. ^calls! ! !TParseNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:13'! bindVariableUsesIn: aDictionary "Bind uses of all variables in the given dictionary, but do not change variables that appear on the left-hand-side of an assignment statement." ^ self ! ! !TParseNode methodsFor: 'all'! bindVariablesIn: aDictionary ^self! ! !TParseNode methodsFor: 'all'! hasExplicitReturn self nodesDo: [ :node | node isReturn ifTrue: [ ^true ]. ]. ^false! ! !TParseNode methodsFor: 'all'! inlineMethodsUsing: aDictionary self! ! !TParseNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! isAssertion ^false! ! !TParseNode methodsFor: 'all'! isAssignment ^false! ! !TParseNode methodsFor: 'all'! isCaseStmt ^false! ! !TParseNode methodsFor: 'all'! isComment ^false! ! !TParseNode methodsFor: 'all'! isConstant ^false! ! !TParseNode methodsFor: 'all'! isGoTo ^false! ! !TParseNode methodsFor: 'all'! isLabel ^false! ! !TParseNode methodsFor: 'all'! isLeaf "Answer true if the receiver is a variable or a constant node." ^false! ! !TParseNode methodsFor: 'all'! isReturn ^false! ! !TParseNode methodsFor: 'all'! isSend ^false! ! !TParseNode methodsFor: 'all'! isStmtList ^false! ! !TParseNode methodsFor: 'all'! isVariable ^false! ! !TParseNode methodsFor: 'all'! nodeCount "Answer the number of nodes in this parseTree (a rough measure of its size)." | cnt | cnt _ 0. self nodesDo: [ :n | cnt _ cnt + 1 ]. ^cnt! ! !TParseNode methodsFor: 'all'! nodesDo: aBlock aBlock value: self.! ! !TParseNode methodsFor: 'all'! printOn: aStream "Append a description of the receiver onto the given stream." self printOn: aStream level: 0.! ! !TParseNode methodsFor: 'all'! printOn: aStream level: anInteger "Typically overridden. If control actually gets here, avoid recursion loop by sending to super." super printOn: aStream.! ! !TParseNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions "default: do nothing"! ! !TParseNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [self]! ! !TReturnNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:26'! bindVariableUsesIn: aDictionary expression _ expression bindVariableUsesIn: aDictionary.! ! !TReturnNode methodsFor: 'all'! bindVariablesIn: aDictionary expression _ expression bindVariablesIn: aDictionary.! ! !TReturnNode methodsFor: 'all'! copyTree ^self class new setExpression: expression copyTree! ! !TReturnNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen aStream nextPutAll: 'return '. expression emitCCodeOn: aStream level: level generator: aCodeGen.! ! !TReturnNode methodsFor: 'all'! expression ^expression! ! !TReturnNode methodsFor: 'all'! inlineMethodsUsing: aDictionary expression _ expression inlineMethodsUsing: aDictionary.! ! !TReturnNode methodsFor: 'all'! isReturn ^true! ! !TReturnNode methodsFor: 'all'! nodesDo: aBlock expression nodesDo: aBlock. aBlock value: self.! ! !TReturnNode methodsFor: 'all'! printOn: aStream level: level aStream nextPut: $^. expression printOn: aStream level: level.! ! !TReturnNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions expression removeAssertions! ! !TReturnNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [ expression _ expression replaceNodesIn: aDictionary. self]! ! !TReturnNode methodsFor: 'all'! setExpression: aNode expression _ aNode.! ! !TSendNode methodsFor: 'all'! args ^arguments! ! !TSendNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:26'! bindVariableUsesIn: aDictionary receiver _ receiver bindVariableUsesIn: aDictionary. arguments _ arguments collect: [ :a | a bindVariableUsesIn: aDictionary ].! ! !TSendNode methodsFor: 'all'! bindVariablesIn: aDictionary receiver _ receiver bindVariablesIn: aDictionary. arguments _ arguments collect: [ :a | a bindVariablesIn: aDictionary ].! ! !TSendNode methodsFor: 'all'! copyTree ^self class new setSelector: selector receiver: receiver copyTree arguments: (arguments collect: [ :arg | arg copyTree ]) isBuiltInOp: isBuiltinOperator! ! !TSendNode methodsFor: 'all' stamp: 'jm 12/14/1998 08:36'! emitCCodeOn: aStream level: level generator: aCodeGen "If the selector is a built-in construct, translate it and return" (aCodeGen emitBuiltinConstructFor: self on: aStream level: level) ifTrue: [ ^self ]. "Special case for pluggable modules. Replace messages to interpreterProxy by interpreterProxy->message(..) if the message is not builtin" (aCodeGen isGeneratingPluginCode and:[ receiver isVariable and:[ 'interpreterProxy' = receiver name and:[ self isBuiltinOperator not]]]) ifTrue:[aStream nextPutAll:'interpreterProxy->']. "Translate this message send into a C function call." aStream nextPutAll: (aCodeGen cFunctionNameFor: selector), '('. (receiver isVariable and: [('self' = receiver name) or: ['interpreterProxy' = receiver name]]) ifFalse: [ "self is omitted from the arguments list of the generated call" "Note: special case for translated BitBltSimulator--also omit the receiver if this is a send to the variable 'interpreterProxy'" receiver emitCCodeOn: aStream level: level generator: aCodeGen. arguments isEmpty ifFalse: [ aStream nextPutAll: ', ' ]. ]. 1 to: arguments size do: [ :i | (arguments at: i) emitCCodeOn: aStream level: level generator: aCodeGen. i < arguments size ifTrue: [ aStream nextPutAll: ', ' ]. ]. aStream nextPutAll: ')'.! ! !TSendNode methodsFor: 'all'! inlineMethodsUsing: aDictionary arguments _ arguments collect: [ :arg | arg inlineMethodsUsing: aDictionary. ]. "xxx inline this message if it is in the dictionary xxx"! ! !TSendNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! isAssertion ^(selector beginsWith: 'assert') or: [selector beginsWith: 'verify']! ! !TSendNode methodsFor: 'all'! isBuiltinOperator ^ isBuiltinOperator! ! !TSendNode methodsFor: 'all'! isBuiltinOperator: builtinFlag isBuiltinOperator _ builtinFlag.! ! !TSendNode methodsFor: 'all'! isSend ^true! ! !TSendNode methodsFor: 'all'! nodesDo: aBlock receiver nodesDo: aBlock. arguments do: [ :arg | arg nodesDo: aBlock ]. aBlock value: self.! ! !TSendNode methodsFor: 'all'! printOn: aStream level: level | keywords | receiver printOn: aStream level: level. arguments size = 0 ifTrue: [ aStream space; nextPutAll: selector. ^self ]. keywords _ selector keywords. 1 to: keywords size do: [ :i | aStream space. aStream nextPutAll: (keywords at: i); space. (arguments at: i) printOn: aStream level: level + 1. ].! ! !TSendNode methodsFor: 'all'! receiver ^receiver! ! !TSendNode methodsFor: 'all'! receiver: aNode receiver _ aNode.! ! !TSendNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions receiver removeAssertions. arguments do: [:arg | arg removeAssertions].! ! !TSendNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [ receiver _ receiver replaceNodesIn: aDictionary. arguments _ arguments collect: [ :a | a replaceNodesIn: aDictionary ]. self]! ! !TSendNode methodsFor: 'all'! selector ^selector! ! !TSendNode methodsFor: 'all'! setSelector: aSymbol receiver: rcvrNode arguments: argList selector _ aSymbol. receiver _ rcvrNode. arguments _ argList asArray. isBuiltinOperator _ false.! ! !TSendNode methodsFor: 'all'! setSelector: aSymbol receiver: rcvrNode arguments: argList isBuiltInOp: builtinFlag selector _ aSymbol. receiver _ rcvrNode. arguments _ argList asArray. isBuiltinOperator _ builtinFlag.! ! !TStmtListNode methodsFor: 'all'! args ^arguments! ! !TStmtListNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:26'! bindVariableUsesIn: aDictionary statements _ statements collect: [ :s | s bindVariableUsesIn: aDictionary ].! ! !TStmtListNode methodsFor: 'all'! bindVariablesIn: aDictionary statements _ statements collect: [ :s | s bindVariablesIn: aDictionary ].! ! !TStmtListNode methodsFor: 'all'! copyTree ^self class new setArguments: arguments copy statements: (statements collect: [ :s | s copyTree ])! ! !TStmtListNode methodsFor: 'all' stamp: 'jm 11/25/1998 16:27'! emitCCodeOn: aStream level: level generator: aCodeGen statements do: [:s | level timesRepeat: [aStream tab]. s emitCCodeOn: aStream level: level generator: aCodeGen. ((self endsWithCloseBracket: aStream) or: [s isComment]) ifFalse: [aStream nextPut: $;]. aStream cr]. ! ! !TStmtListNode methodsFor: 'all' stamp: 'jm 11/25/1998 16:26'! endsWithCloseBracket: aStream "Answer true if the given stream ends in a $} character." | ch pos | (pos _ aStream position) > 0 ifTrue: [ aStream position: pos - 1. ch _ aStream next]. ^ ch = $} ! ! !TStmtListNode methodsFor: 'all'! inlineMethodsUsing: aDictionary statements do: [ :s | s inlineMethodsUsing: aDictionary ].! ! !TStmtListNode methodsFor: 'all'! isStmtList ^true! ! !TStmtListNode methodsFor: 'all'! nodesDo: aBlock statements do: [ :s | s nodesDo: aBlock ]. aBlock value: self.! ! !TStmtListNode methodsFor: 'all'! printOn: aStream level: level aStream nextPut: $[. arguments size > 0 ifTrue: [ arguments do: [ :arg | aStream nextPutAll: ' :', arg ]. aStream nextPutAll: ' | '. ]. self printStatementsOn: aStream level: level. aStream nextPut: $].! ! !TStmtListNode methodsFor: 'all'! printStatementsOn: aStream level: level statements size > 1 ifTrue: [ aStream crtab: level + 1 ]. 1 to: statements size do: [ :i | (statements at: i) printOn: aStream level: level. i = statements size ifTrue: [ (statements size > 1) ifTrue: [ aStream crtab: level. ]. ] ifFalse: [ aStream nextPut: $.; crtab: level + 1. ]. ].! ! !TStmtListNode methodsFor: 'all' stamp: 'ikp 9/26/97 14:50'! removeAssertions | newStatements | newStatements _ OrderedCollection new: statements size. statements do: [ :stmt | stmt isAssertion ifFalse: [ newStatements add: (stmt removeAssertions; yourself). ] ]. self setStatements: newStatements asArray! ! !TStmtListNode methodsFor: 'all'! replaceNodesIn: aDictionary ^aDictionary at: self ifAbsent: [ statements _ statements collect: [ :s | s replaceNodesIn: aDictionary ]. self]! ! !TStmtListNode methodsFor: 'all'! setArguments: argList arguments _ argList.! ! !TStmtListNode methodsFor: 'all'! setArguments: argList statements: statementList "Initialize this method using the given information." arguments _ argList. statements _ statementList.! ! !TStmtListNode methodsFor: 'all'! setStatements: stmtList statements _ stmtList asOrderedCollection.! ! !TStmtListNode methodsFor: 'all'! statements ^statements! ! !TVariableNode methodsFor: 'all' stamp: 'jm 12/10/1998 18:09'! bindVariableUsesIn: aDictionary | newNode | newNode _ aDictionary at: name asSymbol ifAbsent: [ ^self ]. ^ newNode copyTree! ! !TVariableNode methodsFor: 'all'! bindVariablesIn: aDictionary | newNode | newNode _ aDictionary at: name asSymbol ifAbsent: [ ^self ]. ^newNode copyTree! ! !TVariableNode methodsFor: 'all'! copyTree ^self class new setName: name! ! !TVariableNode methodsFor: 'all'! emitCCodeOn: aStream level: level generator: aCodeGen name = 'nil' ifTrue: [ aStream nextPutAll: (aCodeGen cLiteralFor: nil) ] ifFalse: [ aStream nextPutAll: name ].! ! !TVariableNode methodsFor: 'all'! isLeaf ^true! ! !TVariableNode methodsFor: 'all'! isVariable ^true! ! !TVariableNode methodsFor: 'all'! name ^name! ! !TVariableNode methodsFor: 'all'! printOn: aStream level: level aStream nextPutAll: name.! ! !TVariableNode methodsFor: 'all'! setName: aString name _ aString.! ! I am a parse tree leaf representing a temporary variable! !TempVariableNode methodsFor: 'printing' stamp: 'sw 11/16/1999 16:37'! printOn: aStream indent: level aStream withAttributes: (Preferences syntaxAttributesFor: #temporaryVariable) do: [aStream nextPutAll: name]! ! !TempoEvent methodsFor: 'as yet unclassified' stamp: 'jm 9/10/1998 08:37'! printOn: aStream aStream nextPut: $(. time printOn: aStream. aStream nextPutAll: ': tempo '. ((120.0 * (500000.0 / tempo)) roundTo: 0.01) printOn: aStream. aStream nextPut: $). ! ! !Text methodsFor: 'accessing' stamp: 'ls 7/29/1998 01:17'! embeddedMorphs "return the list of morphs embedded in me" | morphs | morphs _ IdentitySet new. runs withStartStopAndValueDo: [ :start :stop :attribs | attribs do: [ :attrib | (attrib isKindOf: TextAnchor) ifTrue: [ morphs add: attrib anchoredMorph ] ] ]. ^morphs select: [ :m | m isKindOf: Morph ]! ! !Text methodsFor: 'accessing' stamp: 'di 11/23/1998 11:53'! findString: aString startingAt: start caseSensitive: caseSensitive "Answer the index of subString within the receiver, starting at index start. If the receiver does not contain subString, answer 0." ^string findString: aString asString startingAt: start caseSensitive: caseSensitive! ! !Text methodsFor: 'accessing' stamp: 'sw 12/7/1999 12:25'! rangeOf: attribute startingAt: index forStyle: aStyle "This is stupid, slow code, but it works" | start stop | start _ index. [start > 1 and: [(self attributesAt: (start - 1) forStyle: aStyle) includes: attribute]] whileTrue: [start _ start - 1]. stop _ index-1. [stop < self size and: [(self attributesAt: (stop + 1) forStyle: aStyle) includes: attribute]] whileTrue: [stop _ stop + 1]. ^ start to: stop! ! !Text methodsFor: 'comparing' stamp: 'di 1/29/2000 14:15'! = other | otherRuns | ^ other isText ifTrue: ["This is designed to run fast even for megabytes" otherRuns _ other asText runs. (string == other string or: [string = other string]) and: [runs == otherRuns or: [runs = otherRuns]]] ifFalse: [false]! ! !Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 12:30'! attributesAt: characterIndex "Answer the code for characters in the run beginning at characterIndex." "NB: no senders any more (supplanted by #attributesAt:forStyle: but retained for the moment in order not to break user code that may exist somewhere that still calls this" | attributes | self size = 0 ifTrue: [^ Array with: (TextFontChange new fontNumber: 1)]. "null text tolerates access" attributes _ runs at: characterIndex. ^ attributes! ! !Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 11:32'! attributesAt: characterIndex forStyle: aTextStyle "Answer the code for characters in the run beginning at characterIndex." | attributes | self size = 0 ifTrue: [^ Array with: (TextFontChange new fontNumber: aTextStyle defaultFontIndex)]. "null text tolerates access" attributes _ runs at: characterIndex. ^ attributes! ! !Text methodsFor: 'emphasis' stamp: 'di 4/1/1999 15:17'! emphasisAt: characterIndex "Answer the fontfor characters in the run beginning at characterIndex." | attributes emph | self size = 0 ifTrue: [^ 0]. "null text tolerates access" emph _ 0. attributes _ runs at: characterIndex. attributes do: [:att | emph _ emph bitOr: att emphasisCode]. ^ emph ! ! !Text methodsFor: 'emphasis' stamp: 'sw 12/7/1999 10:58'! fontAt: characterIndex withStyle: aTextStyle "Answer the fontfor characters in the run beginning at characterIndex." | attributes font | self size = 0 ifTrue: [^ aTextStyle defaultFont]. "null text tolerates access" attributes _ runs at: characterIndex. font _ aTextStyle defaultFont. "default" attributes do: [:att | att forFontInStyle: aTextStyle do: [:f | font _ f]]. ^ font! ! !Text methodsFor: 'emphasis' stamp: 'sma 2/5/2000 12:03'! makeSelectorBoldIn: aClass "For formatting Smalltalk source code, set the emphasis of that portion of the receiver's string that parses as a message selector to be bold." | parser | string size = 0 ifTrue: [^self]. (parser _ aClass parserClass new) parseSelector: string. self makeBoldFrom: 1 to: (parser endOfLastToken min: string size)! ! !Text methodsFor: 'printing' stamp: 'sma 6/1/2000 09:49'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' for '; print: string! ! !Text methodsFor: 'attributes' stamp: 'sw 11/9/1999 17:24'! askIfAddStyle: priorMethod req: requestor "Ask the user if we have a complex style (i.e. bold) for the first time" | tell answ old | (Preferences browseWithPrettyPrint and: [Preferences colorWhenPrettyPrinting]) ifTrue: [self couldDeriveFromPrettyPrinting ifTrue: [^ self asString]]. self runs coalesce. self unembellished ifTrue: [^ self asString]. priorMethod ifNotNil: [old _ priorMethod getSourceFromFile]. (old == nil or: [old unembellished]) ifTrue: [tell _ 'This method contains style (e.g. bold) for the first time. Do you really want to save the style info?'. answ _ (PopUpMenu labels: 'Save method with style Save method simply') startUpWithCaption: tell. answ = 2 ifTrue: [^ self asString]]! ! !Text methodsFor: 'attributes' stamp: 'sw 11/16/1999 22:33'! couldDeriveFromPrettyPrinting "Return true if the receiver has any TextAttributes that are functional rather than simply appearance-related" runs values do: [:emphArray | emphArray do: [:emph | emph couldDeriveFromPrettyPrinting ifFalse: [^ false]]]. ^ true! ! !Text methodsFor: 'attributes' stamp: 'sw 12/7/1999 12:31'! unembellished "Return true if the only emphases are the default font and bold" | font1 bold | font1 _ TextFontChange defaultFontChange. bold _ TextEmphasis bold. Preferences ignoreStyleIfOnlyBold ifFalse: ["Ignore font1 only or font1-bold followed by font1-plain" ^ (runs values = (Array with: (Array with: font1))) or: [runs values = (Array with: (Array with: font1 with: bold) with: (Array with: font1))]]. "If preference is set, then ignore any combo of font1 and bold" runs withStartStopAndValueDo: [:start :stop :emphArray | emphArray do: [:emph | (font1 = emph or: [bold = emph]) ifFalse: [^ false]]]. ^ true! ! !Text class methodsFor: 'instance creation' stamp: 'sw 12/6/1999 14:14'! fromString: aString "Answer an instance of me whose characters are those of the argument, aString." ^ self string: aString attribute: (TextFontChange fontNumber: TextStyle default defaultFontIndex)! ! !TextAction methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'! couldDeriveFromPrettyPrinting ^ false! ! !TextAction methodsFor: 'as yet unclassified' stamp: 'DSM 3/30/1999 13:15'! info ^ 'no hidden info'! ! TextAnchors support anchoring of images in text. A TextAnchor exists as an attribute of text emphasis, and it gets control like a FontReference, through the emphasizeScanner: message. Depending on whether its anchoredMorph is a Morph or a Form, it repositions the morph, or displays the form respectively. The coordination between composition, display and selection can best be understood by browsing the various implementations of placeEmbeddedObject:. In the morphic world, simply embed any morph in text. In the old world, you can create an image reference using code such as the following. ParagraphEditor new clipboardTextPut: (Text string: '*' attribute: (TextAnchor new anchoredMorph: Form fromUser)) In this case you select a piece of the screen, and it gets anchored to a one-character text in the editor's past buffer. If you then paste into some other text, you will see the image as an embedded image.! !TextAnchor methodsFor: 'as yet unclassified' stamp: 'di 7/1/1998 14:35'! = other ^ (other class == self class) and: [other anchoredMorph == anchoredMorph]! ! !TextAnchor methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'! couldDeriveFromPrettyPrinting ^ false! ! Tells a piece of text to be a certain way. Select text, press Command-6, choose a attribute. If selected text is of the form Hi There<Smalltalk beep> the part in angle brackets is saved for action, and the Hi There appears in the paragraph. If selection has no angle brackets, use the whole thing as both the text and the action. TextDoIt -- eval as a Smalltalk expression (the part in angle brackets) TextLink -- Show a method, class comment, class hierarchy, or class defintion. <Point extent:>, <Point Comment>, <Point Hierarchy>, or <Point Defintion> are what you type. TextURL -- Show the web page. <www.disney.com> These attributes of text need to be stored on the disk in a regular file-out. It is done in this form: (ascii 2)<!!do Smalltalk beep(ascii 3)>Hi There(ascii 3)<!!> (ascii 2)<!!li Point extent:(ascii 3)>Click here to see the extent: method(ascii 3)<!!> The brackets are for people to see in fileOuts. The wierd ascii are for the scanner to pick up easily. See RunArray class scanFrom: where decoding is done. ! ]style[(993 24 25)f1,f1LRunArray class scanFrom:;,f1! !TextAttribute methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:25'! couldDeriveFromPrettyPrinting "Answer whether the receiver is a kind of attribute that could have been generated by doing polychrome pretty-printing of a method without functional text attributes." ^ true! ! !TextAttribute methodsFor: 'as yet unclassified' stamp: 'di 4/1/1999 15:16'! emphasisCode "Subclasses may override to add bold, italic, etc" ^ 0! ! A TextColor encodes a text color change applicable over a given range of text.! !TextColor methodsFor: 'comparing' stamp: 'sma 3/24/2000 10:51'! hash ^ color hash! ! !TextColor methodsFor: 'printing' stamp: 'sma 3/24/2000 10:51'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' code: '; print: color! ! !TextColor class methodsFor: 'constants' stamp: 'sma 3/24/2000 10:50'! white ^ self new color: Color white! ! !TextColor class methodsFor: 'instance creation' stamp: 'sma 3/24/2000 10:49'! scanFrom: strm "read a color in the funny format used by Text styles on files. c125000255 or cblue;" | r g b | strm peek isDigit ifTrue: [r _ (strm next: 3) asNumber. g _ (strm next: 3) asNumber. b _ (strm next: 3) asNumber. ^ self color: (Color r: r g: g b: b range: 255)]. "A name of a color" ^ self color: (Color perform: (strm upTo: $;) asSymbol)! ! A TextContainer models the shape of an ownerMorph, possibly occluded by one or more occludingMorphs, and scans this shape to provide a list of rectangles suitable for layout of text. It does this by displaying the shadow of the ownerMorph in black, and any occludingMorphs in white, on its shadowForm. It then scans horizontal strips of appropriate height to find unbroken intervals of black, greater than minWidth in extent. Conputation of the rectangles is done on demand, and results are cached so that text can be redisplayed without having to recompute the rectangles.! !TextContainer methodsFor: 'container protocol' stamp: 'di 9/30/1998 23:17'! rectanglesAt: lineY height: lineHeight "Return a list of rectangles that are at least minWidth wide in the specified horizontal strip of the shadowForm. Cache the results for later retrieval if the owner does not change." | hProfile rects thisWidth thisX count pair outerWidth lineRect lineForm | pair _ Array with: lineY with: lineHeight. rects _ rectangleCache at: pair ifAbsent: [nil]. rects ifNotNil: [^ rects]. outerWidth _ minWidth + (2*OuterMargin). self shadowForm. "Compute the shape". lineRect _ 0@(lineY - shadowForm offset y) extent: shadowForm width@lineHeight. lineForm _ shadowForm copy: lineRect. "Check for a full line -- frequent case" (lineForm tallyPixelValues at: 2) = lineRect area ifTrue: [rects _ Array with: (shadowForm offset x@lineY extent: lineRect extent)] ifFalse: ["No such luck -- scan the horizontal profile for segments of minWidth" hProfile _ lineForm xTallyPixelValue: 1 orNot: false. rects _ OrderedCollection new. thisWidth _ 0. thisX _ 0. 1 to: hProfile size do: [:i | count _ hProfile at: i. count >= lineHeight ifTrue: [thisWidth _ thisWidth + 1] ifFalse: [thisWidth >= outerWidth ifTrue: [rects addLast: ((thisX + shadowForm offset x)@lineY extent: thisWidth@lineHeight)]. thisWidth _ 0. thisX _ i]]. thisWidth >= outerWidth ifTrue: [rects addLast: ((thisX + shadowForm offset x)@lineY extent: thisWidth@lineHeight)]]. rects _ rects collect: [:r | r insetBy: OuterMargin@0]. rectangleCache at: pair put: rects. ^ rects! ! !TextContainer methodsFor: 'private' stamp: 'jm 10/15/2002 16:31'! bounds | bounds theText | self fillsOwner ifFalse: [^ textMorph textBounds]. theText _ textMorph. bounds _ theText owner bounds. theText owner submorphsBehind: theText do: [:m | bounds _ bounds merge: m fullBounds]. ^ bounds! ! !TextContainer methodsFor: 'private' stamp: 'jm 11/24/2002 10:49'! computeShadow | canvas back bounds theText | bounds _ self bounds. theText _ textMorph. canvas _ (FormCanvas extent: bounds extent depth: 1) shadowColor: Color black. canvas translateBy: bounds topLeft negated during:[:tempCanvas| self fillsOwner ifTrue: [(theText owner copyWithoutSubmorph: theText) fullDrawOn: tempCanvas] ifFalse: [tempCanvas fillRectangle: textMorph bounds color: Color black]. self avoidsOcclusions ifTrue: [back _ tempCanvas form deepCopy. tempCanvas form fillWhite. theText owner submorphsInFrontOf: theText do: [:m | (textMorph isLinkedTo: m) ifTrue: [] ifFalse: [m fullDrawOn: tempCanvas]]. back displayOn: tempCanvas form at: 0@0 rule: Form reverse]. ]. shadowForm _ canvas form offset: bounds topLeft. vertProfile _ shadowForm yTallyPixelValue: 1 orNot: false. rectangleCache _ Dictionary new. ^ shadowForm! ! !TextDiffBuilder methodsFor: 'printing' stamp: 'sma 5/6/2000 18:15'! printPatchSequence: seq on: aStream seq do: [:assoc | aStream withAttribute: (self attributeOf: assoc key) do: [aStream nextPutAll: assoc value; cr]]! ! !TextDiffBuilder methodsFor: 'initialize' stamp: 'ar 11/20/1998 18:17'! destString: aString realDst := self split: aString asString. dstLines := OrderedCollection new. dstMap := OrderedCollection new. realDst doWithIndex:[:line :realIndex| "(line contains:[:anyChar| anyChar isSeparator not]) ifTrue:[" dstLines add: line. dstMap add: realIndex. "]." ]. dstPos := PluggableDictionary new: dstLines size. dstPos hashBlock: self stringHashBlock. dstLines doWithIndex:[:line :index| (dstPos includesKey: line) ifTrue:[(dstPos at: line) add: index. multipleMatches := true] ifFalse:[dstPos at: line put: (OrderedCollection with: index)]].! ! !TextDiffBuilder methodsFor: 'initialize'! from: sourceString to: destString self sourceString: sourceString. self destString: destString.! ! !TextDiffBuilder methodsFor: 'initialize' stamp: 'ar 11/20/1998 18:17'! sourceString: aString realSrc := self split: aString asString. srcLines := OrderedCollection new. srcMap := OrderedCollection new. realSrc doWithIndex:[:line :realIndex| "(line contains:[:anyChar| anyChar isSeparator not]) ifTrue:[" srcLines add: line. srcMap add: realIndex. "]." ]. srcPos := PluggableDictionary new: srcLines size. srcPos hashBlock: self stringHashBlock. srcLines doWithIndex:[:line :index| (srcPos includesKey: line) ifTrue:[(srcPos at: line) add: index. multipleMatches := true] ifFalse:[srcPos at: line put: (OrderedCollection with: index)]].! ! !TextDiffBuilder methodsFor: 'initialize'! split: aString ^self split: aString by: self splitCharacter! ! !TextDiffBuilder methodsFor: 'testing'! hasMultipleMatches ^multipleMatches == true! ! !TextDiffBuilder methodsFor: 'creating patches'! buildDisplayPatch ^Text streamContents:[:stream| self printPatchSequence: self buildPatchSequence on: stream. ]! ! !TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:35'! buildPatchSequence "@@ TODO: Das funktioniert noch nicht fŸr n-m matches" matches := PluggableDictionary new. matches hashBlock: self pointHashBlock. self buildReferenceMap. runs := self processDiagonals. self validateRuns: runs. "There may be things which have just been moved around. Find those." shifted := self detectShiftedRuns. self processShiftedRuns. "Now generate a patch sequence" patchSequence := self generatePatchSequence. ^patchSequence! ! !TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:57'! buildReferenceMap dstLines doWithIndex:[:line :index| (srcPos at: line ifAbsent:[#()]) do:[:index2| matches at: index@index2 put: line] ]. srcLines doWithIndex:[:line :index| (dstPos at: line ifAbsent:[#()]) do:[:index2| matches at: index2@index put: line] ]. ! ! !TextDiffBuilder methodsFor: 'creating patches'! collectRunFrom: todo startingWith: startIndex into: run | next start | start := startIndex. self remove: start from: todo. run add: (matches at: start). "Search downwards" next := start. [next := next + (1@1). todo includes: next] whileTrue:[ run addLast: (matches at: next). self remove: next from: todo]. "Search upwards" next := start. [next := next - (1@1). todo includes: next] whileTrue:[ run addFirst: (matches at: next). self remove: next from: todo. start := next. "To use the first index" ]. ^start! ! !TextDiffBuilder methodsFor: 'creating patches'! detectShiftedRuns | sortedRuns lastY run shiftedRuns | runs size < 2 ifTrue: [^ nil]. shiftedRuns _ OrderedCollection new. sortedRuns _ SortedCollection sortBlock: [:a1 :a2 | a1 key x < a2 key x]. runs associationsDo: [:assoc | sortedRuns add: assoc]. lastY _ sortedRuns first key y. 2 to: sortedRuns size do:[:i | run _ sortedRuns at: i. run key y > lastY ifTrue: [lastY _ run key y] ifFalse: [shiftedRuns add: run]]. ^ shiftedRuns! ! !TextDiffBuilder methodsFor: 'creating patches'! generatePatchSequence | ps | ps := OrderedCollection new: srcLines size. srcLines size timesRepeat:[ps add: nil]. self incorporateMatchesInto: ps. self incorporateRemovalsInto: ps. self incorporateAddsInto: ps. ^ps! ! !TextDiffBuilder methodsFor: 'creating patches' stamp: 'di 3/15/1999 14:01'! incorporateAddsInto: aPatchSequence "Incorporate adds" | lastMatch lastIndex index | added ifNil:[^self]. added := added sortBy:[:a1 :a2| a1 key < a2 key]. lastMatch := 1. lastIndex := 0. 1 to: added size do:[:i| index := (added at: i) key. [index > lastMatch] whileTrue:[ [lastIndex := lastIndex + 1. (aPatchSequence at: lastIndex) key == #match] whileFalse. lastMatch := lastMatch + 1. ]. aPatchSequence add: #insert->(added at: i) value afterIndex: lastIndex. lastIndex := lastIndex + 1. lastMatch := lastMatch + 1. ].! ! !TextDiffBuilder methodsFor: 'creating patches'! incorporateMatchesInto: aPatchSequence "Incorporate matches" | index | runs associationsDo:[:assoc| index := assoc key y. assoc value do:[:line| self assert:[(aPatchSequence at: index) isNil]. aPatchSequence at: index put: (#match -> line). index := index + 1. ]. ]. ! ! !TextDiffBuilder methodsFor: 'creating patches'! incorporateRemovalsInto: aPatchSequence "Incorporate removals" | index | removed ifNil:[^self]. removed do:[:assoc| index := assoc key. self assert:[(aPatchSequence at: index) isNil]. aPatchSequence at: index put: #remove -> assoc value. ]. ! ! !TextDiffBuilder methodsFor: 'creating patches'! processDiagonals ^self processDiagonalsFrom: matches keys asSet ! ! !TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 16:34'! processDiagonalsFrom: todoList | runList start run todo | todo := todoList copy. runList := PluggableDictionary new. runList hashBlock: self pointHashBlock. [todo isEmpty] whileFalse:[ start := todo detect:[:any| true]. run := OrderedCollection new. start := self collectRunFrom: todo startingWith: start into: run. runList at: start put: run. ]. "If we have multiple matches we might have chosen a bad sequence. There we redo the whole thing recursively" self hasMultipleMatches ifFalse:[^runList]. runList size < 2 ifTrue:[^runList]. run := nil. start := 0. runList associationsDo:[:assoc| (run isNil or:[assoc value size > run size]) ifTrue:[ run := assoc value. start := assoc key]]. "Now found the longest run" run := OrderedCollection new. start := self collectRunFrom: todoList startingWith: start into: run. "Find the diagonals in the remaining set" runList := self processDiagonalsFrom: todoList. runList at: start put: run. ^runList! ! !TextDiffBuilder methodsFor: 'creating patches'! processShiftedRuns | key | shifted isNil ifTrue:[^self]. shifted do:[:assoc| key := assoc key. assoc value doWithIndex:[:line :idx| removed add: (key y + idx - 1) -> line. added add: (key x + idx - 1) -> line]. runs removeKey: assoc key. ]. ! ! !TextDiffBuilder methodsFor: 'creating patches' stamp: 'ar 11/20/1998 17:26'! validateRuns: runList | srcPosCopy dstPosCopy lines srcIndex dstIndex | srcPosCopy _ srcPos copy. srcPosCopy associationsDo:[:assoc| assoc value: assoc value asSet]. dstPosCopy _ dstPos copy. dstPosCopy associationsDo:[:assoc| assoc value: assoc value asSet]. runList associationsDo:[:assoc| srcIndex := assoc key y. dstIndex := assoc key x. lines := assoc value. lines do:[:string| (srcPosCopy at: string) remove: srcIndex. (dstPosCopy at: string) remove: dstIndex. srcIndex := srcIndex + 1. dstIndex := dstIndex + 1. ]. ]. removed := OrderedCollection new. srcPosCopy associationsDo:[:assoc| assoc value do:[:index| removed add: (index -> assoc key)]. ]. removed := removed sortBy:[:a1 :a2| a1 key < a2 key]. added := OrderedCollection new. dstPosCopy associationsDo:[:assoc| assoc value do:[:index| added add: (index -> assoc key)]. ]. added := added sortBy:[:a1 :a2| a1 key < a2 key]. ! ! !TextDiffBuilder methodsFor: 'private' stamp: 'sma 5/6/2000 18:13'! attributeOf: type "Private. Answer a TextAttribute that is used to display text of the given type." type == #insert ifTrue: [^ TextColor red]. type == #remove ifTrue: [^ TextEmphasis struckOut]. ^ TextEmphasis normal! ! !TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 16:35'! pointHashBlock ^[:pt| (pt x bitShift: 12) + pt y] fixTemps! ! !TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 16:31'! remove: pointKey from: aSet self hasMultipleMatches ifFalse:[^aSet remove: pointKey]. aSet copy do:[:obj| obj x = pointKey x ifTrue:[ aSet remove: obj. ] ifFalse:[ obj y = pointKey y ifTrue:[ aSet remove: obj. ]. ] ]. ! ! !TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/20/1998 17:26'! split: aString by: splitChar | lines index nextIndex | lines := OrderedCollection new. index _ 1. [index <= aString size] whileTrue:[ nextIndex _ aString indexOf: splitChar startingAt: index ifAbsent:[aString size+1]. lines add: (aString copyFrom: index to: nextIndex-1). index _ nextIndex+1]. ^lines! ! !TextDiffBuilder methodsFor: 'private'! splitCharacter ^Character cr! ! !TextDiffBuilder methodsFor: 'private' stamp: 'ar 11/24/1998 13:41'! stringHashBlock "Return a block for use in string hashing" | stringSize | ^[:string| stringSize _ string size. stringSize = 0 ifTrue:[0] ifFalse:[ stringSize < 3 ifTrue:[(string at: 1) asInteger + ((string at: string size) asInteger bitShift: 8)] ifFalse:[ (string at: 1) asInteger + ((string at: stringSize // 3 + 1) asInteger bitShift: 4) + ((string at: stringSize // 2 + 1) asInteger bitShift: 8) + ((string at: stringSize * 2 // 3 + 1) asInteger bitShift: 12) + ((string at: stringSize) asInteger bitShift: 16)]]] fixTemps! ! !TextDiffBuilder class methodsFor: 'instance creation'! buildDisplayPatchFrom: srcString to: dstString ^(self from: srcString to: dstString) buildDisplayPatch! ! !TextDiffBuilder class methodsFor: 'instance creation'! from: srcString to: dstString ^self new from: srcString to: dstString! ! A TextEmphasis, encodes a characteristic applicable to all fonts. The encoding is as follows: 1 bold 2 itallic 4 underlined 8 narrow 16 struck out! A TextFontChange encodes a font change applicable over a given range of text. The font number is interpreted relative to the textStyle governing display of this text.! !TextFontChange class methodsFor: 'as yet unclassified' stamp: 'sw 12/6/1999 17:52'! defaultFontChange "Answer a TextFontChange that represents the default font" ^ self new fontNumber: TextStyle default defaultFontIndex! ! A TextFontReference encodes a font change applicable over a given range of text. The font reference is absolute: unlike a TextFontChange, it is independent of the textStyle governing display of this text.! !TextFontReference methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:22'! couldDeriveFromPrettyPrinting ^ false! ! !TextFontReference methodsFor: 'as yet unclassified' stamp: 'di 5/10/1999 23:47'! font ^ font! ! !TextFontReference methodsFor: 'comparing' stamp: 'mas 5/7/1999 06:20'! = other ^ (other class == self class) and: [other font == font]! ! create a hanging indent. ! !TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'! amount "number of tab spaces to indent by" ^amount! ! !TextIndent methodsFor: 'access' stamp: 'ls 6/22/1998 17:51'! amount: anInteger "change the number of tabs to indent by" amount _ anInteger! ! !TextIndent methodsFor: 'printing' stamp: 'ls 6/22/1998 18:03'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' amount: '. amount printOn: aStream! ! !TextIndent methodsFor: 'setting indentation' stamp: 'ls 6/22/1998 18:56'! emphasizeScanner: scanner scanner indentationLevel: amount! ! !TextIndent methodsFor: 'condensing' stamp: 'ls 6/22/1998 19:27'! dominates: anAttribute ^(self class == anAttribute class)! ! !TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:55'! amount: amount "create a TextIndent which will indent by the given amount. Currently this is a number of tabs, but may change in the futur" ^super new amount: amount! ! !TextIndent class methodsFor: 'instance creation' stamp: 'ls 6/27/1998 15:54'! tabs: numTabs "create an indentation by the given number of tabs" ^self amount: numTabs! ! !TextIndent class methodsFor: 'example' stamp: 'jm 7/23/2003 16:15'! example "Display an example text with some color-coded indentations." "TextIndent example" | text pg r | text _ 'How now brown cow? How much wood would a woodchuck chuck if a woodchuck could chuck wood? He was born with the gift of laughter and a conviction that the world was mad.' asText. text addAttribute: (TextColor red) from: 1 to: 18. text addAttribute: (TextIndent amount: 1) from: 1 to: 18. text addAttribute: (TextColor blue) from: 90 to: 127. text addAttribute: (TextIndent amount: 2) from: 90 to: 127. "stick it in a paragraph and display it" pg _ text asParagraph. r _ 0@0 extent: 150@500. pg compositionRectangle: r; clippingRectangle: r. pg displayAt: 0@0. ! ! !TextIndent class methodsFor: 'example' stamp: 'jm 7/23/2003 16:19'! example2 "Display an example text with some color-coded indentations." "TextIndent example2" | text m | text _ 'How now brown cow? How much wood would a woodchuck chuck if a woodchuck could chuck wood? He was born with the gift of laughter and a conviction that the world was mad.' asText. text addAttribute: (TextColor red) from: 1 to: 18. text addAttribute: (TextIndent amount: 1) from: 1 to: 18. text addAttribute: (TextColor blue) from: 90 to: 127. text addAttribute: (TextIndent amount: 2) from: 90 to: 127. m _ TextMorph new extent: 150@500. m contentsWrapped: text. m openInWorld. ! ! A TextKern encodes a kerning change applicable over a given range of text. Positive values of kern spread letters out, negative kern will cause them to overlap more. Note that kerns other than 0 will display somewhat slower, as kerning is not yet supported in the text scanning primitive. ! !TextKern methodsFor: 'as yet unclassified' stamp: 'sw 11/9/1999 17:21'! couldDeriveFromPrettyPrinting ^ false! ! !TextKern methodsFor: 'as yet unclassified' stamp: 'tk 9/21/1999 15:57'! writeScanOn: strm kern > 0 ifTrue: [ 1 to: kern do: [:kk | strm nextPut: $+]]. kern < 0 ifTrue: [ 1 to: 0-kern do: [:kk | strm nextPut: $-]].! ! A TextLine embodies the layout of a line of composed text. left right top bottom The full line rectangle firstIndex lastIndex Starting and stopping indices in the full text internalSpaces Number of spaces to share paddingWidth paddingWidth Number of pixels of extra space in full line baseline Distance of baseline below the top of the line leftMargin Left margin due to paragraph indentation TextLine's rather verbose message protocol is required for compatibility with the old CharacterScanners.! !TextLine methodsFor: 'updating' stamp: 'di 4/28/1999 11:12'! slideIndexBy: delta andMoveTopTo: newTop "Relocate my character indices and y-values. Used to slide constant text up or down in the wake of a text replacement." firstIndex _ firstIndex + delta. lastIndex _ lastIndex + delta. bottom _ bottom + (newTop - top). top _ newTop. ! ! My instances specify the starting and stopping points in a String of a composed line. The step is always 1.! I support display of (possibly) multiple lines of text that includes a mixture of different fonts and styles. I also support text-editing capabilities, as well as imbedded hot links, and the ability to embed submorphs in the text. When a TextMorph has been embedded into another Morph, one can elect to make the text fill its owner's bounds, in which case the text will be laid out in the shape of the owner's shadow image (including any submorphs other than the TextMorph itself). One can also elect to have the text flow around occlusions, in which case it will avoid the bounds of any sibling morphs that appear in front of it. It may be necessary to update the bounds in order for the text runaround to notice the presence of a new occluding shape. ! !TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:34'! string: aString fontName: aName size: aSize self string: aString fontName: aName size: aSize wrap: true! ! !TextMorph methodsFor: 'initialization' stamp: 'mir 8/2/1999 10:35'! string: aString fontName: aName size: aSize wrap: shouldWrap shouldWrap ifTrue: [self contentsWrapped: aString] ifFalse: [self contents: aString]. self fontName: aName size: aSize! ! !TextMorph methodsFor: 'accessing' stamp: 'di 10/5/1998 13:56'! editor "Return my current editor, or install a new one." editor ifNotNil: [^ editor]. ^ self installEditorToReplace: nil! ! !TextMorph methodsFor: 'accessing' stamp: 'mir 8/2/1999 10:33'! fontName: fontName size: fontSize | newTextStyle | newTextStyle _ (TextStyle named: fontName asSymbol) copy. newTextStyle ifNil: [self halt: 'Error: font ', fontName, ' not found.']. textStyle _ newTextStyle. text addAttribute: (TextFontChange fontNumber: (newTextStyle fontIndexOfSize: fontSize)). paragraph ifNotNil: [paragraph textStyle: newTextStyle]! ! !TextMorph methodsFor: 'accessing' stamp: 'dvf 6/16/2000 17:40'! newContents: stringOrText "Accept new text contents." | newText embeddedMorphs | newText _ stringOrText asText. text = newText ifTrue: [^ self]. "No substantive change" text ifNotNil: [(embeddedMorphs _ text embeddedMorphs) ifNotNil: [self removeAllMorphsIn: embeddedMorphs. embeddedMorphs do: [:m | m delete]]]. text _ newText. "add all morphs off the visible region; they'll be moved into the right place when they become visible. (this can make the scrollable area too large, though)" stringOrText asText embeddedMorphs do: [:m | self addMorph: m. m position: -1000 @ 0]. self releaseParagraph. "update the paragraph cache" self paragraph. "re-instantiate to set bounds" self world ifNotNil: [self world startSteppingSubmorphsOf: self]! ! !TextMorph methodsFor: 'drawing' stamp: 'di 6/22/1998 10:55'! drawBoundsOn: aCanvas "Shows where line boundaries are" self paragraph lines do: [:line | aCanvas frameRectangle: line rectangle color: Color brown] ! ! !TextMorph methodsFor: 'drawing' stamp: 'di 6/22/1998 10:39'! drawNullTextOn: aCanvas "make null text frame visible" aCanvas fillRectangle: bounds color: Color lightRed ! ! !TextMorph methodsFor: 'drawing'! drawOn: aCanvas self setDefaultContentsIfNil. "self drawBoundsOn: aCanvas." "show line rects for debugging" self startingIndex > text size ifTrue: [self drawNullTextOn: aCanvas] ifFalse: [aCanvas paragraph: self paragraph bounds: bounds color: color]. ! ! !TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! chooseAlignment self editor changeAlignment. self updateFromParagraph! ! !TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! chooseEmphasis self editor changeEmphasis. self updateFromParagraph! ! !TextMorph methodsFor: 'editing' stamp: 'sw 9/27/1999 12:13'! chooseEmphasisOrAlignment self editor changeEmphasisOrAlignment. self updateFromParagraph! ! !TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! chooseFont self editor offerFontMenu. self updateFromParagraph! ! !TextMorph methodsFor: 'editing' stamp: 'di 10/5/1998 13:55'! chooseStyle self editor changeStyle. self updateFromParagraph! ! !TextMorph methodsFor: 'editing' stamp: 'RAA 6/15/2000 13:43'! handleInteraction: interactionBlock fromEvent: evt | oldEditor oldParagraph | "Perform the changes in interactionBlock, noting any change in selection" "Also couple ParagraphEditor to Morphic keyboard events" self editor sensor: (KeyboardBuffer new startingEvent: evt). oldEditor _ editor. oldParagraph _ paragraph. self selectionChanged. "Note old selection" interactionBlock value. oldParagraph == paragraph ifTrue: [ "this will not work if the paragraph changed" editor _ oldEditor. "since it may have been changed while in block" ]. self selectionChanged. "Note new selection"! ! !TextMorph methodsFor: 'editing' stamp: 'di 8/11/1998 13:04'! handlesMouseDown: evt self isPartsDonor ifTrue: [^ false]. ^ self uncoveredAt: evt cursorPoint ! ! !TextMorph methodsFor: 'editing' stamp: 'di 6/7/1999 15:51'! keyboardFocusChange: aBoolean | w | aBoolean ifTrue: ["A hand is wanting to send us characters..." self hasFocus ifFalse: [self editor "Forces install"]] ifFalse: ["A hand has clicked elsewhere..." (w _ self world) == nil ifFalse: [w handsDo: [:h | h keyboardFocus == self ifTrue: [^ self]]. "Release control unless some hand is still holding on" self releaseEditor]]. ! ! !TextMorph methodsFor: 'editing' stamp: 'di 6/7/1999 15:56'! passKeyboardFocusTo: otherMorph | w | (w _ self world) == nil ifFalse: [w handsDo: [:h | h keyboardFocus == self ifTrue: [h newKeyboardFocus: otherMorph]]]. ! ! !TextMorph methodsFor: 'geometry' stamp: 'di 10/8/1998 23:46'! bounds container ifNil: [^ bounds]. ^ container bounds ifNil: [bounds]! ! !TextMorph methodsFor: 'geometry' stamp: 'di 1/28/1999 09:20'! container "Return the container for composing this text. There are four cases: 1. container is specified as, eg, an arbitrary shape, 2. container is specified as the bound rectangle, because this morph is linked to others, 3. container is nil, and wrap is true -- grow downward as necessary, 4. container is nil, and wrap is false -- grow in 2D as nexessary." container ifNil: [successor ifNotNil: [^ self bounds]. wrapFlag ifTrue: [^ self bounds withHeight: 9999999]. ^ self position extent: 9999999@9999999]. ^ container! ! !TextMorph methodsFor: 'geometry' stamp: 'di 1/13/1999 14:11'! containsPoint: aPoint (super containsPoint: aPoint) ifFalse: [^false]. self startingIndex > text size ifTrue: ["make null text frame visible" ^ super containsPoint: aPoint]. ^ self paragraph containsPoint: aPoint ! ! !TextMorph methodsFor: 'geometry' stamp: 'di 8/14/1998 15:50'! defaultLineHeight ^ textStyle lineGrid! ! !TextMorph methodsFor: 'geometry' stamp: 'di 4/27/2000 10:37'! privateMoveBy: delta editor == nil ifTrue: [super privateMoveBy: delta. paragraph ifNotNil: [paragraph moveBy: delta]] ifFalse: ["When moving text with an active editor, save and restore all state." super privateMoveBy: delta. paragraph moveBy: delta. self installEditorToReplace: editor] ! ! !TextMorph methodsFor: 'menu' stamp: 'jm 10/19/2002 09:32'! addCustomMenuItems: aCustomMenu hand: aHandMorph | outer | super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'add predecessor' action: #addPredecessor:. aCustomMenu add: 'add successor' action: #addSuccessor:. outer _ self owner. ((outer isKindOf: PolygonMorph) and: [outer isOpen]) ifFalse: [ (container == nil or: [container fillsOwner not]) ifTrue: [aCustomMenu add: 'fill owner''s shape' action: #fillingOnOff] ifFalse: [aCustomMenu add: 'rectangluar bounds' action: #fillingOnOff]. (container == nil or: [container avoidsOcclusions not]) ifTrue: [aCustomMenu add: 'avoid occlusions' action: #occlusionsOnOff] ifFalse: [aCustomMenu add: 'ignore occlusions' action: #occlusionsOnOff]]. ! ! !TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 13:53'! installEditor "Install an editor for my paragraph. This constitutes 'hasFocus'." editor ifNotNil: [^ editor]. ^ self installEditorToReplace: nil! ! !TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 17:04'! installEditorToReplace: priorEditor "Install an editor for my paragraph. This constitutes 'hasFocus'. If priorEditor is not nil, then initialize the new editor from its state. We may want to rework this so it actually uses the prior editor." | stateArray | priorEditor ifNotNil: [stateArray _ priorEditor stateArray]. editor _ TextMorphEditor new morph: self. editor changeParagraph: self paragraph. priorEditor ifNotNil: [editor stateArrayPut: stateArray]. self selectionChanged. ^ editor! ! !TextMorph methodsFor: 'private' stamp: 'jm 10/15/2002 16:32'! paragraph "Paragraph instantiation is lazy -- create it only when needed" paragraph ifNotNil: [^ paragraph]. self setDefaultContentsIfNil. "...code here to recreate the paragraph..." paragraph _ (self paragraphClass new textOwner: self owner) compose: text style: textStyle copy from: self startingIndex in: self container. wrapFlag ifFalse: [ "was given huge container at first... now adjust" paragraph adjustRightX]. self fit. ^ paragraph ! ! !TextMorph methodsFor: 'private' stamp: 'di 10/5/1998 16:39'! releaseEditor "Release the editor for my paragraph. This morph no longer 'hasFocus'." editor ifNotNil: [self selectionChanged. self paragraph selectionStart: nil selectionStop: nil. editor _ nil].! ! !TextMorph methodsFor: 'private' stamp: 'di 1/19/2000 15:47'! updateFromParagraph "A change has taken place in my paragraph, as a result of editing and I must be updated. If a line break causes recomposition of the current paragraph, or it the selection has entered a different paragraph, then the current editor will be release, and must be reinstalled with the resulting new paragraph, while retaining any editor state, such as selection, undo state, and current typing emphasis." | newStyle sel oldLast oldEditor | paragraph ifNil: [^ self]. wrapFlag ifNil: [wrapFlag _ true]. editor ifNotNil: [oldEditor _ editor. sel _ editor selectionInterval. editor storeSelectionInParagraph]. text _ paragraph text. paragraph textStyle = textStyle ifTrue: [self fit] ifFalse: ["Broadcast style changes to all morphs" newStyle _ paragraph textStyle. (self firstInChain text: text textStyle: newStyle) recomposeChain. editor ifNotNil: [self installEditorToReplace: editor]]. super layoutChanged. sel ifNil: [^ self]. "If selection is in top line, then recompose predecessor for possible ripple-back" predecessor ifNotNil: [sel first <= (self paragraph lines first last+1) ifTrue: [oldLast _ predecessor lastCharacterIndex. predecessor paragraph recomposeFrom: oldLast to: text size delta: 0. oldLast = predecessor lastCharacterIndex ifFalse: [predecessor changed. "really only last line" self predecessorChanged]]]. ((predecessor~~nil and: [sel first <= self paragraph firstCharacterIndex]) or: [successor~~nil and: [sel first > (self paragraph lastCharacterIndex+1)]]) ifTrue: ["The selection is no longer inside this paragraph. Pass focus to the paragraph that should be in control." self firstInChain withSuccessorsDo: [:m | (sel first between: m firstCharacterIndex and: m lastCharacterIndex+1) ifTrue: [m installEditorToReplace: editor. ^ self passKeyboardFocusTo: m]]. self error: 'Inconsistency in text editor' "Must be somewhere in the successor chain"]. editor ifNil: ["Reinstate selection after, eg, style change" self installEditorToReplace: oldEditor] ! ! !TextMorph methodsFor: 'containment' stamp: 'sw 6/25/1998 10:44'! ownerChanged super ownerChanged. container ifNotNil: [self releaseParagraph]! ! !TextMorph methodsFor: 'containment' stamp: 'tk 9/28/1999 16:50'! privateOwner: newOwner "Nil the container when text gets extracted" super privateOwner: newOwner. container ifNotNil: [ newOwner ifNotNil: [ newOwner isWorldOrHandMorph ifTrue: [self setContainer: nil]]]! ! !TextMorph methodsFor: 'anchors' stamp: 'tk 6/30/1998 17:06'! acceptDroppingMorph: aMorph event: evt "This message is sent when a morph is dropped onto me." self addMorphFront: aMorph fromWorldPosition: aMorph position. "Make a TextAnchor and install it in a run."! ! !TextMorph methodsFor: 'anchors' stamp: 'ar 11/15/1998 23:42'! addMorphFront: aMorph fromWorldPosition: wp "Overridden for more specific re-layout and positioning" | i | self addMorphFront: aMorph. i _ (self paragraph characterBlockAtPoint: (self transformFromWorld globalPointToLocal: wp)) stringIndex. self paragraph replaceFrom: i to: i-1 with: (Text string: '*' attribute: (TextAnchor new anchoredMorph: aMorph)) displaying: false. self fit! ! !TextMorph class methodsFor: 'as yet unclassified' stamp: 'jm 5/31/2003 20:01'! includeInNewMorphMenu ^ true ! ! I am an editor for TextMorphs. ! !TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'! morph ^ morph! ! !TextMorphEditor methodsFor: 'accessing' stamp: 'tk 1/13/1999 07:53'! morph: aMorph "Install a link back to the morph being edited (esp for text links)" morph _ aMorph ! ! !TextMorphEditor methodsFor: 'events' stamp: 'di 9/8/1999 11:48'! mouseDown: evt "An attempt to break up the old processRedButton code into threee phases" | clickPoint | oldInterval _ startBlock stringIndex to: stopBlock stringIndex - 1. clickPoint _ evt cursorPoint. (paragraph clickAt: clickPoint for: model controller: self) ifTrue: [ evt hand newKeyboardFocus: nil. ^ self]. sensor leftShiftDown ifFalse: [self closeTypeIn. stopBlock _ startBlock _ pivotBlock _ paragraph characterBlockAtPoint: clickPoint] ifTrue: [(paragraph characterBlockAtPoint: clickPoint) <= startBlock ifTrue: [stopBlock _ startBlock. pivotBlock _ stopBlock] ifFalse: [startBlock _ stopBlock. pivotBlock _ startBlock]. self closeTypeIn]. self storeSelectionInParagraph! ! !TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:12'! mouseMove: evt "Change the selection in response to moue-down drag" | dragBlock | pivotBlock ifNil: [^ self]. "Patched during clickAt: repair" dragBlock _ paragraph characterBlockAtPoint: (evt cursorPoint). dragBlock > pivotBlock ifTrue: [stopBlock _ dragBlock. startBlock _ pivotBlock] ifFalse: [startBlock _ dragBlock. stopBlock _ pivotBlock]. self storeSelectionInParagraph! ! !TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:12'! mouseUp: evt "An attempt to break up the old processRedButton code into threee phases" oldInterval ifNil: [^ self]. "Patched during clickAt: repair" (startBlock = stopBlock and: [oldInterval = (startBlock stringIndex to: startBlock stringIndex-1)]) ifTrue: [self selectWord]. self setEmphasisHere. (self isDisjointFrom: oldInterval) ifTrue: [otherInterval _ oldInterval]. self storeSelectionInParagraph! ! !TextMorphEditor methodsFor: 'events' stamp: 'di 6/14/1998 13:11'! readKeyboard super readKeyboard. self storeSelectionInParagraph! ! !TextMorphEditor methodsFor: 'menu commands' stamp: 'di 10/9/1998 16:55'! cancel "Cancel the changes made so far to this text" morph cancelEdits! ! !TextMorphEditor methodsFor: 'menu commands' stamp: 'jm 10/13/2002 18:57'! changeEmphasis: characterStream "Intercept requests to create a link (Cmd-6). Make them simpler for end-user editing. SystemWidows use ParagraphEditor's complex commands." | keyCode attribute index colors theSelection labels | "Test if it's really the droids we're looking for..." keyCode _ ('0123456789-=' indexOf: sensor keyboardPeek ifAbsent: [1]) - 1. keyCode ~= 6 ifTrue: [^ super changeEmphasis: characterStream]. "underline, bold, etc." (morph isKindOf: TextMorphForEditView) ifTrue: [ ^ super changeEmphasis: characterStream]. "if in a browser, show all choices" sensor keyboard. "Yes, it is Cmd-6; consume the command character" theSelection _ self selection. colors _ #(black magenta red yellow green blue cyan white). labels _ colors, #(active). index _ (PopUpMenu labelArray: labels lines: (Array with: colors size)) startUp. index = 0 ifTrue: [^ true]. index <= colors size ifTrue: [attribute _ TextColor color: (Color perform: (colors at: index))]. index = (colors size + 1) ifTrue: [attribute _ TextDoIt new. theSelection _ attribute analyze: self selection asString]. self replaceSelectionWith: (theSelection asText addAttribute: attribute). ^ true! ! !TextMorphEditor methodsFor: 'menu commands' stamp: 'di 10/5/1998 21:48'! find super find. morph installEditorToReplace: self! ! !TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 6/22/1998 01:32'! againOrSame: bool super againOrSame: bool. morph editView selectionInterval: self selectionInterval! ! !TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 17:06'! selectAndScrollToTop "Scroll until the selection is in the view and then highlight it." | lineHeight deltaY rect deltaX | lineHeight _ paragraph textStyle lineGrid. rect _ morph owner bounds. deltaY _ stopBlock top - rect top. deltaY ~= 0 ifTrue: [ deltaX _ 0. deltaY _ (deltaY abs + lineHeight - 1 truncateTo: lineHeight) negated. morph editView scrollBy: deltaX@deltaY]! ! !TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sbw 10/14/1999 16:51'! selectForTopFrom: start to: stop self selectFrom: start to: stop. morph editView ifNotNil: [self selectAndScrollToTop]! ! !TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'di 6/14/1998 13:12'! selectFrom: start to: stop "Select the specified characters inclusive." self selectInvisiblyFrom: start to: stop. self closeTypeIn. self storeSelectionInParagraph! ! !TextMorphEditor methodsFor: 'mvc compatibility' stamp: 'sw 12/7/1999 12:27'! zapSelectionWith: aText "**overridden to inhibit old-style display" | start stop | self deselect. start _ startBlock stringIndex. stop _ stopBlock stringIndex. (aText isEmpty and: [stop > start]) ifTrue: ["If deleting, then set emphasisHere from 1st character of the deletion" emphasisHere _ (paragraph text attributesAt: start forStyle: paragraph textStyle) select: [:att | att mayBeExtended]]. (start = stop and: [aText size = 0]) ifFalse: [paragraph replaceFrom: start to: stop - 1 with: aText displaying: false. "** was true in super" self computeIntervalFrom: start to: start + aText size - 1. UndoInterval _ otherInterval _ self selectionInterval]. self userHasEdited " -- note text now dirty"! ! !TextMorphEditor methodsFor: 'binding' stamp: 'ls 7/24/1998 21:06'! bindingOf: aString ^model bindingOf: aString! ! !TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:41'! totalTextHeight ^paragraph lines last bottom! ! !TextMorphEditor methodsFor: 'as yet unclassified' stamp: 'sbw 10/13/1999 22:43'! visibleHeight ^morph owner bounds height! ! !TextMorphEditor class methodsFor: 'instance creation' stamp: 'jm 5/30/2003 10:48'! new "Initialize, but don't set my paragraph." ^ self basicNew initialize ! ! I am a TextMorph used for editable texts. ! !TextMorphForEditView methodsFor: 'initialization' stamp: 'di 9/11/1998 15:43'! initialize super initialize. acceptOnCR _ false! ! !TextMorphForEditView methodsFor: 'events' stamp: 'bf 4/14/1999 12:39'! keyStroke: evt | view | (editView scrollByKeyboard: evt) ifTrue: [^self]. self editor model: editView model. "For evaluateSelection" view _ editView. "Copy into temp for case of a self-mutating doit" (acceptOnCR and: [evt keyCharacter = Character cr]) ifTrue: [^ self editor accept]. super keyStroke: evt. view scrollSelectionIntoView! ! !TextMorphForEditView methodsFor: 'events' stamp: 'di 6/30/1998 08:50'! mouseDown: event event yellowButtonPressed ifTrue: [^ editView yellowButtonActivity: event shiftPressed]. ^ super mouseDown: event ! ! !TextMorphForEditView methodsFor: 'other' stamp: 'di 9/11/1998 15:42'! acceptOnCR: trueOrFalse acceptOnCR _ trueOrFalse! ! !TextMorphForEditView methodsFor: 'other' stamp: 'di 6/22/1998 10:44'! drawNullTextOn: aCanvas "Just run the normal code to show selection in a window" aCanvas paragraph: self paragraph bounds: bounds color: color ! ! !TextMorphForEditView methodsFor: 'other' stamp: 'di 6/22/1998 01:31'! editView ^ editView! ! !TextMorphForEditView methodsFor: 'other' stamp: 'di 11/10/1998 10:13'! flash ^ editView flash! ! !TextMorphForEditView methodsFor: 'other' stamp: 'di 10/5/1998 14:03'! handleInteraction: interActionBlock fromEvent: evt "Overridden to pass along a model to the editor for, eg, link resolution, doits, etc" self editor model: editView model. "For evaluateSelection, etc" ^ super handleInteraction: interActionBlock fromEvent: evt! ! !TextMorphForEditView methodsFor: 'private' stamp: 'dew 2/21/1999 03:09'! updateFromParagraph super updateFromParagraph. editView setScrollDeltas.! ! I represent a link to either a SqueakPage in a BookMorph, or a regular url. See TextMorphEditor changeEmphasis:. ! ]style[(81 31 4)f1,f1LTextMorphEditor changeEmphasis:;,f1! !TextSqkPageLink methodsFor: 'as yet unclassified' stamp: 'tk 1/13/1999 08:14'! writeScanOn: strm strm nextPut: $q; nextPutAll: url; nextPut: $;! ! !TextStream methodsFor: 'as yet unclassified' stamp: 'djp 11/6/1999 20:30'! withAttributes: attributes do: streamBlock | pos1 val | pos1 _ self position. val _ streamBlock value. attributes do: [:attribute | collection addAttribute: attribute from: pos1 + 1 to: self position]. ^ val! ! !TextStyle methodsFor: 'accessing' stamp: 'sw 12/6/1999 12:31'! defaultFont ^ fontArray at: self defaultFontIndex! ! !TextStyle methodsFor: 'accessing' stamp: 'jm 6/9/2003 21:51'! fontNamesWithHeights "Answer a collection of strings containing the font name and height for each of my fonts." "TextStyle default fontNamesWithHeights" ^ fontArray collect: [:x | x name withoutTrailingDigits, ' ', x height printString] ! ! !TextStyle methodsFor: 'accessing' stamp: 'sma 12/30/1999 13:57'! printOn: aStream super printOn: aStream. aStream space; nextPutAll: self defaultFont name! ! !TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/8/1999 18:02'! consistOnlyOf: aFont fontArray _ Array with: aFont. defaultFontIndex _ 1! ! !TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 12/6/1999 13:54'! fontIndexOf: aFont ^ fontArray indexOf: aFont ifAbsent: [nil]! ! !TextStyle methodsFor: 'fonts and font indexes' stamp: 'sw 1/18/2000 21:34'! fontOfPointSize: aPointSize ^ fontArray detect: [:aFont | aFont pointSize = aPointSize] ifNone: [nil]! ! !TextStyle methodsFor: 'private' stamp: 'di 3/20/1999 22:31'! fontAt: index "This is private because no object outside TextStyle should depend on the representation of the font family in fontArray." ^ fontArray atPin: index! ! !TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 12:30'! defaultFontIndex ^ defaultFontIndex ifNil: [defaultFontIndex _ 1]! ! !TextStyle methodsFor: 'default font' stamp: 'sw 12/6/1999 13:50'! defaultFontIndex: anIndex defaultFontIndex _ anIndex! ! !TextStyle class methodsFor: 'constants' stamp: 'sw 12/6/1999 12:32'! defaultFont "Answer the default system font" ^ DefaultTextStyle defaultFont! ! !TextURL methodsFor: 'as yet unclassified' stamp: 'jm 10/14/2002 18:52'! actOnClickFor: anObject "Do what you can with this URL. Later show it in a web browser." | response | response _ (PopUpMenu labels: 'View web page as source\Cancel' withCRs) startUpWithCaption: 'Couldn''t find a web browser. View page as source?'. response = 1 ifTrue: [HTTPSocket httpShowPage: url]. ^ true ! ! A button morph with separate images for on, off, and pressed with the mouse. When the event actWhen occurs, send actionSelector with 'arguments' to target. For other events, default to my eventHandler. The current event is not supplied in the arguments to the actionSelector. image (a.k.a. onImage) may not be nil. offImage and pressedImage may be nil. nil there means be transparent and show the underlying object. If my getSelector is not nil, I update myself from the state of my target object. Tools for debugging: Display the images momentarily under program control (for positioning) (self is an instance). self state: #on. self state: #off. self state: #pressed. self state: #off. Display a rectangle where the button is. Display fillWithColor: bounds + (self world viewBox origin). self invalidRect: bounds.! !ThreePhaseButtonMorph methodsFor: 'initialization' stamp: 'jm 10/13/2002 17:37'! initialize super initialize. state _ #off. target _ nil. actionSelector _ #flash. arguments _ Array empty. actWhen _ #buttonUp. "self on: #mouseStillDown send: #dragIfAuthoring: to: self." "real move should include a call on dragIfAuthoring: "! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jm 10/4/2002 08:45'! adaptToWorld: aWorld super adaptToWorld: aWorld. target isMorph ifTrue: [ target isWorldMorph ifTrue: [self target: aWorld]. target isHandMorph ifTrue: [self target: aWorld primaryHand]]. ! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 11:46'! getSelector ^ getSelector ! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 11:46'! getSelector: sel getSelector _ sel. ! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'sw 3/8/1999 13:56'! isOn ^ state == #on! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'sw 5/23/2000 17:53'! mouseDown: evt | now dt | self state: #pressed. actWhen == #buttonDown ifTrue: [self doButtonAction] ifFalse: [now _ Time millisecondClockValue. super mouseDown: evt. "Allow on:send:to: to set the response to events other than actWhen" dt _ Time millisecondClockValue - now max: 0. "Time it took to do" dt < 200 ifTrue: [(Delay forMilliseconds: 200-dt) wait]] ! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jm 11/13/2002 11:02'! onImage ^ form ! ! !ThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'jm 11/13/2002 11:01'! onImage: aForm form _ aForm. self invalidRect: self bounds. ! ! !ThreePhaseButtonMorph methodsFor: 'drawing' stamp: 'jm 11/13/2002 11:02'! drawOn: aCanvas state == #off ifTrue: [ offImage ifNotNil: [aCanvas paintImage: offImage at: bounds origin]]. state == #pressed ifTrue: [ pressedImage ifNotNil: [aCanvas paintImage: pressedImage at: bounds origin]]. state == #on ifTrue: [ form ifNotNil: [aCanvas paintImage: form at: bounds origin]]. ! ! !ThreePhaseButtonMorph methodsFor: 'stepping' stamp: 'jm 6/16/2003 14:24'! step | newOnState | getSelector ifNil: [^ self stopStepping]. state == #pressed ifTrue: [^ self]. "do not update while user is pressing me" newOnState _ target perform: getSelector. newOnState == self isOn ifFalse: [ self state: (newOnState ifTrue: [#on] ifFalse: [#off])]. ! ! !ThreePhaseButtonMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 11:50'! stepTime ^ 50 ! ! !ThreePhaseButtonMorph methodsFor: 'printing' stamp: 'sw 11/11/1998 15:01'! printOn: aStream | string | aStream nextPutAll: '3PButton'. arguments size > 0 ifTrue: [string _ arguments at: (2 min: arguments size)]. aStream nextPutAll: '('. (string ~~ nil and: [string ~~ self]) ifTrue: [aStream print: string; space] ifFalse: [aStream print: actionSelector; space]. aStream print: self identityHash; nextPutAll: ')'.! ! !ThreePhaseButtonMorph class methodsFor: 'class initialization' stamp: 'jm 10/8/2002 09:08'! initialize "self initialize" | extent inset f r c | extent _ 12@12. inset _ 3. #(CheckBoxOff CheckBoxOn CheckBoxPressed) do: [:fName | f _ ColorForm extent: extent depth: 1. f colors: {Color transparent. Color black}. f borderWidth: 1. r _ f boundingBox insetBy: inset. fName = #CheckBoxPressed ifTrue: [f border: r width: 1]. fName = #CheckBoxOn ifTrue: [f fillBlack: r]. self classPool at: fName put: f]. #(RadioButtonOff RadioButtonOn RadioButtonPressed) do: [:fName | f _ ColorForm extent: extent depth: 1. f colors: {Color transparent. Color black}. r _ f boundingBox. c _ f getCanvas. c frameOval: r color: Color black. r _ r insetBy: inset. fName = #RadioButtonPressed ifTrue: [c frameOval: r color: Color black]. fName = #RadioButtonOn ifTrue: [c fillOval: r color: Color black]. self classPool at: fName put: f]. ! ! !ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 18:50'! checkBox "Answer a button pre-initialized with checkbox images." ^ super new onImage: CheckBoxOn; pressedImage: CheckBoxPressed; offImage: CheckBoxOff; extent: CheckBoxOn extent + (2@0); yourself ! ! !ThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 18:50'! radioButton "Answer a button pre-initialized with radiobutton images." ^ super new onImage: RadioButtonOn; pressedImage: RadioButtonPressed; offImage: RadioButtonOff; extent: RadioButtonOn extent + (2@0); yourself ! ! I represent the time of day. Internally I store the number of seconds since midnight.! !Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 19:48'! hours "Answer the number of hours the receiver represents." ^seconds // 3600! ! !Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 00:48'! minutes "Answer the number of minutes the receiver represents." ^seconds \\ 3600 // 60! ! !Time methodsFor: 'accessing' stamp: 'BP 5/17/2000 00:00'! seconds "Answer the number of seconds the receiver represents." ^seconds \\ 3600 \\ 60! ! !Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'! < aTime "Answer whether aTime is earlier than the receiver." ^seconds < aTime asSeconds! ! !Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'! = aTime "Answer whether aTime represents the same second as the receiver." self species = aTime species ifTrue: [ ^seconds = aTime asSeconds ] ifFalse: [ ^false ].! ! !Time methodsFor: 'comparing' stamp: 'BP 5/17/2000 00:00'! hash "Hash must be redefined since = was redefined." ^seconds hash! ! !Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:44'! hhmm24 "Return a string of the form 1123 (for 11:23 am), 2154 (for 9:54 pm), of exactly 4 digits" ^(String streamContents: [ :aStream | self print24: true showSeconds: false on: aStream ]) copyWithout: $:! ! !Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:44'! intervalString "Treat the time as a difference. Give it in hours and minutes with two digits of accuracy." | hh mm ss | hh _ self hours = 0 ifTrue: [''] ifFalse: [' ', self hours printString, ' hours']. mm _ self minutes = 0 ifTrue: [''] ifFalse: [' ', self minutes printString, ' minutes']. ss _ self seconds = 0 ifTrue: [''] ifFalse: [' ', self seconds printString, ' seconds']. hh size > 0 ifTrue: [ss _ '']. ^ hh, mm, ss! ! !Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:43'! print24 "Return as 8-digit string 'hh:mm:ss', with leading zeros if needed" ^String streamContents: [ :aStream | self print24: true on: aStream ] ! ! !Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:41'! print24: hr24 on: aStream "Format is 'hh:mm:ss' or 'h:mm:ss am' " self print24: hr24 showSeconds: true on: aStream ! ! !Time methodsFor: 'printing' stamp: 'BP 5/17/2000 19:42'! print24: hr24 showSeconds: showSeconds on: aStream "Format is 'hh:mm:ss' or 'h:mm:ss am' or, if showSeconds is false, 'hh:mm' or 'h:mm am'" | h m s | h _ self hours. m _ self minutes. s _ self seconds. hr24 ifTrue: [ h < 10 ifTrue: [ aStream nextPutAll: '0' ]. h printOn: aStream ] ifFalse: [ h > 12 ifTrue: [ h - 12 printOn: aStream] ifFalse: [ h < 1 ifTrue: [ 12 printOn: aStream ] ifFalse: [ h printOn: aStream ] ] ]. aStream nextPutAll: (m < 10 ifTrue: [':0'] ifFalse: [':']). m printOn: aStream. showSeconds ifTrue: [ aStream nextPutAll: (s < 10 ifTrue: [':0'] ifFalse: [':']). s printOn: aStream ]. hr24 ifFalse: [ aStream nextPutAll: (h < 12 ifTrue: [' am'] ifFalse: [' pm']) ]. ! ! !Time methodsFor: 'converting' stamp: 'BP 5/17/2000 00:00'! asSeconds "Answer the number of seconds since midnight of the receiver." ^seconds! ! !Time methodsFor: 'private' stamp: 'BP 5/17/2000 19:45'! hours: anInteger self hours: anInteger minutes: 0 seconds: 0.! ! !Time methodsFor: 'private' stamp: 'BP 5/17/2000 00:00'! hours: hourInteger minutes: minInteger seconds: secInteger self setSeconds: (hourInteger * 3600) + (minInteger * 60) + secInteger.! ! !Time methodsFor: 'private' stamp: 'BP 5/17/2000 00:00'! setSeconds: secondCount seconds _ secondCount ! ! !Time class methodsFor: 'instance creation' stamp: 'BP 5/17/2000 19:53'! fromSeconds: secondCount "Answer an instance of me that is secondCount number of seconds since midnight." ^self new setSeconds: secondCount; yourself.! ! !Time class methodsFor: 'instance creation' stamp: 'BP 5/17/2000 19:53'! readFrom: aStream "Read a Time from the stream in the form: <hour>:<minute>:<second> <am/pm> <minute>, <second> or <am/pm> may be omitted. e.g. 1:59:30 pm; 8AM; 15:30" | hour minute second ampm | hour _ Integer readFrom: aStream. minute _ 0. second _ 0. (aStream peekFor: $:) ifTrue: [ minute _ Integer readFrom: aStream. (aStream peekFor: $:) ifTrue: [ second _ Integer readFrom: aStream ] ]. aStream skipSeparators. (aStream atEnd not and: [aStream peek isLetter]) ifTrue: [ ampm _ aStream next asLowercase. (ampm = $p and: [hour < 12]) ifTrue: [hour _ hour + 12]. (ampm = $a and: [hour = 12]) ifTrue: [hour _ 0]. (aStream peekFor: $m) ifFalse: [aStream peekFor: $M] ]. ^self fromSeconds: 60*(60*hour+minute)+second "Time readFrom: (ReadStream on: '2:23:09 pm')" ! ! !Time class methodsFor: 'general inquiries' stamp: 'JZH 11/8/1998 13:03'! dateAndTimeFromSeconds: secondCount ^ Array with: (Date fromSeconds: secondCount) with: (Time fromSeconds: secondCount \\ 86400) ! ! !Time class methodsFor: 'general inquiries' stamp: 'ls 7/25/1998 01:16'! dateAndTimeNow "Answer a two-element Array of (Date today, Time now)." | secondCount d t | secondCount _ self primSecondsClock. d _ Date fromSeconds: secondCount. t _ Time fromSeconds: secondCount \\ 86400. ^ Array with: d with: t! ! !Time class methodsFor: 'general inquiries' stamp: 'mir 10/29/1999 18:27'! milliseconds: currentTime since: lastTime | delta | "Answer the elapsed time since last recorded in milliseconds. Compensate for rollover." delta _ currentTime - lastTime. ^delta < 0 ifTrue: [SmallInteger maxVal + delta] ifFalse: [delta] ! ! !Time class methodsFor: 'general inquiries' stamp: 'mir 10/29/1999 18:24'! millisecondsSince: lastTime "Answer the elapsed time since last recorded in milliseconds. Compensate for rollover." ^self milliseconds: self millisecondClockValue since: lastTime! ! !Time class methodsFor: 'benchmarks' stamp: 'ar 9/6/1999 17:51'! benchmarkMillisecondClock "Time benchmarkMillisecondClock" "Benchmark the time spent in a call to Time>>millisecondClockValue. On the VM level this tests the efficiency of calls to ioMSecs()." "PII/400 Windows 98: 0.725 microseconds per call" | temp1 temp2 temp3 delayTime nLoops time | delayTime _ 5000. "Time to run benchmark is approx. 2*delayTime" "Don't run the benchmark if we have an active delay since we will measure the additional penalty in the primitive dispatch mechanism (see #benchmarkPrimitiveResponseDelay)." Delay anyActive ifTrue:[ ^self notify:'Some delay is currently active. Running this benchmark will not give any useful result.']. "Flush the cache for this benchmark so we will have a clear cache hit for each send to #millisecondClockValue below" Object flushCache. temp1 _ 0. temp2 _ self. "e.g., temp1 == Time" temp3 _ self millisecondClockValue + delayTime. "Now check how often we can run the following loop in the given time" [temp2 millisecondClockValue < temp3] whileTrue:[temp1 _ temp1 + 1]. nLoops _ temp1. "Remember the loops we have run during delayTime" "Setup the second loop" temp1 _ 0. temp3 _ nLoops. "Now measure how much time we spend without sending #millisecondClockValue" time _ Time millisecondClockValue. [temp1 < temp3] whileTrue:[temp1 _ temp1 + 1]. time _ Time millisecondClockValue - time. "And compute the number of microseconds spent per call to #millisecondClockValue" ^((delayTime - time * 1000.0 / nLoops) truncateTo: 0.001) printString, ' microseconds per call to Time>>millisecondClockValue'! ! !Time class methodsFor: 'benchmarks' stamp: 'ar 9/6/1999 18:02'! benchmarkPrimitiveResponseDelay "Time benchmarkPrimitiveResponseDelay" "Benchmark the overhead for primitive dispatches with an active Delay. On the VM level, this tests the efficiency of ioLowResMSecs." "PII/400 Windows98: 0.128 microseconds per prim" "ar 9/6/1999: This value is *extremely* important for stuff like sockets etc. I had a bad surprise when Michael pointed this particular problem out: Using the hardcoded clock() call for ioLowResMSecs on Win32 resulted in an overhead of 157.4 microseconds per primitive call - meaning you can't get no more than approx. 6000 primitives per second on my 400Mhz PII system with an active delay!! BTW, it finally explains why Squeak seemed soooo slow when running PWS or other socket stuff. The new version (not using clock() but some Windows function) looks a lot better (see above; approx. 8,000,000 prims per sec with an active delay)." | nLoops bb index baseTime actualTime delayTime | delayTime _ 5000. "Time to run this test is approx. 3*delayTime" Delay anyActive ifTrue:[ ^self notify:'Some delay is currently active. Running this benchmark will not give any useful result.']. bb _ Array new: 1. "The object we send the prim message to" "Compute the # of loops we'll run in a decent amount of time" [(Delay forMilliseconds: delayTime) wait] forkAt: Processor userInterruptPriority. nLoops _ 0. [Delay anyActive] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. nLoops _ nLoops + 1. ]. "Flush the cache and make sure #basicSize is in there" Object flushCache. bb basicSize. "Now run the loop without any active delay for getting an idea about its actual speed." baseTime _ self millisecondClockValue. index _ nLoops. [index > 0] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. index _ index - 1. ]. baseTime _ self millisecondClockValue - baseTime. "Setup the active delay but try to never make it active" [(Delay forMilliseconds: delayTime + delayTime) wait] forkAt: Processor userInterruptPriority. "And run the loop" actualTime _ self millisecondClockValue. index _ nLoops. [index > 0] whileTrue:[ bb basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize; basicSize. index _ index - 1. ]. actualTime _ self millisecondClockValue - actualTime. "And get us some result" ^((actualTime - baseTime) * 1000 asFloat / (nLoops * 10) truncateTo: 0.001) printString, ' microseconds overhead per primitive call'! ! I demonstrate how to create a very simple image editor in Morphic. I am intentially left incomplete so that the basics can be clearly seen. ! !TinyPaint methodsFor: 'events' stamp: 'jm 6/15/2003 12:06'! mouseDown: evt "Start drawing at the event point and report the invalid area." lastMouse _ evt cursorPoint. brush drawFrom: lastMouse - bounds origin to: lastMouse - bounds origin. self invalidRect: ((lastMouse - brush sourceForm extent) corner: (lastMouse + brush sourceForm extent)). ! ! !TinyPaint methodsFor: 'events' stamp: 'jm 6/15/2003 12:05'! mouseMove: evt "Draw from the last mouse position to the new position and report the invalid area." | p | p _ evt cursorPoint. p = lastMouse ifTrue: [^ self]. brush drawFrom: lastMouse - bounds origin to: p - bounds origin. self invalidRect: ( ((lastMouse min: p) - brush sourceForm extent) corner: ((lastMouse max: p) + brush sourceForm extent)). lastMouse _ p. ! ! !TinyPaint methodsFor: 'menu' stamp: 'jm 1/6/2003 16:04'! fill | fillPt | Cursor blank show. Cursor crossHair showWhile: [fillPt _ Sensor waitButton - self position]. originalForm shapeFill: brushColor interiorPoint: fillPt. Sensor waitNoButton. self changed. ! ! !TinyPaint methodsFor: 'menu' stamp: 'di 9/3/1999 09:43'! setPenColor: evt evt hand changeColorTarget: self selector: #brushColor: originalColor: brushColor. ! ! !TinyPaint class methodsFor: 'instance creation' stamp: 'jm 5/31/2003 20:02'! includeInNewMorphMenu ^ true ! ! !TranscriptStream methodsFor: 'initialization' stamp: 'di 5/9/2000 09:11'! closeAllViews "Transcript closeAllViews" self dependents do: [:d | (d isKindOf: PluggableTextView) ifTrue: [d topView controller closeAndUnscheduleNoTerminate]. (d isKindOf: SystemWindow) ifTrue: [d delete]]! ! !TranscriptStream methodsFor: 'initialization' stamp: 'di 5/27/1998 16:36'! openAsMorphLabel: labelString "Build a morph viewing this transcriptStream" | window | window _ (SystemWindow labelled: labelString) model: self. window addMorph: (PluggableTextMorph on: self text: nil accept: nil readSelection: nil menu: #codePaneMenu:shifted:) frame: (0@0 corner: 1@1). ^ window! ! !TranscriptStream methodsFor: 'initialization' stamp: 'sma 4/30/2000 10:16'! openLabel: aString "Open a window on this transcriptStream" | topView codeView | Smalltalk isMorphic ifTrue: [^ (self openAsMorphLabel: aString) openInWorld]. topView _ (StandardSystemView new) model: self. topView borderWidth: 1. topView label: aString. topView minimumSize: 100 @ 50. codeView _ PluggableTextView on: self text: nil accept: nil readSelection: nil menu: #codePaneMenu:shifted:. codeView window: (0@0 extent: 200@200). topView addSubView: codeView. topView controller open! ! !TranscriptStream methodsFor: 'access' stamp: 'di 3/16/1999 21:38'! characterLimit "Tell the views how much to retain on screen" ^ 20000! ! !TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 3/15/2000 21:28'! bs self position > 0 ifTrue: [^ self skip: -1]. self changed: #bs! ! !TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 4/22/2000 16:58'! flush self endEntry! ! !TranscriptStream methodsFor: 'stream extensions' stamp: 'sma 2/26/2000 19:31'! show: anObject "TextCollector compatibility" self nextPutAll: anObject asString; endEntry! ! !TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/27/1998 16:44'! codePaneMenu: aMenu shifted: shifted "Note that unless we override perform:orSendTo:, PluggableTextController will respond to all menu items" ^ StringHolder basicNew codePaneMenu: aMenu shifted: shifted ! ! !TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/29/1998 17:13'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." (self respondsTo: selector) ifTrue: [^ self perform: selector] ifFalse: [^ otherTarget perform: selector]! ! !TranscriptStream methodsFor: 'model protocol' stamp: 'di 5/3/1999 22:49'! release self dependents do: [:view | (view isMorph and: [view isInWorld not]) ifTrue: [self removeDependent: view]]! ! Transcripter is a dog-simple scrolling stream with display. It is intended to operate with no support from MVC or color in a minimal, or headless version of Squeak. No attention has been paid to appearance or performance.! !Transcripter methodsFor: 'initialization' stamp: 'di 8/14/97 12:44'! initInFrame: rect frame _ rect insetBy: 2. "Leave room for border" para _ Paragraph withText: self contents asText style: TextStyle default compositionRectangle: ((frame insetBy: 4) withHeight: 9999) clippingRectangle: frame foreColor: self black backColor: self white! ! !Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:41'! clear Display fill: (frame insetBy: -2) fillColor: self black; fill: frame fillColor: self white. self on: (String new: 100); endEntry! ! !Transcripter methodsFor: 'accessing' stamp: 'di 8/14/97 12:44'! endEntry | c d cb | c _ self contents. Display extent ~= DisplayScreen actualScreenSize ifTrue: ["Handle case of user resizing physical window" DisplayScreen startUp. frame _ frame intersect: Display boundingBox. ^ self clear; show: c]. para setWithText: c asText style: TextStyle default compositionRectangle: ((frame insetBy: 4) withHeight: 9999) clippingRectangle: frame foreColor: self black backColor: self white. d _ para compositionRectangle bottom - frame bottom. d > 0 ifTrue: ["Scroll up to keep all contents visible" cb _ para characterBlockAtPoint: para compositionRectangle topLeft + (0@(d+para lineGrid)). self on: (c copyFrom: cb stringIndex to: c size). readLimit_ position_ collection size. ^ self endEntry]. para display! ! !Transcripter methodsFor: 'accessing' stamp: 'sma 2/26/2000 19:35'! show: anObject self nextPutAll: anObject asString; endEntry! ! !Transcripter methodsFor: 'command line' stamp: 'di 8/12/97 22:11'! confirm: queryString | choice | [true] whileTrue: [choice _ self request: queryString , ' Please type yes or no followed by return'. choice first asUppercase = $Y ifTrue: [^ true]. choice first asUppercase = $N ifTrue: [^ false]]! ! !Transcripter methodsFor: 'command line' stamp: 'sma 5/27/2000 17:53'! readEvalPrint | line | [#('quit' 'exit' 'done' ) includes: (line _ self request: '>')] whileFalse: [self cr; show: ([Compiler evaluate: line] ifError: [:err :ex | err])]! ! !Transcripter methodsFor: 'command line' stamp: 'sma 2/26/2000 19:39'! request: prompt | startPos char contents | self cr; show: prompt. startPos _ position. [[Sensor keyboardPressed] whileFalse. (char _ Sensor keyboard) = Character cr] whileFalse: [char = Character backspace ifTrue: [readLimit _ position _ (position - 1 max: startPos)] ifFalse: [self nextPut: char]. self endEntry]. contents _ self contents. ^ contents copyFrom: startPos + 1 to: contents size! ! !Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'! black Display depth = 1 ifTrue: [^ Bitmap with: 16rFFFFFFFF "Works without color support"]. ^ Color black! ! !Transcripter methodsFor: 'private' stamp: 'di 8/14/97 12:12'! white Display depth = 1 ifTrue: [^ Bitmap with: 0 "Works without color support"]. ^ Color white! ! !Transcripter class methodsFor: 'instance creation' stamp: 'di 8/14/97 12:09'! newInFrame: frame " (Transcripter newInFrame: (0@0 extent: 100@200)) nextPutAll: 'Hello there'; endEntry; cr; print: 355.0/113; endEntry; readEvalPrint. " | transcript | transcript _ self on: (String new: 100). transcript initInFrame: frame. ^ transcript clear! ! !Transcripter class methodsFor: 'instance creation' stamp: 'ar 11/16/1999 20:16'! startTranscriptProcess "Transcripter startTranscriptProcess" | activeProcess | Transcript _ self newInFrame: Display boundingBox. activeProcess _ [Transcript readEvalPrint. Smalltalk processShutDownList: true; quitPrimitive] newProcess priority: Processor userSchedulingPriority. activeProcess resume. Processor terminateActive ! ! !Transcripter class methodsFor: 'utilities' stamp: 'sma 5/27/2000 17:35'! emergencyEvaluator (Transcripter newInFrame: (0@0 corner: 320@200)) show: 'type ''exit'' to exit the emergency evaluator'; readEvalPrint! ! Warning: TransformMorph is currently being phased out. Do not use it for new applications!! A TransformMorph introduces a 2-D transformation between its (global) coordinates and the (local) coordinates of its submorphs, while also clipping all display to its bounds. Specifically, with no offset, angle or scaling, a submorph with coordinates (0@0) will appear exactly at the topLeft of the windowMorph (its position). Rotation and scaling are relative to the local origin, (0@0). TransformMorphs operate with two different display strategies, depending on whether the transformation is a pure translation or not. If so, then they simply use a clipping canvas and display their submorphs with the appropriate offset. If the transformation includes scaling or rotation, then a caching canvas is used, whose active area covers the fullBounds of the submorphs intersected with the source quadrilateral corresponding to the window bounds. ! !TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'! transform ^transform! ! !TransformMorph methodsFor: 'accessing' stamp: 'ar 5/19/1999 18:04'! transform: aTransform transform _ aTransform.! ! !TransformMorph methodsFor: 'submorphs-accessing' stamp: 'ar 11/15/1998 23:42'! morphsAt: aPoint addTo: mList "Return a collection of all morphs in this morph structure that contain the given point. Map through my transform. Must do this recursively because of transforms. " | p | (self containsPoint: aPoint) ifFalse: ["TransformMorph clips to bounds" ^ mList]. p _ transform globalPointToLocal: aPoint. submorphs do: [:m | m morphsAt: p addTo: mList]. mList addLast: self. ^ mList ! ! !TransformMorph methodsFor: 'submorphs-accessing' stamp: 'ar 11/15/1998 23:42'! unlockedMorphsAt: aPoint addTo: mList "Return a collection of all morphs in this morph structure that contain the given point. Map through my transform. Must do this recursively because of transforms. " | p | self isLocked ifTrue: [^ mList]. (self containsPoint: aPoint) ifFalse: ["TransformMorph clips to bounds" ^ mList]. p _ transform globalPointToLocal: aPoint. submorphs do: [:m | m unlockedMorphsAt: p addTo: mList]. mList addLast: self. ^ mList ! ! !TransformMorph methodsFor: 'drawing' stamp: 'di 10/16/1999 16:03'! drawSubmorphsOn: aCanvas aCanvas transformBy: transform clippingTo: self innerBounds during: [:myCanvas | submorphs reverseDo:[:m | myCanvas fullDrawMorph: m] ] smoothing: smoothing! ! !TransformMorph methodsFor: 'geometry' stamp: 'ar 11/15/1998 23:42'! containsPoint: aPoint (bounds containsPoint: aPoint) ifFalse: [^ false]. self hasSubmorphs ifTrue: [self submorphsDo: [:m | (m fullBounds containsPoint: (transform globalPointToLocal: aPoint)) ifTrue: [^ true]]. ^ false] ifFalse: [^ true]! ! !TransformMorph methodsFor: 'geometry' stamp: 'sw 12/29/1999 15:51'! wantsHaloFromClick ^ false! ! !TransformMorph methodsFor: 'change reporting' stamp: 'ar 3/14/2000 16:06'! invalidRect: damageRect "Translate damage reports from submorphs by the scrollOffset." super invalidRect: (((transform localBoundsToGlobal: damageRect) intersect: bounds) expandBy: 1)! ! A transitionMorph inserts itself in the morphic object structure during a visual transition. It has a stepNumber that runs from 1 to nSteps. This class handles a large family of wipe-like transitions by itself. Subclasses may implement other transitions such as dissolves and zooms.! !TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 12:52'! completeReplacement self delete. completionBlock value! ! !TransitionMorph methodsFor: 'initialization' stamp: 'jm 7/4/2003 10:35'! initiateReplacement | n | startForm _ effect = #dissolve ifTrue: [(startMorph imageForm: 16 forRectangle: bounds) offset: 0@0] ifFalse: [(startMorph imageForm: Display depth forRectangle: bounds) offset: 0@0]. endForm _ (endMorph imageForm: Display depth forRectangle: bounds) offset: 0@0. nSteps == nil ifTrue: [self nSteps: 30 stepTime: 10. (#(zoom pageForward pageBack) includes: effect) ifTrue: [n _ 20 * 100000 // self bounds area min: 20 max: 4. self nSteps: n stepTime: 10]. (#dissolve = effect) ifTrue: [n _ 20 * 50000 // self bounds area min: 20 max: 4. self nSteps: n stepTime: 10]]. startBlock value. "with forms in place there should b no further delay." self arrangeToStartStepping. ! ! !TransitionMorph methodsFor: 'initialization' stamp: 'di 12/14/1998 12:25'! nSteps: n stepTime: msPerStep nSteps _ n. stepTime _ msPerStep! ! !TransitionMorph methodsFor: 'initialization' stamp: 'di 12/22/1998 13:32'! showTransitionFrom: startingMorph to: endingMorph in: containingMorph whenStart: firstBlock whenDone: doneBlock effect == #none ifTrue: [firstBlock value. ^ doneBlock value]. self startMorph: startingMorph endMorph: endingMorph startBlock: firstBlock completionBlock: doneBlock. stepNumber _ 0. self bounds: startingMorph bounds. endingMorph privateOwner: self. "Allows test of transition in progress" containingMorph owner privateAddMorph: self atIndex: (containingMorph owner submorphs indexOf: containingMorph). self initiateReplacement! ! !TransitionMorph methodsFor: 'initialization' stamp: 'di 12/20/1998 10:46'! startMorph: start endMorph: end startBlock: firstBlock completionBlock: aBlock startMorph _ start. endMorph _ end. startBlock _ firstBlock. completionBlock _ aBlock! ! !TransitionMorph methodsFor: 'drawing' stamp: 'di 1/5/1999 08:37'! areasRemainingToFill: aRectangle "May be overridden by any subclasses with opaque regions" ^ aRectangle areasOutside: self bounds! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'! drawDissolveOn: aCanvas "startForm and endFrom are both fixed, but the dissolve ration changes." startForm copyBits: endForm at: 0@0 translucent: stepNumber asFloat / (nSteps*2). aCanvas drawImage: startForm at: self position. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'! drawFrenchDoorOn: aCanvas "startForm and endFrom are both fixed, but a border expands out from a vertical (or H) slit, revealing endForm. It's like opening a pair of doors." | box innerForm outerForm boxExtent h w | h _ self height. w _ self width. direction = #in ifTrue: [innerForm _ endForm. outerForm _ startForm. boxExtent _ self stepFrom: 0@h to: self extent]. direction = #out ifTrue: [innerForm _ startForm. outerForm _ endForm. boxExtent _ self stepFrom: self extent to: 0@h]. direction = #inH ifTrue: [innerForm _ endForm. outerForm _ startForm. boxExtent _ self stepFrom: w@0 to: self extent]. direction = #outH ifTrue: [innerForm _ startForm. outerForm _ endForm. boxExtent _ self stepFrom: self extent to: w@0]. aCanvas drawImage: outerForm at: self position. box _ Rectangle center: self center extent: boxExtent. aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated). ((box expandBy: 1) areasOutside: box) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'di 12/22/1998 20:58'! drawOn: aCanvas "During the transition process, the reveal and obscure areas will be invalidated, so we should be drawing on a canvas that clips to only the changing region." (stepNumber between: 1 and: nSteps) ifFalse: [^ self]. effect = #slideOver ifTrue: [^ self drawSlideOverOn: aCanvas]. effect = #slideBoth ifTrue: [^ self drawSlideBothOn: aCanvas]. effect = #slideAway ifTrue: [^ self drawSlideAwayOn: aCanvas]. effect = #slideBorder ifTrue: [^ self drawSlideBorderOn: aCanvas]. effect = #pageForward ifTrue: [^ self drawPageForwardOn: aCanvas]. effect = #pageBack ifTrue: [^ self drawPageBackOn: aCanvas]. effect = #frenchDoor ifTrue: [^ self drawFrenchDoorOn: aCanvas]. effect = #zoomFrame ifTrue: [^ self drawZoomFrameOn: aCanvas]. effect = #zoom ifTrue: [^ self drawZoomOn: aCanvas]. effect = #dissolve ifTrue: [^ self drawDissolveOn: aCanvas]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:01'! drawPageBackOn: aCanvas "endForm grows in the given direction, overlaying endForm." | offset growRect scale | aCanvas drawImage: startForm at: self position. offset _ self stepFrom: self extent * direction negated to: 0@0. growRect _ (bounds translateBy: offset) intersect: bounds. scale _ growRect extent asFloatPoint / bounds extent. aCanvas drawImage: (endForm magnify: endForm boundingBox by: scale smoothing: 1) at: growRect topLeft. ((growRect translateBy: direction) areasOutside: growRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'! drawPageForwardOn: aCanvas "startForm shrinks in the given direction, revealing endForm." | offset shrinkRect scale | aCanvas drawImage: endForm at: self position. offset _ self stepFrom: 0@0 to: self extent * direction. shrinkRect _ (bounds translateBy: offset) intersect: bounds. scale _ shrinkRect extent asFloatPoint / bounds extent. aCanvas drawImage: (startForm magnify: startForm boundingBox by: scale smoothing: 1) at: shrinkRect topLeft. ((shrinkRect translateBy: direction negated) areasOutside: shrinkRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'! drawSlideAwayOn: aCanvas "startMorph slides away in the given direction, revealing up the endMorph." | startLoc moveRect | startLoc _ self stepFrom: self position to: self position + (self extent * direction). moveRect _ startForm boundingBox translateBy: startLoc. aCanvas drawImage: endForm at: self position. aCanvas drawImage: startForm at: startLoc. ((moveRect translateBy: direction negated) areasOutside: moveRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'! drawSlideBorderOn: aCanvas "startForm and endFrom are both fixed, but a border slides in the given direction, revealing endForm. (It's like opening a can of sardines ;-)." | endRect box sourceRect boxLoc | box _ endForm boundingBox. boxLoc _ self stepFrom: box topLeft - (box extent * direction) to: box topLeft. sourceRect _ box translateBy: boxLoc. endRect _ sourceRect translateBy: self position. ((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse: [aCanvas drawImage: startForm at: self position]. aCanvas drawImage: endForm at: self position + boxLoc sourceRect: sourceRect. ((endRect translateBy: direction) areasOutside: endRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:02'! drawSlideBothOn: aCanvas "endMorph slides in the given direction, as startMorph slides out of its way." | endLoc endRect startLoc | startLoc _ self stepFrom: self position to: self position + (self extent * direction). aCanvas drawImage: startForm at: startLoc. endLoc _ self stepFrom: self position - (self extent * direction) to: self position. aCanvas drawImage: endForm at: endLoc. endRect _ endForm boundingBox translateBy: endLoc. ((endRect translateBy: direction) areasOutside: endRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'! drawSlideOverOn: aCanvas "endMorph slides in the given direction, covering up the startMorph." | endLoc endRect | endLoc _ self stepFrom: self position - (self extent * direction) to: self position. endRect _ endForm boundingBox translateBy: endLoc. ((endRect expandBy: 1) containsRect: aCanvas clipRect) ifFalse: [aCanvas drawImage: startForm at: self position]. aCanvas drawImage: endForm at: endLoc. ((endRect translateBy: direction) areasOutside: endRect) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'! drawZoomFrameOn: aCanvas "startForm and endFrom are both fixed, but a square border expands out from the center (or back), revealing endForm. It's like passing through a portal." | box innerForm outerForm boxExtent | direction = #in ifTrue: [innerForm _ endForm. outerForm _ startForm. boxExtent _ self stepFrom: 0@0 to: self extent] ifFalse: [innerForm _ startForm. outerForm _ endForm. boxExtent _ self stepFrom: self extent to: 0@0]. aCanvas drawImage: outerForm at: self position. box _ Rectangle center: self center extent: boxExtent. aCanvas drawImage: innerForm at: box topLeft sourceRect: (box translateBy: self position negated). ((box expandBy: 1) areasOutside: box) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'drawing' stamp: 'ar 2/12/2000 18:03'! drawZoomOn: aCanvas "Zoom in: endForm expands overlaying startForm. Zoom out: startForm contracts revealing endForm." | box innerForm outerForm boxExtent scale | direction = #in ifTrue: [innerForm _ endForm. outerForm _ startForm. boxExtent _ self stepFrom: 0@0 to: self extent] ifFalse: [innerForm _ startForm. outerForm _ endForm. boxExtent _ self stepFrom: self extent to: 0@0]. aCanvas drawImage: outerForm at: self position. box _ Rectangle center: self center extent: boxExtent. scale _ box extent asFloatPoint / bounds extent. aCanvas drawImage: (innerForm magnify: innerForm boundingBox by: scale smoothing: 1) at: box topLeft. ((box expandBy: 1) areasOutside: box) do: [:r | aCanvas fillRectangle: r color: Color black]. ! ! !TransitionMorph methodsFor: 'change reporting' stamp: 'di 12/22/1998 20:59'! changed "The default (super) method is, generally much slower than need be, since many transitions only change part of the screen on any given step of the animation. The purpose of this method is to effect some of those savings." | loc box boxPrev h w | (stepNumber between: 1 and: nSteps) ifFalse: [^ super changed]. effect = #slideBoth ifTrue: [^ super changed]. effect = #slideOver ifTrue: [loc _ self stepFrom: self position - (self extent * direction) to: self position. ^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)]. effect = #slideAway ifTrue: [loc _ self prevStepFrom: self position to: self position + (self extent * direction). ^ self invalidRect: (((loc extent: self extent) expandBy: 1) intersect: bounds)]. effect = #slideBorder ifTrue: [box _ endForm boundingBox translateBy: (self stepFrom: self topLeft - (self extent * direction) to: self topLeft). boxPrev _ endForm boundingBox translateBy: (self prevStepFrom: self topLeft - (self extent * direction) to: self topLeft). ^ self invalidate: (box expandBy: 1) areasOutside: boxPrev]. effect = #pageForward ifTrue: [loc _ self prevStepFrom: 0@0 to: self extent * direction. ^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)]. effect = #pageBack ifTrue: [loc _ self stepFrom: self extent * direction negated to: 0@0. ^ self invalidRect: (((bounds translateBy: loc) expandBy: 1) intersect: bounds)]. effect = #frenchDoor ifTrue: [h _ self height. w _ self width. direction = #in ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: 0@h to: self extent). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: 0@h to: self extent). ^ self invalidate: (box expandBy: 1) areasOutside: boxPrev]. direction = #out ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: self extent to: 0@h). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: self extent to: 0@h). ^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]. direction = #inH ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: w@0 to: self extent). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: w@0 to: self extent). ^ self invalidate: (box expandBy: 1) areasOutside: boxPrev]. direction = #outH ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: self extent to: w@0). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: self extent to: w@0). ^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]]. effect = #zoomFrame ifTrue: [direction = #in ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: 0@0 to: self extent). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: 0@0 to: self extent). ^ self invalidate: (box expandBy: 1) areasOutside: boxPrev]. direction = #out ifTrue: [box _ Rectangle center: self center extent: (self stepFrom: self extent to: 0@0). boxPrev _ Rectangle center: self center extent: (self prevStepFrom: self extent to: 0@0). ^ self invalidate: (boxPrev expandBy: 1) areasOutside: box]]. effect = #zoom ifTrue: [box _ Rectangle center: self center extent: (direction = #in ifTrue: [self stepFrom: 0@0 to: self extent] ifFalse: [self prevStepFrom: self extent to: 0@0]). ^ self invalidRect: ((box expandBy: 1) intersect: bounds)]. ^ super changed ! ! !TransitionMorph methodsFor: 'change reporting' stamp: 'di 12/22/1998 20:10'! invalidate: box1 areasOutside: box2 ((box1 intersect: bounds) areasOutside: (box2 intersect: bounds)) do: [:r | self invalidRect: r]! ! !TransitionMorph methodsFor: 'stepping' stamp: 'di 12/14/1998 12:30'! step (stepNumber _ stepNumber + 1) <= nSteps ifTrue: [self changed] ifFalse: [self completeReplacement]! ! !TransitionMorph methodsFor: 'stepping' stamp: 'di 12/15/1998 13:52'! stepTime ^ stepTime! ! !TransitionMorph methodsFor: 'private' stamp: 'di 12/22/1998 21:01'! effect: effectSymbol direction: dirSymbol | i | effect _ effectSymbol. "Default directions" (#(zoom zoomFrame frenchDoor) includes: effectSymbol) ifTrue: [(#(in out inH outH) includes: dirSymbol) ifTrue: [direction _ dirSymbol] ifFalse: [direction _ #in]] ifFalse: [i _ #(right downRight down downLeft left upLeft up upRight) indexOf: dirSymbol ifAbsent: [5]. direction _ (0@0) eightNeighbors at: i].! ! !TransitionMorph methodsFor: 'private' stamp: 'di 12/15/1998 11:42'! prevStepFrom: p1 to: p2 "Used for recalling dimensions from previous step." ^ (p2-p1) * (stepNumber-1) // nSteps + p1! ! !TransitionMorph methodsFor: 'private' stamp: 'di 12/14/1998 12:43'! stepFrom: p1 to: p2 "This gives p1 for stepCount = 0, moving to p2 for stepCount = nSteps" ^ (p2-p1) * stepNumber // nSteps + p1! ! !TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 22:01'! effect: effectSymbol direction: dirSymbol ^ self new effect: effectSymbol direction: dirSymbol! ! !TransitionMorph class methodsFor: 'initialization' stamp: 'di 12/20/1998 21:37'! effect: effectSymbol direction: dirSymbol inverse: inverse | invEffect invDir i dirSet | inverse ifFalse: [^ self effect: effectSymbol direction: dirSymbol]. invEffect _ effectSymbol. effectSymbol = #pageForward ifTrue: [invEffect _ #pageBack]. effectSymbol = #pageBack ifTrue: [invEffect _ #pageForward]. effectSymbol = #slideOver ifTrue: [invEffect _ #slideAway]. effectSymbol = #slideAway ifTrue: [invEffect _ #slideOver]. invDir _ dirSymbol. dirSet _ self directionsForEffect: effectSymbol. (i _ dirSet indexOf: dirSymbol) > 0 ifTrue: [invDir _ dirSet atWrap: i + (dirSet size // 2)]. ^ self effect: invEffect direction: invDir! ! !TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:58'! allEffects ^ #(none slideOver slideBoth slideAway slideBorder pageForward pageBack frenchDoor zoomFrame zoom dissolve)! ! !TransitionMorph class methodsFor: 'available effects' stamp: 'di 12/22/1998 20:59'! directionsForEffect: eff "All these arrays are ordered so inverse is atWrap: size//2." (#(slideOver slideBoth slideAway slideBorder) includes: eff) ifTrue: [^ #(right downRight down downLeft left upLeft up upRight)]. (#(pageForward pageBack) includes: eff) ifTrue: [^ #(right down left up)]. (#(frenchDoor) includes: eff) ifTrue: [^ #(in inH out outH)]. (#(zoomFrame zoom) includes: eff) ifTrue: [^ #(in out)]. ^ Array new! ! A TranslucentColor behaves just like a normal color, except that it will pack its alpha value into the high byte of a 32-bit pixelValue. This allows creating forms with translucency for use with the alpha blend function of BitBlt. An alpha of zero is transparent, and 1.0 is opaque.! !TranslucentColor methodsFor: 'printing' stamp: 'mir 7/21/1999 11:43'! storeArrayValuesOn: aStream self isTransparent ifTrue: [ ^ aStream space]. super storeArrayValuesOn: aStream. aStream space. (self alpha roundTo: 0.001) storeOn: aStream. ! ! !TranslucentColor methodsFor: 'printing' stamp: 'di 1/14/1999 14:31'! storeOn: aStream self isTransparent ifTrue: [^ aStream nextPutAll: '(Color transparent)']. super storeOn: aStream. aStream skip: -1; "get rid of trailing )" nextPutAll: ' alpha: '; nextPutAll: self alpha printString; nextPutAll: ')'. ! ! !TranslucentColor methodsFor: 'conversions' stamp: 'di 1/15/1999 11:44'! alpha: alphaValue alphaValue = 1.0 ifTrue: [^ Color basicNew setPrivateRed: self privateRed green: self privateGreen blue: self privateBlue]. ^ super alpha: alphaValue! ! !TranslucentColor methodsFor: 'conversions' stamp: 'sw 10/27/1999 10:51'! asNontranslucentColor ^ self alpha: 1.0! ! !TranslucentColor methodsFor: 'conversions' stamp: 'di 3/25/2000 17:56'! balancedPatternForDepth: depth "Return an appropriate bit pattern or stipple. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." alpha = 0 ifTrue: [^ Bitmap with: 0]. ^ super balancedPatternForDepth: depth! ! !TranslucentColor methodsFor: 'conversions' stamp: 'di 1/14/1999 20:05'! bitPatternForDepth: depth "Return an appropriate bit pattern or stipple. This will almost never be meaningful for tranlucentColors, except for the degenerate case of tranparency." alpha = 0 ifTrue: [^ Bitmap with: 0]. ^ super bitPatternForDepth: depth! ! !TranslucentColor methodsFor: 'conversions' stamp: 'di 1/6/1999 16:15'! pixelValueForDepth: d "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." alpha = 0 ifTrue: [^ 0]. ^ super pixelValueForDepth: d! ! !TranslucentColor methodsFor: 'conversions' stamp: 'di 1/6/1999 16:14'! pixelWordForDepth: depth "Return the pixel value for this color at the given depth. Translucency only works in RGB; this color will appear either opaque or transparent at all other depths." | basicPixelWord | alpha = 0 ifTrue: [^ 0]. basicPixelWord _ super pixelWordForDepth: depth. depth < 32 ifTrue: [^ basicPixelWord] ifFalse: [^ (basicPixelWord bitAnd: 16rFFFFFF) bitOr: (alpha bitShift: 24)]. ! ! !TranslucentColor methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:30'! scaledPixelValue32 "Return the alpha scaled pixel value for depth 32" | pv32 a b g r | pv32 _ super scaledPixelValue32. a _ (self alpha * 255.0) rounded. b _ (pv32 bitAnd: 255) * a // 256. g _ ((pv32 bitShift: -8) bitAnd: 255) * a // 256. r _ ((pv32 bitShift: -16) bitAnd: 255) * a // 256. ^b + (g bitShift: 8) + (r bitShift: 16) + (a bitShift: 24)! ! !TranslucentColor methodsFor: 'private' stamp: 'jm 9/23/2003 17:27'! setRgb: rgbValue alpha: rawAlpha "Set the state of this translucent color. Alpha is represented internally by an integer in the range 0..255." rgb == nil ifFalse: [self attemptToMutateError]. rgb _ rgbValue. alpha _ (rawAlpha asInteger max: 0) min: 255. ! ! !TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! isTranslucent ^ alpha < 255! ! !TranslucentColor methodsFor: 'queries' stamp: 'di 1/3/1999 12:22'! isTranslucentColor "This means: self isTranslucent, but isTransparent not" ^ alpha > 0! ! !TranslucentColor methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! isTransparent ^ alpha = 0! ! I am a client for TransmissionTestServer that can be used to test the data throughput of a connection. First start the server on the target machine (it can be the local machine): server _ TransmissionTestServer new. server forkServerProcess. Then execute the following tests in a workspace, one line at a time: client _ TransmissionTestClient new initialize. client serverAddress: '127.0.0.1'. "<- insert the actual server address here" client openConnection. client pingTest. client sendTest. client receiveTest. client echoTest. client closeConnection. When you are done with the server, you can stop it with: server stopServer Have fun!! ! !TransmissionTestClient methodsFor: 'initialization' stamp: 'jm 10/10/2001 13:10'! initialize serverAddress _ NetNameResolver addressFromString: '127.0.0.1'. msgSocket _ MessageSocket new. payloadBytes _ 10000. ! ! !TransmissionTestClient methodsFor: 'accessing' stamp: 'jm 10/10/2001 13:10'! payloadBytes ^ payloadBytes ! ! !TransmissionTestClient methodsFor: 'accessing' stamp: 'jm 10/10/2001 14:04'! payloadBytes: aNumber "Set the number of bytes to send or receive." payloadBytes _ aNumber asInteger max: 0. ! ! !TransmissionTestClient methodsFor: 'accessing' stamp: 'jm 10/10/2001 12:32'! serverAddress ^ serverAddress ! ! !TransmissionTestClient methodsFor: 'accessing' stamp: 'jm 10/10/2001 12:32'! serverAddress: addressOrString (addressOrString isKindOf: ByteArray) ifTrue: [serverAddress _ addressOrString] ifFalse: [serverAddress _ NetNameResolver addressFromString: addressOrString]. ! ! !TransmissionTestClient methodsFor: 'connection' stamp: 'jm 10/10/2001 13:49'! closeConnection "Close the connection, if any." msgSocket destroy. ! ! !TransmissionTestClient methodsFor: 'connection' stamp: 'jm 10/10/2001 13:46'! openConnection "Open a connection and report how long it took." | port t | msgSocket destroy. port _ TransmissionTestServer portNumber. t _ [msgSocket connectTo: serverAddress port: port waitSecs: 10] timeToRun. msgSocket isConnected ifTrue: [self inform: 'connected in ', t printString, ' milliseconds'] ifFalse: [ self closeConnection. ^ self inform: 'could not connect to ', (NetNameResolver stringFromAddress: serverAddress)]. ! ! !TransmissionTestClient methodsFor: 'tests' stamp: 'jm 10/10/2001 14:05'! echoTest "Report the time to echo some data to the server. The data is sent to the server and back again." | buf t r | msgSocket isConnected ifFalse: [^ self inform: 'not connected']. buf _ ByteArray new: payloadBytes. buf at: 1 put: 1. "data echo request" t _ [r _ msgSocket request: buf] timeToRun. self inform: r size printString, ' bytes echoed in ', t printString, ' milliseconds'. ! ! !TransmissionTestClient methodsFor: 'tests' stamp: 'jm 10/10/2001 14:03'! pingTest "Report the time to ping the server with an empty request." | t | msgSocket isConnected ifFalse: [^ self inform: 'not connected']. t _ [msgSocket request: ''] timeToRun. self inform: 'ping took ', t printString, ' milliseconds'. ! ! !TransmissionTestClient methodsFor: 'tests' stamp: 'jm 10/10/2001 13:47'! receiveTest "Report the time to receive some data from the server. A short request is sent to the server, which replies with the requested number of bytes." | s t r | msgSocket isConnected ifFalse: [^ self inform: 'not connected']. s _ WriteStream on: ByteArray new. s nextPut: 2. s uint32: payloadBytes. t _ [r _ msgSocket request: s contents] timeToRun. self inform: r size printString, ' bytes received in ', t printString, ' milliseconds'. ! ! !TransmissionTestClient methodsFor: 'tests' stamp: 'jm 10/10/2001 13:49'! sendTest "Report the time to send the server some data. The server absorbs the data and sends an empty reply." | buf t | msgSocket isConnected ifFalse: [^ self inform: 'not connected']. buf _ ByteArray new: payloadBytes. buf at: 1 put: 0. "data sink request" t _ [msgSocket request: buf] timeToRun. self inform: payloadBytes printString, ' bytes sent in ', t printString, ' milliseconds'. ! ! I am a simple server that can be used to test network transmission. The first byte of the request message determines the response: 1 -- echo the message verbatim 2 -- reply with a message containing N bytes of 0, where N is specified by next 4 bytes anything else -- reply with a null message (can be used to measure upload speed) ! !TransmissionTestServer methodsFor: 'request handling' stamp: 'jm 9/6/2001 17:46'! processMessage: aByteArray "This server implements three tests that can be used to test network performance. The first byte of the message determines the response: 1 -- server echos the message verbatim 2 -- server answers a message containing N bytes of 0, where N is specified by next 4 bytes 3 (or anything else) -- server answers null message." | op s n | aByteArray size = 0 ifTrue: [^ ByteArray new]. "null message generates null respose" op _ aByteArray first. op = 1 ifTrue: [^ aByteArray]. "echo request" ((op = 2) and: [aByteArray size = 5]) ifTrue: [ "server transmit request" s _ ReadStream on: aByteArray. s skip: 1. n _ (s uint32 min: (Smalltalk garbageCollectMost - 1000000)) max: 0. ^ ByteArray new: n]. ^ ByteArray new "null message" ! ! !TransmissionTestServer class methodsFor: 'port number' stamp: 'jm 7/30/2001 20:31'! portNumber ^ 54323 ! ! True defines the behavior of its single instance, true -- logical assertion. Notice how the truth-value checks become direct message sends, without the need for explicit testing. Be aware however that most of these methods are not sent as real messages in normal use. Most are inline coded by the compiler as test and jump bytecodes - avoiding the overhead of the full message sends. So simply redefining these methods here will have no effect.! I describe the behavior of my sole instance, nil. nil represents a prior value for variables that have not been initialized, or for results which are meaningless.! !UndefinedObject methodsFor: 'copying' stamp: 'tk 6/26/1998 11:35'! clone "Only one instance of UndefinedObject should ever be made, so answer with self."! ! !UndefinedObject methodsFor: 'testing' stamp: 'sw 4/7/1999 17:44'! isEmptyOrNil "Answer whether the receiver contains any elements, or is nil. Useful in numerous situations where one wishes the same reaction to an empty collection or to nil" ^ true! ! !UndefinedObject methodsFor: 'testing' stamp: 'sma 6/6/2000 22:53'! isLiteral ^ true! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:49'! addSubclass: aClass "Ignored -- necessary to support disjoint class hierarchies"! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:57'! environment "Necessary to support disjoint class hierarchies." ^Smalltalk! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 18:56'! subclass: nameOfClass "Define root (superclass = nil) of a class hierarchy" instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: poolDictnames category: category ^(ClassBuilder new) superclass: self subclass: nameOfClass instanceVariableNames: instVarNames classVariableNames: classVarNames poolDictionaries: poolDictnames category: category ! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 8/29/1999 12:49'! subclassDefinerClass "For disjunct class hierarchies -- how should subclasses of nil be evaluated" ^Compiler! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/15/1999 16:55'! subclasses "Return all the subclasses of nil" | classList | classList _ WriteStream on: Array new. self subclassesDo:[:class| classList nextPut: class]. ^classList contents! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'jm 5/16/2003 09:37'! subclassesDo: aBlock "Evaluate aBlock with all subclasses of nil. Others are not direct subclasses of Class." ^ Class subclassesDo: [:cl | cl isMeta ifTrue: [aBlock value: cl soleInstance]]. ! ! !UndefinedObject methodsFor: 'class hierarchy' stamp: 'ar 7/13/1999 06:08'! typeOfClass "Necessary to support disjoint class hierarchies." ^#normal! ! !UnixFileDirectory methodsFor: 'file names' stamp: 'bf 3/22/2000 18:24'! fullPathFor: path "Return the fully-qualified path name for the given file." path isEmpty ifTrue: [^ pathName]. path first = $/ ifTrue: [^ path]. ^ pathName = '/' "Only root dir ends with a slash" ifTrue: ['/' , path] ifFalse: [pathName , '/' , path]! ! !UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 12:58'! directoryExists: filenameOrPath "Handles the special case of testing for the root dir: there isn't a possibility to express the root dir as full pathname like '/foo'." ^ filenameOrPath = '/' or: [super directoryExists: filenameOrPath]! ! !UnixFileDirectory methodsFor: 'testing' stamp: 'sr 5/8/2000 13:03'! fileOrDirectoryExists: filenameOrPath "Handles the special case of testing for the root dir: there isn't a possibility to express the root dir as full pathname like '/foo'." ^ filenameOrPath = '/' or: [super fileOrDirectoryExists: filenameOrPath]! ! !UnixFileDirectory class methodsFor: 'platform specific' stamp: 'yo 2/4/1999 06:40'! maxFileNameLength ^ 255! ! Instances of me, which are really just FMSounds, are used placeholders for sounds that have been unloaded from this image but which may be re-loaded later. ! !UnloadedSound class methodsFor: 'as yet unclassified' stamp: 'jm 1/14/1999 12:00'! default "UnloadedSound default play" | snd p | snd _ super new modulation: 1 ratio: 1. p _ OrderedCollection new. p add: 0@0.0; add: 10@1.0; add: 100@1.0; add: 120@0.0. snd addEnvelope: (VolumeEnvelope points: p loopStart: 2 loopEnd: 3). ^ snd setPitch: 440.0 dur: 1.0 loudness: 0.5 ! ! A menu item whose textual label and whose enablement are updatable. The wordingProvider provides the current wording, upon being being sent the wordingSelector. The item can also dynamically update whether or not it should be enabled; to do this, give it an enablementSelector, which is also sent to the wordingProvider..! !UpdatingMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'jm 10/4/2002 08:45'! adaptToWorld: aWorld super adaptToWorld: aWorld. wordingProvider isMorph ifTrue: [ wordingProvider isWorldMorph ifTrue: [ wordingProvider _ aWorld]. wordingProvider isHandMorph ifTrue: [wordingProvider _ aWorld primaryHand]]. ! ! !UpdatingMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/21/1999 11:28'! enablementSelector: aSelector enablementSelector _ aSelector! ! !UpdatingMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'sw 7/15/1999 07:27'! step | newString enablement | super step. wordingProvider ifNotNil: [newString _ wordingProvider perform: wordingSelector. newString = contents ifFalse: [self contents: newString]. enablementSelector ifNotNil: [enablement _ wordingProvider perform: enablementSelector. enablement == isEnabled ifFalse: [self isEnabled: enablement]]]! ! !UpdatingMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/11/1999 18:31'! stepTime ^ 1200! ! !UpdatingMenuItemMorph methodsFor: 'as yet unclassified' stamp: 'sw 6/11/1999 15:12'! wordingProvider: aProvider wordingSelector: aSelector wordingProvider _ aProvider. wordingSelector _ aSelector! ! I am a rectangle that updates its color by periodically sending a message to my target object. I also optionally allow the color of the target object to be edited. ! !UpdatingRectangleMorph methodsFor: 'initialization' stamp: 'sw 9/15/1999 15:31'! initialize super initialize. borderColor _ Color lightGray lighter ! ! !UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 12:39'! argument ^ argument ! ! !UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 12:39'! argument: arg argument _ arg. ! ! !UpdatingRectangleMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 12:42'! getSelector ^ getSelector ! ! !UpdatingRectangleMorph methodsFor: 'accessing'! getSelector: aSymbol getSelector _ aSymbol. ! ! !UpdatingRectangleMorph methodsFor: 'drawing' stamp: 'sw 10/24/1998 21:23'! drawOn: aCanvas "Copied down from BorderedMorph, with the substitution that the color inst var of the receiver here might well be something like #raised or some other symbol, which the frameAndFillRectangle... methods barf on." | insetColor colorToFill | colorToFill _ (color isKindOf: Color) ifTrue: [color] ifFalse: [Color gray]. borderWidth = 0 ifTrue: [ "no border" aCanvas fillRectangle: bounds color: color. ^ self]. borderColor == #raised ifTrue: [^ aCanvas frameAndFillRectangle: bounds fillColor: colorToFill borderWidth: borderWidth topLeftColor: colorToFill lighter bottomRightColor: colorToFill darker]. borderColor == #inset ifTrue: [insetColor _ owner colorForInsets. ^ aCanvas frameAndFillRectangle: bounds fillColor: colorToFill borderWidth: borderWidth topLeftColor: insetColor darker bottomRightColor: insetColor lighter]. "solid color border" aCanvas frameAndFillRectangle: bounds fillColor: colorToFill borderWidth: borderWidth borderColor: borderColor.! ! !UpdatingRectangleMorph methodsFor: 'events' stamp: 'di 9/3/1999 09:43'! mouseUp: evt evt hand changeColorTarget: self selector: #setTargetColor: originalColor: color. ! ! !UpdatingRectangleMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 12:57'! step | c | super step. c _ self readFromTarget. c = color ifFalse: [self color: c]. ! ! !UpdatingRectangleMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 12:40'! stepTime ^ 500 ! ! !UpdatingRectangleMorph methodsFor: 'private' stamp: 'jm 6/15/2003 12:58'! readFromTarget ((target == nil) or: [getSelector == nil]) ifTrue: [^ self color]. argument ifNil: [^ target perform: getSelector] ifNotNil: [^ target perform: getSelector with: argument]. ! ! !UpdatingRectangleMorph methodsFor: 'private' stamp: 'jm 6/15/2003 12:58'! setTargetColor: aColor | args | putSelector ifNotNil: [ self color: aColor. args _ argument ifNil: [Array with: aColor] ifNotNil: [Array with: argument with: aColor]. target perform: self putSelector withArguments: args]. ! ! I am a StringMorph that periodically polls my target object (by sending it getSelector) and displays the resulting value. If I have a putSelector, then I can be edited and my target object is informed by sending the new value as a parameter of the putSelector message. ! !UpdatingStringMorph methodsFor: 'initialization' stamp: 'jm 3/15/2003 20:37'! initialize super initialize. format _ #default. "formats: #string, #default" target _ getSelector _ lastValue _ putSelector _ parameter _ nil. floatPrecision _ 1. growable _ true. stepTime _ 50. ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 3/15/2003 19:43'! floatPrecision ^ floatPrecision ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'! floatPrecision: aNumber floatPrecision _ aNumber. ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 3/15/2003 20:34'! growable ^ growable ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 5/26/1999 16:22'! growable: aBoolean growable _ aBoolean. ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 3/15/2003 20:49'! parameter ^ parameter ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 3/15/2003 20:51'! parameter: anObject "Set a parameter (e.g., an array index) to be sent with both my get selector and my put selector. The default is nil, which means no parameter is used." parameter _ anObject. ! ! !UpdatingStringMorph methodsFor: 'accessing' stamp: 'jm 9/26/2003 08:13'! target: anObject target _ anObject. lastValue _ nil. ! ! !UpdatingStringMorph methodsFor: 'stepping' stamp: 'sw 7/15/1999 07:28'! step | s | super step. hasFocus ifFalse: ["update contents, but only if user isn't editing this string" s _ self readFromTarget. s = contents ifFalse: [self updateContentsFrom: s]] ! ! !UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:17'! stepTime ^ stepTime ifNil: [50] ! ! !UpdatingStringMorph methodsFor: 'stepping' stamp: 'jm 5/26/1999 16:23'! stepTime: mSecsPerStep stepTime _ mSecsPerStep truncated. ! ! !UpdatingStringMorph methodsFor: 'menu' stamp: 'jm 3/15/2003 20:33'! addCustomMenuItems: menu hand: aHandMorph | prefix | super addCustomMenuItems: menu hand: aHandMorph. prefix _ growable ifTrue: ['stop'] ifFalse: ['start']. menu add: prefix, ' being growable' action: #toggleGrowability. menu add: 'decimal places...' action: #setPrecision. menu add: 'font size...' action: #setFontSize. menu add: 'font style...' action: #setFontStyle. ! ! !UpdatingStringMorph methodsFor: 'menu' stamp: 'jm 6/9/2003 21:52'! setFontSize | sizes reply family | family _ font ifNil: [TextStyle default] ifNotNil: [font textStyle]. family ifNil: [family _ TextStyle default]. "safety net -- this line SHOULD be unnecessary now" sizes _ family fontNamesWithHeights. reply _ (SelectionMenu labelList: sizes selections: sizes) startUp. reply ifNotNil: [self font: (family fontAt: (sizes indexOf: reply))]! ! !UpdatingStringMorph methodsFor: 'menu' stamp: 'sw 12/7/1999 11:45'! setFontStyle | aList reply style | aList _ (TextConstants select: [:anItem | anItem isKindOf: TextStyle]) keys asOrderedCollection. reply _ (SelectionMenu labelList: aList selections: aList) startUp. reply ~~ nil ifTrue: [(style _ TextStyle named: reply) ifNil: [self beep. ^ true]. self font: (style defaultFont)]! ! !UpdatingStringMorph methodsFor: 'menu' stamp: 'sw 10/5/1998 15:31'! setPrecision | aList aMenu reply | aList _ #('0' '1' '2' '3' '4' '5'). aMenu _ SelectionMenu labels: aList selections: aList. reply _ aMenu startUpWithCaption: 'How many decimal places?'. reply ifNotNil: [self floatPrecision: (#(1 0.1 0.01 0.001 0.0001 0.00001 0.000001) at: (aList indexOf: reply))]! ! !UpdatingStringMorph methodsFor: 'menu' stamp: 'jm 3/15/2003 20:33'! toggleGrowability growable _ growable not. self updateContentsFrom: self readFromTarget. growable ifTrue: [self fitContents]. ! ! !UpdatingStringMorph methodsFor: 'editing' stamp: 'jm 9/29/2003 19:48'! acceptContents | newValue | ((target ~~ nil) and: [putSelector ~~ nil]) ifTrue: [ "compute the new value" format = #string ifTrue: [newValue _ contents] ifFalse: [ (contents size > 0 and: [contents first = $.]) ifTrue: [contents _ '0', contents]. newValue _ Compiler evaluate: contents]. newValue ifNotNil: [ parameter ifNil: [target perform: putSelector with: newValue] ifNotNil: [target perform: putSelector with: parameter with: newValue]. target isMorph ifTrue: [target changed]]. self fitContents]. ! ! !UpdatingStringMorph methodsFor: 'editing' stamp: 'jm 3/15/2003 20:43'! handlesMouseDown: evt (owner wantsKeyboardFocusFor: self) ifTrue: [^ self uncoveredAt: evt cursorPoint]. ^ super handlesMouseDown: evt ! ! !UpdatingStringMorph methodsFor: 'editing' stamp: 'jm 3/15/2003 20:36'! lostFocusWithoutAccepting "The message is sent when the user, having been in an editing episode on the receiver, changes the keyboard focus without having accepted the current edits. In This case, we just accept the edits." self acceptContents. ! ! !UpdatingStringMorph methodsFor: 'editing' stamp: 'sw 9/9/1999 10:58'! mouseDown: evt (owner wantsKeyboardFocusFor: self) ifTrue: [putSelector ifNotNil: [self launchMiniEditor: evt]]! ! !UpdatingStringMorph methodsFor: 'private' stamp: 'jm 3/15/2003 20:28'! fitContents | minWidth maxWidth scanner newExtent | minWidth _ 5. maxWidth _ 500. scanner _ DisplayScanner quickPrintOn: Display box: Display boundingBox font: self fontToUse. newExtent _ (((scanner stringWidth: contents) max: minWidth) min: maxWidth) @ scanner lineHeight. self extent = newExtent ifFalse: [ self extent: newExtent. self changed]. ! ! !UpdatingStringMorph methodsFor: 'private' stamp: 'jm 3/15/2003 21:00'! formatValue: v format = #string ifTrue: [^ v asString]. (format = #default and: [v isNumber]) ifTrue: [ v isInteger ifTrue: [^ v asInteger printString]. (v isKindOf: Float) ifTrue: [^ (v roundTo: self floatPrecision) printString]]. ^ v printString ! ! !UpdatingStringMorph methodsFor: 'private' stamp: 'jm 3/17/2003 17:01'! readFromTarget "Answer the formatted string for the value read from my target. If the target or selector are nil, or if the value is the same as the last value read, answer my current contents." | v | (v _ self valueFromTargetOrNil) ifNil: [^ contents]. lastValue = v ifTrue: [^ contents]. lastValue _ v. ^ self formatValue: v ! ! !UpdatingStringMorph methodsFor: 'private' stamp: 'jm 3/15/2003 20:34'! updateContentsFrom: aValue growable ifTrue: [self contents: aValue] ifFalse: [self contentsClipped: aValue]. ! ! !UpdatingStringMorph methodsFor: 'private' stamp: 'jm 3/17/2003 16:59'! valueFromTargetOrNil "Answer the value read from my target. Answer nil if my target or selector is nil.." ((target == nil) or: [getSelector == nil]) ifTrue: [^ nil]. parameter ifNil: [^ target perform: getSelector] ifNotNil: [^ target perform: getSelector with: parameter]. ! ! !UpdatingStringMorph class methodsFor: 'instance creation' stamp: 'jm 3/15/2003 20:49'! on: targetObject selector: aSymbol ^ self new getSelector: aSymbol; target: targetObject ! ! A repository for general and miscellaneous utilities; much of what is here are in effect global methods that don't naturally attach to anything else. All the functionality is implemented as class messages. ! !Utilities class methodsFor: 'investigations' stamp: 'jm 5/29/2003 19:10'! inspectGlobals "Utilities inspectGlobals" | dict gNames | dict _ IdentityDictionary new. gNames _ (Smalltalk keys select: [:n | (Smalltalk at: n) isBehavior not]) asArray sort. gNames do: [:n | dict add: (Smalltalk associationAt: n)]. dict inspectWithLabel: 'The Globals'. ! ! !Utilities class methodsFor: 'identification' stamp: 'sw 7/6/1998 11:49'! authorInitialsPerSe "Answer the currently-prevailing author initials, such as they, empty or not" ^ AuthorInitials! ! !Utilities class methodsFor: 'identification' stamp: 'jm 5/31/2003 16:25'! authorName AuthorName ifNil: [ AuthorName _ FillInTheBlank request: 'Please type your name:' initialAnswer: 'Your Name']. ^ AuthorName ! ! !Utilities class methodsFor: 'identification' stamp: 'jm 6/23/2003 09:36'! clearAuthorInfo AuthorInitials _ ''. AuthorName _ nil. ! ! !Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 22:45'! dateTimeSuffix "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc." "Utilities dateTimeSuffix" ^ Preferences twentyFourHourFileStamps ifFalse: [self monthDayTimeStringFrom: Time primSecondsClock] ifTrue: [self monthDayTime24StringFrom: Time primSecondsClock]! ! !Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'! monthDayTime24StringFrom: aSecondCount | aDate aTime | "From the date/time represented by aSecondCount, produce a string which indicates the date and time in the compact form ddMMMhhmm where dd is a two-digit day-of-month, MMM is the alpha month abbreviation and hhmm is the time on a 24-hr clock. Utilities monthDayTime24StringFrom: Time primSecondsClock " aDate _ Date fromSeconds: aSecondCount. aTime _ Time fromSeconds: aSecondCount \\ 86400. ^ (aDate dayOfMonth asTwoCharacterString), (aDate monthName copyFrom: 1 to: 3), (aTime hhmm24)! ! !Utilities class methodsFor: 'identification' stamp: 'sw 11/13/1999 23:03'! monthDayTimeStringFrom: aSecondCount | aDate aTime | "From the date/time represented by aSecondCount, produce a string which indicates the date and time in the form: ddMMMhhmmPP where: dd is a two-digit day-of-month, MMM is the alpha month abbreviation, hhmm is the time, PP is either am or pm Utilities monthDayTimeStringFrom: Time primSecondsClock " aDate _ Date fromSeconds: aSecondCount. aTime _ Time fromSeconds: aSecondCount \\ 86400. ^ (aDate dayOfMonth asTwoCharacterString), (aDate monthName copyFrom: 1 to: 3), ((aTime hours \\ 12) asTwoCharacterString), (aTime minutes asTwoCharacterString), (aTime hours > 12 ifTrue: ['pm'] ifFalse: ['am'])! ! !Utilities class methodsFor: 'identification' stamp: 'jm 12/5/2002 12:15'! setAuthorInitials "Put up a dialog allowing the user to specify the author's initials. " self setAuthorInitials: (FillInTheBlank request: 'Please type your initials: ' initialAnswer: AuthorInitials) ! ! !Utilities class methodsFor: 'support windows' stamp: 'sma 2/12/2000 20:29'! commandKeyMappings ^ self class firstCommentAt: #commandKeyMappings "Lower-case command keys (use with Cmd key on Mac and Alt key on other platforms) a Select all b Browse it (selection is a class name) c Copy selection d Do it (selection is a valid expression) e Exchange selection with prior selection f Find g Find again h Set selection as search string for find again i Inspect it (selection is a valid expression) j Again once k Set font l Cancel m Implementors of it (selection is a message selector) n Senders of it (selection is a message selector) o Spawn current method p Print it (selection is a valid expression) q Query symbol (toggle all possible completion for a given prefix) r Recognizer s Save (i.e. accept) u Toggle alignment v Paste w Delete preceding word x Cut selection y Swap characters z Undo Note: for Do it, Senders of it, etc., a null selection will be expanded to a word or to the current line in an attempt to do what you want. Also note that Senders/Implementors of it will find the outermost keyword selector in a large selection, as when you have selected a bracketed expression or an entire line. Finally note that the same cmd-m and cmd-n (and cmd-v for versions) work in the message pane of most browsers. Upper-case command keys (use with Shift-Cmd, or Ctrl on Mac or Shift-Alt on other platforms; sometimes Ctrl works too) A Advance argument B Browse it in this same browser (in System browsers only) C Compare argument to clipboard D Duplicate E Method strings containing it F Insert 'ifFalse:' I Inspect via Object Explorer J Again many K Set style L Outdent (move selection one tab-stop left) N References to it O Open single-message browser (in selector lists) R Indent (move selection one tab-stap right) S Search T Insert 'ifTrue:' U Convert linefeeds to carriage returns in selection V Paste author's initials W Selectors containing it X Force selection to lowercase Y Force selection to uppercase Z Capitalize all words in selection Other special keys Backspace Backward delete character Del Forward delete character Shift-Bcksp Backward delete word Shift-Del Forward delete word Esc Select current type-in Cursor keys left, right, up, or down Move cursor left, right, up or down Ctrl+Left Move cursor left one word Ctrl+Right Move cursor right one word Home Move cursor to begin of line or begin of text End Move cursor to end of line or end of text PgUp, or Ctrl+Up Move cursor up one page PgDown, or Ctrl+Down Move cursor down one page Note all these keys can be used together with Shift to define or enlarge the selection. You cannot however shrink that selection again, which is, compared to other systems, still a limitation aka bug. Other Cmd-key combinations (does not work on all platforms) Return Insert return followed by as many tabs as the previous line (with a further adjustment for additional brackets in that line) Space Select the current word as with double clicking Enclose the selection in a kind of bracket. Each is a toggle. (does not work on all platforms) Ctrl-( Enclose within ( and ), or remove enclosing ( and ) Ctrl-[ Enclose within [ and ], or remove enclosing [ and ] Crtl-{ Enclose within { and }, or remove enclosing { and } Ctrl-< Enclose within < and >, or remove enclosing < and > Ctrl-' Enclose within ' and ', or remove enclosing ' and ' Ctrl-"" Enclose within "" and "", or remove enclosing "" and "" Note also that you can double-click just inside any of the above delimiters (or at the beginning or end of a line) to select the text enclosed. Text Emphasis... (does not work on all platforms) Cmd-1 10 point font Cmd-2 12 point font Cmd-3 18 point font Cmd-4 24 point font Cmd-5 36 point font Cmd-6 color, action-on-click, link to class comment, link to method, url Brings up a menu. To remove these properties, select more than the active part and then use command-0. Cmd-7 bold Cmd-8 italic Cmd-9 narrow (same as negative kern) Cmd-0 plain text (resets all emphasis) Cmd-- underlined (toggles it) Cmd-= struck out (toggles it) Shift-Cmd-- (aka _) negative kern (letters 1 pixel closer) Shift-Cmd-+ positive kern (letters 1 pixel larger spread) "! ! !Utilities class methodsFor: 'support windows' stamp: 'di 9/23/1998 01:53'! openCommandKeyHelp "Open a window giving command key help." "Utilities openCommandKeyHelp" (StringHolder new contents: self commandKeyMappings) openLabel: 'Command Key Actions' ! ! !Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:17'! informUser: aString during: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block." "Utilities informUser: 'Just a sec!!' during: [(Delay forSeconds: 1) wait]" Smalltalk isMorphic ifTrue: [(MVCMenuMorph from: (SelectionMenu labels: '') title: aString) displayAt: Sensor cursorPoint during: [aBlock value]. ^ self]. (SelectionMenu labels: '') displayAt: Sensor cursorPoint withCaption: aString during: [aBlock value]! ! !Utilities class methodsFor: 'user interface' stamp: 'sma 4/30/2000 10:18'! informUserDuring: aBlock "Display a message above (or below if insufficient room) the cursor during execution of the given block." "Utilities informUserDuring:[:bar| #(one two three) do:[:info| bar value: info. (Delay forSeconds: 1) wait]]" Smalltalk isMorphic ifTrue: [(MVCMenuMorph from: (SelectionMenu labels: '') title: ' ') informUserAt: Sensor cursorPoint during: aBlock. ^ self]. aBlock value:[:string| Transcript cr; show: string]! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'JMM 3/31/2000 20:41'! awaitMouseUpIn: box whileMouseDownDo: doBlock1 whileMouseDownInsideDo: doBlock2 ifSucceed: succBlock "The mouse has gone down in box; track the mouse, inverting the box while it's within, and if, on mouse up, the cursor was still within the box, execute succBlock. While waiting for the mouse to come up, repeatedly execute doBlock1, and also, if the cursor is within the box, execute doBlock2. 6/10/96 sw 3/31/00 JMM added logic to stop multiple redraws" | p inside lightForm darkForm isLight | p _ Sensor cursorPoint. inside _ box insetBy: 1. isLight _ true. lightForm _ Form fromDisplay: inside. darkForm _ lightForm deepCopy reverse. [Sensor anyButtonPressed] whileTrue: [doBlock1 value. (box containsPoint: (p _ Sensor cursorPoint)) ifTrue: [doBlock2 value. isLight ifTrue: [isLight _ false. darkForm displayAt: inside origin]] ifFalse: [isLight ifFalse: [isLight _ true. lightForm displayAt: inside origin]]]. (box containsPoint: p) ifTrue: [lightForm displayAt: inside origin. ^ succBlock value] ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'jm 11/25/1998 22:31'! convertCRtoLF: fileName "Convert the given file to LF line endings. Put the result in a file with the extention '.lf'" | in out c justPutCR | in _ (FileStream oldFileNamed: fileName) binary. out _ (FileStream newFileNamed: fileName, '.lf') binary. justPutCR _ false. [in atEnd] whileFalse: [ c _ in next. c = 10 ifTrue: [ out nextPut: 13. justPutCR _ true] ifFalse: [ (justPutCR and: [c = 10]) ifFalse: [out nextPut: c]. justPutCR _ false]]. in close. out close. ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sma 4/30/2000 10:17'! emergencyCollapse Smalltalk isMorphic ifTrue: [^ self]. ScheduledControllers screenController emergencyCollapse! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sw 2/15/1999 12:24'! fileOutChanges "File out the current change set to a file whose name is a function of the current date and time." Smalltalk changes fileOut. Transcript cr; show: 'Changes filed out ', Date dateAndTimeNow printString ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'jm 7/20/2003 22:30'! form: partName from: directory "Answer the form with the given name in the given directory or nil if there isn't one." | f | directory fileNames do: [:fn | ((partName, '.*') match: fn) ifTrue: [ f _ [Form fromFileNamed: (directory fullNameFor: fn)] ifError: [nil]. f ifNotNil: [^ f]]]. ^ nil ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sw 7/22/1998 17:12'! instanceComparisonsBetween: fileName1 and: fileName2 "For differential results, run printSpaceAnalysis twice with different fileNames, then run this method... Smalltalk printSpaceAnalysis: 0 on: 'STspace.text1'. --- do something that uses space here --- Smalltalk printSpaceAnalysis: 0 on: 'STspace.text2'. Smalltalk instanceComparisonsBetween: 'STspace.text1' and 'STspace.text2'" | instCountDict report f aString items className newInstCount oldInstCount newSpace oldPair oldSpace | instCountDict _ Dictionary new. report _ ReadWriteStream on: ''. f _ FileStream oldFileNamed: fileName1. [f atEnd] whileFalse: [aString _ f upTo: Character cr. items _ aString findTokens: ' '. (items size == 4 or: [items size == 5]) ifTrue: [instCountDict at: items first put: (Array with: items third asNumber with: items fourth asNumber)]]. f close. f _ FileStream oldFileNamed: fileName2. [f atEnd] whileFalse: [aString _ f upTo: Character cr. items _ aString findTokens: ' '. (items size == 4 or: [items size == 5]) ifTrue: [className _ items first. newInstCount _ items third asNumber. newSpace _ items fourth asNumber. oldPair _ instCountDict at: className ifAbsent: [nil]. oldInstCount _ oldPair ifNil: [0] ifNotNil: [oldPair first]. oldSpace _ oldPair ifNil: [0] ifNotNil: [oldPair second]. oldInstCount ~= newInstCount ifTrue: [report nextPutAll: (newInstCount - oldInstCount) printString; tab; nextPutAll: (newSpace - oldSpace) printString; tab; nextPutAll: className asString; cr]]]. f close. (StringHolder new contents: report contents) openLabel: 'Instance count differentials between ', fileName1, ' and ', fileName2! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sw 1/12/1999 12:24'! methodDiffFor: aString class: aClass selector: aSelector ^ (aClass includesSelector: aSelector) ifFalse: [aString copy] ifTrue: [TextDiffBuilder buildDisplayPatchFrom: (aClass sourceCodeAt: aSelector) to: aString]! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'sw 10/20/1999 13:48'! setClassAndSelectorFrom: messageIDString in: csBlock "Decode strings of the form <className> [class] <selectorName>. If <className> does not exist as a class, use nil for the class in the block" | aStream aClass maybeClass sel | aStream _ ReadStream on: messageIDString. aClass _ Smalltalk at: (aStream upTo: $ ) asSymbol ifAbsent: [nil]. maybeClass _ aStream upTo: $ . sel _ aStream upTo: $ . ((maybeClass = 'class') & (sel size ~= 0)) ifTrue: [aClass ifNil: [csBlock value: nil value: sel asSymbol] ifNotNil: [csBlock value: aClass class value: sel asSymbol]] ifFalse: [csBlock value: aClass value: maybeClass asSymbol] " Utilities setClassAndSelectorFrom: 'Utilities class oppositeModeTo:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. Utilities setClassAndSelectorFrom: 'MessageSet setClassAndSelectorIn:' in: [:aClass :aSelector | Transcript cr; show: 'Class = ', aClass name printString, ' selector = ', aSelector printString]. " ! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'jm 4/20/1999 11:29'! timeStampForMethod: method "Answer the authoring time-stamp for the given method, retrieved from the sources or changes file. Answer the empty string if no time stamp is available." | position file preamble stamp tokens tokenCount | method fileIndex == 0 ifTrue: [^ String new]. "no source pointer for this method" position _ method filePosition. file _ SourceFiles at: method fileIndex. file ifNil: [^ String new]. "sources file not available" file _ file readOnlyCopy. 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]. stamp _ String new. tokens _ (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [Scanner new scanTokens: preamble] ifFalse: [Array new "ie cant be back ref"]. (((tokenCount _ tokens size) between: 7 and: 8) and: [(tokens at: tokenCount - 5) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 3) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount - 2]]. ((tokenCount between: 5 and: 6) and: [(tokens at: tokenCount - 3) = #methodsFor:]) ifTrue: [(tokens at: tokenCount - 1) = #stamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp _ tokens at: tokenCount]]. file close. ^ stamp! ! !Utilities class methodsFor: 'miscellaneous' stamp: 'jm 10/7/2002 05:38'! vmStatisticsReportString "StringHolderView open: (StringHolder new contents: Utilities vmStatisticsReportString) label: 'VM Statistics'" | params oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount upTime | params _ Smalltalk getVMParameters. oldSpaceEnd _ params at: 1. youngSpaceEnd _ params at: 2. memoryEnd _ params at: 3. fullGCs _ params at: 7. fullGCTime _ params at: 8. incrGCs _ params at: 9. incrGCTime _ params at: 10. tenureCount _ params at: 11. upTime _ Time millisecondClockValue. ^ String streamContents: [:str | str nextPutAll: 'uptime '; print: (upTime / 1000 / 60 // 60); nextPut: $h; print: (upTime / 1000 / 60 \\ 60) asInteger; nextPut: $m; print: (upTime / 1000 \\ 60) asInteger; nextPut: $s; cr; cr. str nextPutAll: 'memory '; nextPutAll: memoryEnd asStringWithCommas; nextPutAll: ' bytes'; cr. str nextPutAll: ' old '; nextPutAll: oldSpaceEnd asStringWithCommas; nextPutAll: ' bytes ('; print: ((oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. str nextPutAll: ' young '; nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommas; nextPutAll: ' bytes ('; print: ((youngSpaceEnd - oldSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. str nextPutAll: ' used '; nextPutAll: youngSpaceEnd asStringWithCommas; nextPutAll: ' bytes ('; print: ((youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr. str nextPutAll: ' free '; nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommas; nextPutAll: ' bytes ('; print: ((memoryEnd - youngSpaceEnd / memoryEnd * 100) roundTo: 0.1); nextPutAll: '%)'; cr; cr. str nextPutAll: 'GCs '; nextPutAll: (fullGCs + incrGCs) asStringWithCommas; nextPutAll: ' ('; print: ((upTime / (fullGCs + incrGCs)) roundTo: 1); nextPutAll: 'ms between GCs)'; cr. str nextPutAll: ' full '; print: fullGCs; nextPutAll: ' in '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((fullGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime)'. fullGCs = 0 ifFalse: [str nextPutAll: ', avg '; print: ((fullGCTime / fullGCs) roundTo: 1.0); nextPutAll: 'ms']. str cr. str nextPutAll: ' incr '; print: incrGCs; nextPutAll: ' in '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms ('; print: ((incrGCTime / upTime * 100) roundTo: 1.0); nextPutAll: '% uptime), avg '; print: ((incrGCTime / incrGCs) roundTo: 1.0); nextPutAll: 'ms'; cr. str nextPutAll: ' tenures '; nextPutAll: tenureCount asStringWithCommas. tenureCount = 0 ifFalse: [str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)']. str cr]. ! ! !Utilities class methodsFor: 'summer97 additions' stamp: 'sw 10/5/1998 17:58'! chooseFileWithSuffixFromList: aSuffixList withCaption: aCaption "Pop up a list of all files in the default directory which have a suffix in the list. Return #none if there are none; return nil if the user backs out of the menu without making a choice." "Utilities chooseFileWithSuffixFromList: #('.gif' '.jpg')" | aList aName | aList _ OrderedCollection new. aSuffixList do: [:aSuffix | aList addAll: (FileDirectory default fileNamesMatching: '*', aSuffix)]. ^ aList size > 0 ifTrue: [aName _ (SelectionMenu selections: aList) startUpWithCaption: aCaption. aName] ifFalse: [#none]! ! !Utilities class methodsFor: 'summer97 additions' stamp: 'sw 5/4/2000 13:47'! classFromPattern: pattern withCaption: aCaption "If there is a class whose name exactly given by pattern, return it. If there is only one class in the system whose name matches pattern, return it. Otherwise, put up a menu offering the names of all classes that match pattern, and return the class chosen, else nil if nothing chosen" | toMatch potentialClassNames classNames exactMatch index | pattern isEmpty ifTrue: [^ nil]. Symbol hasInterned: pattern ifTrue: [:patternSymbol | Smalltalk at: patternSymbol ifPresent: [:maybeClass | (maybeClass isKindOf: Class) ifTrue: [^ maybeClass]]]. toMatch _ (pattern copyWithout: $.) asLowercase. potentialClassNames _ Smalltalk classNames asOrderedCollection. classNames _ pattern last = $. ifTrue: [potentialClassNames select: [:nm | nm asLowercase = toMatch]] ifFalse: [potentialClassNames select: [:n | n includesSubstring: toMatch caseSensitive: false]]. classNames isEmpty ifTrue: [^ nil]. exactMatch _ classNames detect: [:each | each asLowercase = toMatch] ifNone: [nil]. index _ classNames size = 1 ifTrue: [1] ifFalse: [exactMatch ifNil: [(PopUpMenu labelArray: classNames lines: #()) startUpWithCaption: aCaption] ifNotNil: [classNames addFirst: exactMatch. (PopUpMenu labelArray: classNames lines: #(1)) startUpWithCaption: aCaption]]. index = 0 ifTrue: [^ nil]. ^ Smalltalk at: (classNames at: index) asSymbol " Utilities classFromPattern: 'CharRecog' Utilities classFromPattern: 'rRecog' Utilities classFromPattern: 'znak' Utilities classFromPattern: 'orph' " ! ! I am a parse tree leaf representing a variable. Note that my name and key are different for pool variables: the key is the Object Reference.! !VariableNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:40'! isSelfPseudoVariable "Answer if this ParseNode represents the 'self' pseudo-variable." ^ key = 'self'! ! !VariableNode methodsFor: 'testing' stamp: 'di 2/3/1999 09:41'! type "This code attempts to reconstruct the type from its encoding in code. This allows one to test, for instance, (aNode type = LdInstType)." | type | code < 0 ifTrue: [^ code negated]. code < 256 ifFalse: [^ code // 256]. type _ CodeBases findFirst: [:one | code < one]. type = 0 ifTrue: [^ 5] ifFalse: [^ type - 1]! ! !VariableNode methodsFor: 'code generation' stamp: 'di 2/6/2000 10:52'! fieldOffset "Return temp or instVar offset for this variable" code < 256 ifTrue: [^ code \\ 16] ifFalse: [^ code \\ 256]! ! !VariableNode methodsFor: 'printing' stamp: 'sw 11/16/1999 16:36'! printOn: aStream indent: level aStream withAttributes: (Preferences syntaxAttributesFor: #variable) do: [aStream nextPutAll: name]. ! ! !VariableNode methodsFor: 'C translation' stamp: 'jm 11/15/2003 04:50'! asTranslatorNode name = 'true' ifTrue: [^ TConstantNode new setValue: true]. name = 'false' ifTrue: [^ TConstantNode new setValue: false]. ^ TVariableNode new setName: name ! ! This morph simulates an old-fashioned vector display. In the mid-1970's, Danny Hillis and Marvin Minsky built a computer with a vector graphics display and used it to do Logo-style turtle graphics. An interesting additional feature they added was the ability to make the turtle's coordinate system rotate a varying speeds allowing animated drawings to be created very easily. To experiment with this morph, copy the following and paste it into a Workspace window, then select each group of lines and invoke "do it" from the menu or by typing alt-d (cmd-d on a Mac). "create the virtual vector scope display:" d _ VectorScopeMorph new openInWorld. "stationary line:" d cs. d forward: 50. "spinning line:" d cs. d spin: 2. d forward: 50. "nested spins:" d cs. d spin: 5; forward: 50. d spin: -5; forward: 50. d spin: -10; forward: 50. "ferris wheel:" d cs. d spin: 1. 16 timesRepeat: [ 4 timesRepeat: [d forward: 50; right: 90]. d right: 22.5] "snake:" d cs. 10 timesRepeat: [d spin: 1; forward: 100] "snake made from flags:" d cs. 5 timesRepeat: [ d spin: 5; forward: 50. 4 timesRepeat: [d forward: 50; right: 90]] "first two terms of the Fourier series for a square wave:" d cs. d spin: 1; forward: 100; spin: -2; forward: 100; spin: 1. d spin: 3; forward: -100 / 3 ; spin: -6; forward: -100 / 3; spin: 3. d startGraph. "graphs the y component of the final turtle position" "first five terms of the Fourier series for a square wave:" d cs. d spin: 1; forward: 100; spin: -2; forward: 100; spin: 1. d spin: 3; forward: -100 / 3 ; spin: -6; forward: -100 / 3; spin: 3. d spin: 5; forward: 100 / 5 ; spin: -10; forward: 100 / 5; spin: 5. d spin: 7; forward: -100 / 7 ; spin: -14; forward: -100 / 7; spin: 7. d spin: 9; forward: 100 / 9 ; spin: -18; forward: 100 / 9; spin: 9. d startGraph. "misc. graphing controls" d clearGraph d startGraph. d stopGraph. ! !VectorScopeMorph methodsFor: 'initialization' stamp: 'jm 6/16/2003 18:44'! initialize super initialize. self position: 10@150. self form: (Form extent: 400@400 depth: Display depth). displayList _ OrderedCollection new. graphPen _ nil. tickNum _ 0. self cs. ! ! !VectorScopeMorph methodsFor: 'accessing' stamp: 'jm 6/15/2003 09:37'! form: aForm "Create a pen on my new Form." super form: aForm. pen _ Pen newOnForm: form. pen color: Color white. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:50'! clearGraph "Clear the graph and place the graph pen on the left edge of the screen." Display restore. graphPen ifNotNil: [graphPen place: 0@0]. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:37'! cs "Clear the screen and the the display list." displayList _ displayList species new. graphPen ifNotNil: [graphPen place: 0@0]. tickNum _ 0. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:42'! forward: n "Add a forward command to my display list." displayList add: {#doForward:. n}. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:42'! right: n "Add a right turn command to my display list. The argument is in degrees. Negative arguments turn left." displayList add: {#doRight:. n}. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:45'! spin: n "Make the coordinate system for subsequent drawing operations rotate by the given number of degrees per update cycle. Spin commands are additive: a spin of 2 followed by a spin of 5 results in a cummulative spin of 5. It follows that a negative spin can cancel out a positive spin of the same amount." displayList add: {#doSpin:. n}. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 10:07'! startGraph "Start graphing the final y-coordinate of the drawing pen. Can be used to show, for example, how the y-component of a spinning line results in a sine wave." Display restore. graphPen _ Pen new place: 0@0. graphPen color: Color blue. ! ! !VectorScopeMorph methodsFor: 'commands' stamp: 'jm 6/15/2003 09:51'! stopGraph "Stop graphing." graphPen _ nil. Display restore. ! ! !VectorScopeMorph methodsFor: 'stepping' stamp: 'jm 6/15/2003 09:53'! step "Clear the screen, perform all actions on the display list, and increment the tick number. If graphPen is not nil, plot the y-coordinate of the scope's drawing pen." pen home; north. form fillBlack. displayList do: [:a | self perform: a first withArguments: a allButFirst]. graphPen ifNotNil: [ graphPen goto: (graphPen location x + 1) @ (pen location y // 3)]. tickNum _ (tickNum + 1) \\ 360. self changed. ! ! !VectorScopeMorph methodsFor: 'stepping' stamp: 'jm 6/12/2003 12:59'! stepTime ^ 50 ! ! !VectorScopeMorph methodsFor: 'private' stamp: 'jm 6/15/2003 09:38'! doForward: n "Do a display list 'forward' command." pen go: n. ! ! !VectorScopeMorph methodsFor: 'private' stamp: 'jm 6/15/2003 09:39'! doRight: n "Do a display list 'right' command." pen turn: n. ! ! !VectorScopeMorph methodsFor: 'private' stamp: 'jm 6/15/2003 09:39'! doSpin: n "Do a display list 'spin' command." pen turn: n * tickNum. ! ! !VectorScopeMorph class methodsFor: 'instance creation' stamp: 'jm 6/16/2003 18:47'! includeInNewMorphMenu ^ true ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'sw 5/6/2000 01:16'! changeListButtonSpecs ^#( ('compare to current' compareToCurrentVersion 'opens a separate window which shows the text differences between the selected version and the current version') ('revert' fileInSelections 'reverts the method to the version selected') ('remove from changes' removeMethodFromChanges 'remove this method from the current change set') ('help' offerVersionsHelp 'further explanation about use of Versions browsers') )! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'sbw 12/30/1999 14:43'! optionalButtonsView | view bHeight vWidth offset triples buttonCount previousView wid button | view _ View new model: self. bHeight _ self optionalButtonHeight. vWidth _ 180. view window: (0@0 extent: vWidth@bHeight). offset _ 0. triples _ self versionListButtonTriples. buttonCount _ triples size + 1. previousView _ nil. wid _ vWidth // buttonCount. triples do: [:triplet | button _ PluggableButtonView on: self getState: nil action: triplet second. button label: triplet first asParagraph; insideColor: Color lightBlue; borderWidthLeft: 0 right: 1 top: 0 bottom: 0; window: (offset@0 extent: wid@bHeight). offset _ offset + wid. triplet last = triples first last ifTrue: [view addSubView: button] ifFalse: [view addSubView: button toRightOf: previousView]. previousView _ button]. button _ PluggableButtonView on: self getState: #showDiffs action: #toggleDiff. button label: 'toggle diff' asParagraph; insideColor: Color lightBlue; window: (offset@0 extent: (vWidth - offset)@bHeight). view addSubView: button toRightOf: previousView. ^ view ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'sw 11/28/1999 22:50'! reformulateList | aMethod | "Some uncertainty about how to deal with lost methods here" aMethod _ classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ self]. self scanVersionsOf: aMethod class: classOfMethod theNonMetaClass meta: classOfMethod isMeta category: (classOfMethod whichCategoryIncludesSelector: selectorOfMethod) selector: selectorOfMethod. self changed: #list. "for benefit of mvc" listIndex _ 1. self changed: #listIndex. self contentsChanged ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'ar 5/17/2000 18:30'! scanVersionsOf: method class: class meta: meta category: category selector: selector | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp | selectorOfMethod _ selector. currentCompiledMethod _ method. classOfMethod _ meta ifTrue: [class class] ifFalse: [class]. 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: [^ 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 _ sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos _ sourceFilesCopy filePositionFromSourcePointer: prevPos] 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! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'sw 10/19/1999 14:11'! updateListsAndCodeIn: aWindow | aMethod | aMethod _ classOfMethod compiledMethodAt: selectorOfMethod ifAbsent: [^ false]. aMethod == currentCompiledMethod ifFalse: [self reformulateList]. ^ true ! ! !VersionsBrowser methodsFor: 'init & update' stamp: 'sbw 12/30/1999 14:34'! versionListButtonTriples ^#( ('compare to current' compareToCurrentVersion 'opens a separate window which shows the text differences between the selected version and the current version') ('revert' fileInSelections 'reverts the method to the version selected') ('remove from changes' removeMethodFromChanges 'remove this method from the current change set') ('help' offerVersionsHelp 'further explanation about use of Versions browsers') )! ! !VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 17:51'! fileInSelections super fileInSelections. self reformulateList! ! !VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:49'! offerVersionsHelp (StringHolder new contents: self versionsHelpString) openLabel: 'Versions Browsers'! ! !VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:36'! removeMethodFromChanges Smalltalk changes removeSelectorChanges: selectorOfMethod class: classOfMethod ! ! !VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 23:09'! versionsHelpString ^ 'Each entry in the list pane represents a version of the source code for the same method; the topmost entry is the current version, the next entry is the next most recent, etc. To revert to an earlier version, select it (in the list pane) and then do any of the following: * Choose "revert to this version" from the list pane menu. * Hit the "revert" button, * Type ENTER in the code pane * Type cmd-s (alt-s) in the code pane. The code pane shows the source for the selected version. If "diffing" is in effect, then differences betwen the selected version and the version before it are pointed out in the pane. Turn diffing on and off by choosing "toggle diffing" from the list pane menu, or hitting the "diffs" button. To get a comparison between the selected version and the current version, choose "compare to current" from the list pane menu or hit the "compare to current" button. (This is meaningless if the current version is selected, and is unnecessary if you''re interested in diffs from between the current version and the next-most-recent version, since the standard in-pane "diff" feature will give you that.) If further versions of the method in question have been submitted elsewhere since you launched a particular Versions Browser, it will still stay nicely up-to-date if you''re in Morphic and have asked that lazy updating be maintained; if you''re in mvc, you can use the "update list" command to make certain the versions list is up to date. Hit the "remove from changes" button, or choose the corresponding command in the list pane menu, to have the method in question deleted from the current change set. This is useful if you''ve put debugging code into a method, and now want to strip it out and cleanse your current change set of all memory of the excursion.'! ! !VersionsBrowser methodsFor: 'menu' stamp: 'sw 10/12/1999 22:32'! versionsMenu: aMenu ^ aMenu labels: 'compare to current revert to this version remove from changes toggle diffing update list help...' lines: #() selections: #(compareToCurrentVersion fileInSelections removeMethodFromChanges toggleDiffing reformulateList offerVersionsHelp) ! ! !VersionsBrowser methodsFor: 'misc' stamp: 'sw 10/19/1999 15:04'! showsVersions ^ true! ! !VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'di 1/11/2000 12:45'! browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector ^ self browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: nil! ! !VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'di 1/11/2000 12:44'! browseVersionsOf: method class: class meta: meta category: msgCategory selector: selector lostMethodPointer: sourcePointer | changeList | Cursor read showWhile: [changeList _ self new scanVersionsOf: method class: class meta: meta category: msgCategory selector: selector]. changeList ifNil: [^ self inform: 'No versions available']. sourcePointer ifNotNil: [changeList setLostMethodPointer: sourcePointer]. self open: changeList name: 'Recent versions of ' , selector multiSelect: false! ! !VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/21/1999 17:21'! timeStampFor: aSelector class: aClass reverseOrdinal: anInteger "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." | method aChangeList | method _ aClass compiledMethodAt: aSelector ifAbsent: [^ nil]. aChangeList _ self new scanVersionsOf: method class: aClass meta: aClass isMeta category: nil selector: aSelector. ^ aChangeList ifNil: [nil] ifNotNil: [aChangeList list size >= anInteger ifTrue: [(aChangeList changeList at: anInteger) stamp] ifFalse: [nil]]! ! !VersionsBrowser class methodsFor: 'as yet unclassified' stamp: 'sw 10/19/1999 15:01'! 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. Answer zero if no logged version can be obtained." | method aChangeList | method _ aClass compiledMethodAt: aSelector ifAbsent: [^ 0]. aChangeList _ self new scanVersionsOf: method class: aClass meta: aClass isMeta category: nil selector: aSelector. ^ aChangeList ifNil: [0] ifNotNil: [aChangeList list size]! ! My instances are intended to be components in a structured picture. Each View in the structured picture can contain other Views as sub-components. These sub-components are called subViews. A View can be a subView of only one View. This View is called its superView. The set of Views in a structured picture forms a hierarchy. The one View in the hierarchy that has no superView is called the topView of the structured picture. A View in a structured picture with no subViews is called a bottom View. A View and all of its subViews, and all of their subViews and so on, are treated as a unit in many operations on the View. For example, if a View is displayed, all of its subViews are displayed as well. There are several categories of operations that can be performed on a View. Among these are the following: 1. Adding subViews to a View. 2. Positioning subViews within a View. 3. Deleting subViews from a View. 4. Transforming a View. 5. Displaying a View. Each View has its own coordinate system. In order to change from one coordinate system to another, each View has two transformations associated with it. The local transformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the coordinate system of the superView of the View. The displayTransformation is a WindowingTransformation that maps objects in the coordinate system of the View to objects in the display screen coordinate system. The part of the space that is to be made visible is represented by the window of the View. The window of a View is a Rectangle expressed in the coordinate system of the View. The area occupied by a View in the coordinate system of its superView is called its viewport. The viewport of a View is its window transformed by its local transformation. The region of the display screen occupied by a View is called its displayBox. The display box of a View can include a border. The width of the border expressed in display screen coordinates is called the border width of the View. The color of the border is called the border color. The region of the display box of a View excluding the border is called the inset display box. The color of the inset display box is called the inside color of the View.! !View methodsFor: 'display box access' stamp: 'jm 6/15/2003 18:25'! boundingBox "Answer my bounding box, which in this default case is the rectangle surrounding the bounding boxes of all my subViews." ^ boundingBox ~~ nil ifTrue: [boundingBox] ifFalse: [self computeBoundingBox] ! ! !View methodsFor: 'display box access' stamp: 'acg 2/23/2000 00:08'! insetDisplayBox "Answer the receiver's inset display box. The inset display box is the intersection of the receiver's window, tranformed to display coordinates, and the inset display box of the superView, inset by the border width. The inset display box represents the region of the display screen in which the inside of the receiver (all except the border) is displayed. If the receiver is totally clipped by the display screen and its superView, the resulting Rectangle will be invalid." insetDisplayBox ifNil: [insetDisplayBox _ self computeInsetDisplayBox]. ^insetDisplayBox! ! !View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:34'! backgroundColor Display depth <= 2 ifTrue: [^ Color white]. insideColor ifNotNil: [^ Color colorFrom: insideColor]. ^ superView == nil ifFalse: [superView backgroundColor] ifTrue: [Color white]! ! !View methodsFor: 'bordering' stamp: 'sw 11/2/1998 15:35'! foregroundColor borderColor ifNotNil: [^ Color colorFrom: borderColor]. ^ superView == nil ifFalse: [superView foregroundColor] ifTrue: [Color black]! ! !View methodsFor: 'morphic compatibility' stamp: 'mdr 1/24/2000 17:27'! setBalloonText: aString "Unfortunately we just ignore this help text because we are not morphic" ! ! I am a server for a simple voice messaging system. The first byte of the request message determines the response: 1 -- sendMsg format: <1><from><toList><sampleRate><GSMData> response: <empty> 2 -- nextMsg format: <2><user> response: <empty> | <2><from><toList><sampleRate><GSMData> 3 -- deleteMsg format: <3><user> response: <empty> 4 -- availableUsers format: <4><user> response: <4><userList> 5 -- allUsers format: <5><user> response: <5><userList> The client sends a voice message using sendMsg and polls for incoming messages by sending nextMsg requests. When it gets a non-empty reply, it removes that message from its message mailbox by sending deleteMsg, typically as part of the same transaction. A client can also get a list of all users (allUsers) or can find out which other users are currently online (availableUsers). The reply is a list of users that have performed a nextMsg request to the server recently. ! !VoiceMsgServer methodsFor: 'initialization' stamp: 'jm 9/5/2001 07:48'! initialize super initialize. lastPollTime _ Dictionary new. msgBox _ Dictionary new. ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 12:01'! handleAllUsers: aByteArray "Handle a allUsers request. The answer is a list of alll users who are registered with the server." | s user allUsers out | s _ ReadStream on: aByteArray. s skip: 1. "op" user _ s string. self ensureUserRegistered: user. allUsers _ lastPollTime keys asArray sort. out _ WriteStream on: (ByteArray new: 1000). out nextPut: 5. out uint16: allUsers size. allUsers do: [:u | out string: u]. ^ out contents ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 11:44'! handleDeleteMsg: aByteArray "Handle a deleteMsg request. Delete the first message in the requestor's message box, if any." | s user box | s _ ReadStream on: aByteArray. s skip: 1. "op" user _ s string. self ensureUserRegistered: user. box _ msgBox at: user. box isEmpty ifFalse: [box removeFirst]. ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 11:42'! handleMsgSend: aByteArray "Handle a send request. The full message is in the proper format to be answered to a nextMsg request, which saves copying." | s from toCount to | s _ ReadStream on: aByteArray. s skip: 1. "op" from _ s string. self ensureUserRegistered: from. toCount _ s uint16. toCount timesRepeat: [ to _ s string. self ensureUserRegistered: to. (msgBox at: to) addLast: aByteArray]. "append the message" ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 11:48'! handleNextMsg: aByteArray "Process a nextMsg request. If the requesting user has no messages, answer the empty message. Otherwise, answer the first message in that user's message box." | s user box | s _ ReadStream on: aByteArray. s skip: 1. "op" user _ s string. self ensureUserRegistered: user. box _ msgBox at: user. box isEmpty ifTrue: [^ ByteArray new]. "no messages; respond with empty message" ^ box first "answer the first message" ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 11:46'! handleUsersAvailable: aByteArray "Handle a usersAvailable request. The answer is a list of users who have interacted with the server in the past several minutes." | s user cutoffTime availableUsers out | s _ ReadStream on: aByteArray. s skip: 1. "op" user _ s string. self ensureUserRegistered: user. cutoffTime _ Time totalSeconds - 120. availableUsers _ lastPollTime keys asArray sort select: [:u | (lastPollTime at: u) > cutoffTime]. out _ WriteStream on: (ByteArray new: 1000). out nextPut: 4. out uint16: availableUsers size. availableUsers do: [:u | out string: u]. ^ out contents ! ! !VoiceMsgServer methodsFor: 'request handling' stamp: 'jm 9/5/2001 11:58'! processMessage: aByteArray "This server implements five commands. Zero-length messages are echoed. The first byte of the message defines the other commands:" | op | aByteArray size = 0 ifTrue: [^ '']. "ping: an empty message generates an empty respose" op _ aByteArray first. op = 1 ifTrue: [^ self handleMsgSend: aByteArray]. op = 2 ifTrue: [^ self handleNextMsg: aByteArray]. op = 3 ifTrue: [^ self handleDeleteMsg: aByteArray]. op = 4 ifTrue: [^ self handleUsersAvailable: aByteArray]. op = 5 ifTrue: [^ self handleAllUsers: aByteArray]. ^ ByteArray new "null reply" ! ! !VoiceMsgServer methodsFor: 'private' stamp: 'jm 9/4/2001 15:13'! ensureUserRegistered: aString "Make sure the given user has a message box and update the lastPollTime for that user." (msgBox includesKey: aString) ifFalse: [ msgBox at: aString put: OrderedCollection new]. lastPollTime at: aString put: Time totalSeconds. ! ! !VoiceMsgServer class methodsFor: 'port number' stamp: 'jm 9/18/2001 11:56'! portNumber ^ 54324 ! ! !VolumeEnvelope methodsFor: 'other' stamp: 'jm 8/17/1998 17:29'! computeSlopeAtMSecs: mSecs "Private!! Find the next inflection point of this envelope and compute its target volume and the number of milliseconds until the inflection point is reached." | t i | ((loopEndMSecs ~~ nil) and: [mSecs >= loopEndMSecs]) ifTrue: [ "decay phase" t _ (points at: loopEndIndex) x + (mSecs - loopEndMSecs). i _ self indexOfPointAfterMSecs: t startingAt: loopEndIndex. i == nil ifTrue: [ "past end" targetVol _ points last y * decayScale. mSecsForChange _ 0. nextRecomputeTime _ mSecs + 1000000. ^ self]. targetVol _ (points at: i) y * decayScale. mSecsForChange _ (((points at: i) x - t) min: (endMSecs - mSecs)) max: 4. nextRecomputeTime _ mSecs + mSecsForChange. ^ self]. mSecs < loopStartMSecs ifTrue: [ "attack phase" i _ self indexOfPointAfterMSecs: mSecs startingAt: 1. targetVol _ (points at: i) y. mSecsForChange _ ((points at: i) x - mSecs) max: 4. nextRecomputeTime _ mSecs + mSecsForChange. ((loopEndMSecs ~~ nil) and: [nextRecomputeTime > loopEndMSecs]) ifTrue: [nextRecomputeTime _ loopEndMSecs]. ^ self]. "sustain and loop phase" noChangesDuringLoop ifTrue: [ targetVol _ (points at: loopEndIndex) y. mSecsForChange _ 10. loopEndMSecs == nil ifTrue: [nextRecomputeTime _ mSecs + 10] "unknown end time" ifFalse: [nextRecomputeTime _ loopEndMSecs]. ^ self]. loopMSecs = 0 ifTrue: [^ (points at: loopEndIndex) y]. "looping on a single point" t _ loopStartMSecs + ((mSecs - loopStartMSecs) \\ loopMSecs). i _ self indexOfPointAfterMSecs: t startingAt: loopStartIndex. targetVol _ (points at: i) y. mSecsForChange _ ((points at: i) x - t) max: 4. nextRecomputeTime _ (mSecs + mSecsForChange) min: loopEndMSecs. ! ! !VolumeEnvelope methodsFor: 'other' stamp: 'jm 9/10/1998 07:04'! updateTargetAt: mSecs "Update the volume envelope slope and limit for my target. Answer false." mSecs < nextRecomputeTime ifTrue: [^ false]. self computeSlopeAtMSecs: mSecs. mSecsForChange < 5 ifTrue: [mSecsForChange _ 5]. "don't change instantly to avoid clicks" target adjustVolumeTo: targetVol * scale overMSecs: mSecsForChange. ^ false ! ! !VolumeEnvelope methodsFor: 'other' stamp: 'jm 8/17/1998 08:00'! volume: aNumber "Set the maximum volume of a volume-controlling envelope." scale _ aNumber asFloat. ! ! WarpBlt is a little warp-drive added on to BitBlt. It takes a quadrilateral as its source specification, while its destination is traversed and combined just like any other call to copyBits. The source quadrilateral is specified as an array of points starting with the corner that wants to end up in the topLeft, and proceding to the successive points that want to follow CCW around the destination rectangle. Note that in specifying a plain old rectangle source, its non topLeft points must be actual pixels, not outside by 1, as with rectangle bottmRight, eg. See the method Rectangle asQuad. WarpBlt does a fast job of rotation, reflection and scaling, and it can even produce a semblance of perspective. Depth parameters are included for future improvements in this direction. but the primitve does not support this yet.! !WarpBlt methodsFor: 'setup' stamp: 'jm 4/11/1999 12:00'! cellSize: s cellSize _ s. cellSize = 1 ifTrue: [^ self]. colorMap _ Color colorMapIfNeededFrom: 32 to: destForm depth. ! ! !WarpBlt methodsFor: 'primitives' stamp: 'LY 6/17/2003 15:33'! copyQuad: pts toRect: destRect cellSize ifNil: [^ self error: 'cellSize must not be nil!!']. self sourceQuad: pts destRect: destRect. self warpBits. ! ! !WarpBlt methodsFor: 'primitives' stamp: 'jm 5/2/1999 07:09'! sourceForm: srcForm destRect: dstRectangle "Set up a WarpBlt from the entire source Form to the given destination rectangle." | w h | sourceForm _ srcForm. sourceX _ sourceY _ 0. destX _ dstRectangle left. destY _ dstRectangle top. width _ dstRectangle width. height _ dstRectangle height. w _ 16384 * (srcForm width - 1). h _ 16384 * (srcForm height - 1). p1x _ 0. p2x _ 0. p3x _ w. p4x _ w. p1y _ 0. p2y _ h. p3y _ h. p4y _ 0. p1z _ p2z _ p3z _ p4z _ 16384. "z-warp ignored for now" ! ! !WarpBlt methodsFor: 'primitives' stamp: 'jm 4/11/1999 13:45'! warpBits "Move those pixels!!" self warpBitsSmoothing: cellSize sourceMap: (sourceForm colormapIfNeededForDepth: 32). ! ! !WarpBlt methodsFor: 'primitives' stamp: 'jm 5/29/2003 18:07'! warpBitsSmoothing: n sourceMap: sourceMap | deltaP12 deltaP43 pA pB deltaPAB sp fixedPtOne picker poker pix nSteps | <primitive: 147> "Check for compressed source, destination or halftone forms" ((sourceForm isKindOf: Form) and: [sourceForm unhibernate]) ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap]. ((destForm isKindOf: Form) and: [destForm unhibernate]) ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap]. ((halftoneForm isKindOf: Form) and: [halftoneForm unhibernate]) ifTrue: [^ self warpBitsSmoothing: n sourceMap: sourceMap]. (width < 1) | (height < 1) ifTrue: [^ self]. fixedPtOne _ 16384. "1.0 in fixed-pt representation" n > 1 ifTrue: [(destForm depth < 16 and: [colorMap == nil]) ifTrue: ["color map is required to smooth non-RGB dest" ^ self primitiveFail]. pix _ Array new: n*n]. nSteps _ height-1 max: 1. deltaP12 _ (self deltaFrom: p1x to: p2x nSteps: nSteps) @ (self deltaFrom: p1y to: p2y nSteps: nSteps). pA _ (self startFrom: p1x to: p2x offset: nSteps*deltaP12 x) @ (self startFrom: p1y to: p2y offset: nSteps*deltaP12 y). deltaP43 _ (self deltaFrom: p4x to: p3x nSteps: nSteps) @ (self deltaFrom: p4y to: p3y nSteps: nSteps). pB _ (self startFrom: p4x to: p3x offset: nSteps*deltaP43 x) @ (self startFrom: p4y to: p3y offset: nSteps*deltaP43 y). picker _ BitBlt bitPeekerFromForm: sourceForm. poker _ BitBlt bitPokerToForm: destForm. poker clipRect: self clipRect. nSteps _ width-1 max: 1. destY to: destY+height-1 do: [:y | deltaPAB _ (self deltaFrom: pA x to: pB x nSteps: nSteps) @ (self deltaFrom: pA y to: pB y nSteps: nSteps). sp _ (self startFrom: pA x to: pB x offset: nSteps*deltaPAB x) @ (self startFrom: pA y to: pB y offset: nSteps*deltaPAB x). destX to: destX+width-1 do: [:x | n = 1 ifTrue: [Transcript cr; print: sp // fixedPtOne asPoint. poker pixelAt: x@y put: (picker pixelAt: sp // fixedPtOne asPoint)] ifFalse: [0 to: n-1 do: [:dx | 0 to: n-1 do: [:dy | pix at: dx*n+dy+1 put: (picker pixelAt: sp + (deltaPAB*dx//n) + (deltaP12*dy//n) // fixedPtOne asPoint)]]. poker pixelAt: x@y put: (self mixPix: pix sourceMap: sourceMap destMap: colorMap)]. sp _ sp + deltaPAB]. pA _ pA + deltaP12. pB _ pB + deltaP43]! ! !WarpBlt class methodsFor: 'examples' stamp: 'jm 7/17/2003 22:53'! test1 "Display restoreAfter: [WarpBlt test1]" "Demonstrates variable scale and rotate" | warp pts r1 p0 p ext | Utilities informUser: 'Choose a rectangle with interesting stuff' during: [r1 _ Rectangle originFromUser: 50@50. Sensor waitNoButton]. Utilities informUser: 'Now click down and up and move the mouse around the dot' during: [p0 _ Sensor waitClickButton. (Form dotOfSize: 8) displayAt: p0]. warp _ (self toForm: Display) clipRect: (0@0 extent: r1 extent*5); sourceForm: Display; combinationRule: Form over. [Sensor anyButtonPressed] whileFalse: [p _ Sensor cursorPoint. pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight} collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center]. ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) truncated. warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext)]! ! !WarpBlt class methodsFor: 'examples' stamp: 'jm 7/17/2003 22:53'! test12 "Display restoreAfter: [WarpBlt test12]" "Just like test1, but comparing smooth to non-smooth warps" | warp pts r1 p0 p ext warp2 | Utilities informUser: 'Choose a rectangle with interesting stuff' during: [r1 _ Rectangle originFromUser: 50@50. Sensor waitNoButton]. Utilities informUser: 'Now click down and up and move the mouse around the dot' during: [p0 _ Sensor waitClickButton. (Form dotOfSize: 8) displayAt: p0]. warp _ (self toForm: Display) cellSize: 2; "installs a colormap" clipRect: (0@0 extent: r1 extent*5); sourceForm: Display; combinationRule: Form over. warp2 _ (self toForm: Display) clipRect: ((0@0 extent: r1 extent*5) translateBy: 250@0); sourceForm: Display; combinationRule: Form over. [Sensor anyButtonPressed] whileFalse: [p _ Sensor cursorPoint. pts _ {r1 topLeft. r1 bottomLeft. r1 bottomRight. r1 topRight} collect: [:pt | pt rotateBy: (p-p0) theta about: r1 center]. ext _ (r1 extent*((p-p0) r / 20.0 max: 0.1)) truncated. warp copyQuad: pts toRect: (r1 extent*5-ext//2 extent: ext). warp2 copyQuad: pts toRect: ((r1 extent*5-ext//2 extent: ext) translateBy: 250@0). ]! ! I am a Morphic clock or watch. My font can be changed and I can draw the clock face in either decimal or Roman numerals and I use an appropriate font for my current size. WatchMorph new openInWorld (WatchMorph fontName: 'ComicPlain') openInWorld " transparent " (WatchMorph fontName: 'ComicBold' bgColor: Color white centerColor: Color black) openInWorld Structure: fontName String -- the labels' font name cColor Color -- center color handsColor Color romanNumerals Boolean ! !WatchMorph methodsFor: 'initialization' stamp: 'jm 6/1/2003 05:32'! extent: newExtent super extent: newExtent. self createLabels. ! ! !WatchMorph methodsFor: 'initialization' stamp: 'jm 6/1/2003 05:39'! initialize super initialize. self color: Color green. self centerColor: Color gray. self handsColor: Color red. fontName _ 'NewYork'. romanNumerals _ false. self extent: 130@130. ! ! !WatchMorph methodsFor: 'accessing' stamp: 'jm 6/1/2003 05:44'! centerColor: aColor cColor _ aColor. self changed. ! ! !WatchMorph methodsFor: 'accessing' stamp: 'jm 6/1/2003 05:51'! fontName: aString fontName _ aString. self createLabels. ! ! !WatchMorph methodsFor: 'accessing' stamp: 'jm 6/1/2003 05:52'! handsColor: aColor handsColor _ aColor. self changed. ! ! !WatchMorph methodsFor: 'drawing' stamp: 'jm 6/1/2003 05:47'! drawOn: aCanvas | pHour pMin pSec time | time _ Time now. pHour _ self radius: 0.6 hourAngle: time hours + (time minutes / 60.0). pMin _ self radius: 0.72 hourAngle: (time minutes / 5.0). pSec _ self radius: 0.8 hourAngle: (time seconds / 5.0). time hours < 12 ifTrue: [self centerColor: Color veryLightGray] ifFalse: [self centerColor: Color darkGray]. super drawOn: aCanvas. aCanvas fillOval: (bounds insetBy: self extent*0.35) color: cColor; line: self center to: pHour width: 3 color: handsColor; line: self center to: pMin width: 2 color: handsColor; line: self center to: pSec width: 1 color: handsColor. ! ! !WatchMorph methodsFor: 'menus' stamp: 'jm 6/1/2003 05:47'! addCustomMenuItems: aCustomMenu hand: aHandMorph "Add morph-specific items to the given menu which was invoked by the given hand." super addCustomMenuItems: aCustomMenu hand: aHandMorph. aCustomMenu add: 'change font...' action: #changeFont. romanNumerals ifTrue: [aCustomMenu add: 'use latin numerals' action: #toggleRoman] ifFalse: [aCustomMenu add: 'use roman numerals' action: #toggleRoman]. aCustomMenu add: 'change hands color...' action: #changeHandsColor. ! ! !WatchMorph methodsFor: 'menus' stamp: 'jm 6/1/2003 05:50'! changeFont "Let the user change the font." | newFontName | newFontName _ (SelectionMenu labelList: StrikeFont familyNames selections: StrikeFont familyNames) startUp. newFontName ifNil: [^ self]. self fontName: newFontName. ! ! !WatchMorph methodsFor: 'menus' stamp: 'jm 6/1/2003 05:36'! changeHandsColor "Let the user change the color of the hands of the watch." ColorPickerMorph new sourceHand: self activeHand; target: self; selector: #handsColor:; originalColor: self color; addToWorld: self world near: self fullBounds. ! ! !WatchMorph methodsFor: 'menus' stamp: 'jm 6/1/2003 05:36'! toggleRoman romanNumerals _ romanNumerals not. self createLabels. ! ! !WatchMorph methodsFor: 'private' stamp: 'jm 6/1/2003 05:53'! createLabels "Add hour labels." | numeral font h r | self removeAllMorphs. font _ StrikeFont familyName: fontName size: (h _ self height min: self width) // 8. r _ 1.0 - (1.4 * font height / h). 1 to: 12 do: [:hour | numeral _ romanNumerals ifTrue: [hour romanString] ifFalse: [hour asString]. self addMorphBack: ((StringMorph contents: numeral font: font emphasis: 1) center: (self radius: r hourAngle: hour)) lock]. ! ! !WatchMorph methodsFor: 'private' stamp: 'jm 6/1/2003 05:35'! radius: unitRadius hourAngle: hourAngle "unitRadius goes from 0.0 at the center to 1.0 on the circumference. hourAngle runs from 0.0 clockwise around to 12.0 with wrapping." ^ self center + (self extent * (Point r: 0.5 * unitRadius degrees: hourAngle * 30.0 - 90.0)). ! ! !WatchMorph methodsFor: 'stepping' stamp: 'jm 6/1/2003 05:35'! step self changed. ! ! !WatchMorph class methodsFor: 'instance creation' stamp: 'jm 6/1/2003 05:55'! fontName: aString ^ self fontName: aString bgColor: nil centerColor: nil ! ! !WatchMorph class methodsFor: 'instance creation' stamp: 'jm 6/1/2003 05:54'! fontName: aString bgColor: aColor centerColor: otherColor ^ self new fontName: aString; color: aColor; centerColor: otherColor ! ! !WatchMorph class methodsFor: 'instance creation' stamp: 'jm 6/1/2003 05:55'! includeInNewMorphMenu ^ true ! ! This tool was created to aid in the preparation of LoopedSampledSound objects. It includes support for finding good loop points with a little help from the user. Namely, the user must identify a good ending point for the loop (typically just before the decay phase begins) and identify one cycle of the waveform. After that, the "choose loop point" menu command can be invoked to search backwards to find and rank all possible loop starting points. Some experimentation is usually required to find a loop that "breaths" in a natural way. This tool can also be used as a general viewer of numerical sequences of any kind, such as time-varying functions, FFT data, etc.! !WaveEditor methodsFor: 'initialization' stamp: 'jm 6/15/2003 20:32'! addControls | slider b r m | b _ SimpleButtonMorph new target: self; borderColor: Color black; useSquareCorners. 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: 'X'; actionSelector: #delete). r addMorphBack: (b fullCopy label: 'Menu'; actWhen: #buttonDown; actionSelector: #invokeMenu). r addMorphBack: (b fullCopy label: 'Play'; actionSelector: #play). r addMorphBack: (b fullCopy label: 'Play Before'; actionSelector: #playBeforeCursor). r addMorphBack: (b fullCopy label: 'Play After'; actionSelector: #playAfterCursor). r addMorphBack: (b fullCopy label: 'Play Loop'; actionSelector: #playLoop). r addMorphBack: (b fullCopy label: 'Test'; actionSelector: #playTestNote). r addMorphBack: (b fullCopy label: 'Save'; actionSelector: #saveInstrument). r addMorphBack: (b fullCopy label: 'Set Loop End'; actionSelector: #setLoopEnd). r addMorphBack: (b fullCopy label: 'One Cycle'; actionSelector: #setOneCycle). r addMorphBack: (b fullCopy label: 'Set Loop Start'; actionSelector: #setLoopStart). self addMorphBack: r. r _ AlignmentMorph newRow. r color: self color; borderWidth: 0; inset: 0. r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; centering: #center. m _ StringMorph new contents: 'Index: '. r addMorphBack: m. m _ UpdatingStringMorph new target: graph; getSelector: #cursor; putSelector: #cursor:; growable: false; width: 71; step. r addMorphBack: m. m _ StringMorph new contents: 'Value: '. r addMorphBack: m. m _ UpdatingStringMorph new target: graph; getSelector: #valueAtCursor; putSelector: #valueAtCursor:; growable: false; width: 50; step. r addMorphBack: m. slider _ SimpleSliderMorph new color: color; extent: 200@2; target: self; actionSelector: #scrollTime:. r addMorphBack: slider. m _ Morph new color: r color; extent: 10@5. "spacer" r addMorphBack: m. m _ UpdatingStringMorph new target: graph; getSelector: #startIndex; putSelector: #startIndex:; width: 40; step. r addMorphBack: m. self addMorphBack: r. ! ! !WaveEditor methodsFor: 'initialization' stamp: 'jm 8/17/1998 20:31'! addLoopPointControls | r m | r _ AlignmentMorph newRow. r color: self color; borderWidth: 0; inset: 0. r hResizing: #spaceFill; vResizing: #rigid; extent: 5@20; centering: #center. m _ StringMorph new contents: 'Loop end: '. r addMorphBack: m. m _ UpdatingStringMorph new target: self; getSelector: #loopEnd; putSelector: #loopEnd:; growable: false; width: 50; step. r addMorphBack: m. m _ StringMorph new contents: 'Loop length: '. r addMorphBack: m. m _ UpdatingStringMorph new target: self; getSelector: #loopLength; putSelector: #loopLength:; floatPrecision: 0.001; growable: false; width: 50; step. r addMorphBack: m. m _ StringMorph new contents: 'Loop cycles: '. r addMorphBack: m. m _ UpdatingStringMorph new target: self; getSelector: #loopCycles; putSelector: #loopCycles:; floatPrecision: 0.001; growable: false; width: 50; step. r addMorphBack: m. m _ StringMorph new contents: 'Frequency: '. r addMorphBack: m. m _ UpdatingStringMorph new target: self; getSelector: #perceivedFrequency; putSelector: #perceivedFrequency:; floatPrecision: 0.001; growable: false; width: 50; step. r addMorphBack: m. self addMorphBack: r. ! ! !WaveEditor methodsFor: 'initialization' stamp: 'jm 6/15/2003 20:08'! initialize super initialize. samplingRate _ SoundPlayer samplingRate. loopEnd _ loopLength _ 0. loopCycles _ 1. perceivedFrequency _ 0. "zero means unknown" self extent: 5@5; orientation: #vertical; centering: #topLeft; hResizing: #shrinkWrap; vResizing: #shrinkWrap; inset: 3; color: Color lightGray; borderWidth: 2. graph _ GraphMorph new extent: 450@200. graph cursor: 0. graph cursorColorAtZeroCrossings: Color blue. self addControls. self addLoopPointControls. self addMorphBack: graph. self addMorphBack: (Morph newBounds: (0@0 extent: 0@3) color: Color transparent). self addMorphBack: (keyboard _ PianoKeyboardMorph new). ! ! !WaveEditor methodsFor: 'menu' stamp: 'di 6/22/1999 08:46'! chooseLoopStart | bestLoops menu secs choice start | possibleLoopStarts ifNil: [ Utilities informUser: 'Finding possible loop points...' during: [possibleLoopStarts _ self findPossibleLoopStartsFrom: graph cursor]]. bestLoops _ possibleLoopStarts copyFrom: 1 to: (100 min: possibleLoopStarts size). menu _ CustomMenu new. bestLoops do: [:entry | secs _ ((loopEnd - entry first) asFloat / self samplingRate) roundTo: 0.01. menu add: entry third printString, ' cycles; ', secs printString, ' secs' action: entry]. choice _ menu startUp. choice ifNil: [^ self]. loopCycles _ choice at: 3. start _ self fractionalLoopStartAt: choice first. self loopLength: (loopEnd asFloat - start) + 1.0. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/15/2003 22:52'! deleteInstrument | sampledSoundNames menu soundToDelete | sampledSoundNames _ AbstractSound soundNames select: [:n | (AbstractSound soundNamed: n) isKindOf: LoopedSampledSound]. menu _ CustomMenu new title: 'Sound to delete:'. sampledSoundNames do: [:n | menu add: n action: n]. soundToDelete _ menu startUp. soundToDelete ifNotNil: [AbstractSound sounds removeKey: soundToDelete]. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/15/2003 22:12'! invokeMenu "Invoke a menu of additonal functions for this WaveEditor." | aMenu | aMenu _ CustomMenu new. aMenu addList: #( ('play all' play) ('play before cursor' playBeforeCursor) ('play after cursor' playAfterCursor) ('play test note' playTestNote) ('play loop' playLoop) - ('trim before cursor' trimBeforeCursor) ('trim after cursor' trimAfterCursor) - ('choose loop start' chooseLoopStart) ('jump to loop start' jumpToLoopStart) ('jump to loop end' jumpToLoopEnd) - ('make unlooped' setUnlooped) ('make unpitched' setUnpitched) - ('show envelope' showEnvelope) ('show FFT' showFFTAtCursor) - ('add to instrument library' saveInstrument) ('delete instrument' deleteInstrument) - ('save to file' saveToFile) ('read from file' readFromFile)). aMenu invokeOn: self defaultSelection: nil. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/3/1998 12:42'! jumpToLoopEnd graph cursor: loopEnd; centerCursor. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 10:09'! jumpToLoopStart graph cursor: (loopEnd - loopLength) truncated; centerCursor. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/21/1999 22:11'! makeLoopedSampledSound | data end snd basePitch | data _ graph data. ((loopEnd = 0) or: [loopLength = 0]) ifTrue: [ "save as unlooped" perceivedFrequency = 0 ifTrue: [basePitch _ 100.0] ifFalse: [basePitch _ perceivedFrequency]. snd _ LoopedSampledSound new unloopedSamples: data pitch: basePitch samplingRate: samplingRate] ifFalse: [ end _ (loopEnd min: data size) max: 1. basePitch _ (samplingRate * loopCycles) / loopLength. snd _ LoopedSampledSound new samples: data loopEnd: end loopLength: loopLength pitch: basePitch samplingRate: samplingRate]. snd addReleaseEnvelope. ^ snd ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 7/9/1998 09:23'! play graph data size < 2 ifTrue: [^ self]. (SampledSound samples: graph data samplingRate: samplingRate) play. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:40'! playAfterCursor self playFrom: graph cursor to: graph data size. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:39'! playBeforeCursor self playFrom: 1 to: graph cursor. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:02'! playFrom: start to: end | sz i1 i2 snd | sz _ graph data size. i1 _ ((start + 1) min: sz) max: 1. i2 _ ((end + 1) min: sz) max: i1. (i1 + 2) >= i2 ifTrue: [^ self]. snd _ SampledSound samples: (graph data copyFrom: i1 to: i2) samplingRate: samplingRate. snd play. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:39'! playLoop | sz i1 i2 snd len | sz _ graph data size. i1 _ ((loopEnd - loopLength) truncated min: sz) max: 1. i2 _ (loopEnd min: sz) max: i1. len _ (i2 - i1) + 1. len < 2 ifTrue: [^ self]. snd _ LoopedSampledSound new samples: (graph data copyFrom: i1 to: i2) loopEnd: len loopLength: loopLength pitch: 100.0 samplingRate: samplingRate. "sustain for the longer of four loops or two seconds" snd setPitch: 100.0 dur: (((4.0 * loopLength) / samplingRate) max: 2.0) loudness: 0.5. snd play. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/17/1998 11:38'! playTestNote | data end snd loopDur dur | (loopEnd = 0 or: [loopLength = 0]) ifTrue: [^ self]. data _ graph data. end _ (loopEnd min: data size) max: 1. snd _ LoopedSampledSound new samples: data loopEnd: end loopLength: loopLength pitch: 100.0 samplingRate: samplingRate. loopDur _ (4.0 * loopLength / samplingRate) max: 2.0. "longer of 4 loops or 2 seconds" dur _ (data size / samplingRate) + loopDur. (snd addReleaseEnvelope; setPitch: 100.0 dur: dur loudness: 0.5) play. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/15/2003 22:23'! readFromFile "Read my samples from an image file." | result fullName snd | result _ StandardFileMenu oldFile. result ifNil: [^ self]. fullName _ result directory pathName, FileDirectory slash, result name. (result name asLowercase endsWith: '.aif') ifTrue: [snd _ SampledSound fromAIFFfileNamed: fullName] ifFalse: [snd _ SampledSound fromWaveFileNamed: fullName]. samplingRate _ snd originalSamplingRate. graph data: snd samples. loopEnd _ loopLength _ 0. loopCycles _ 1. perceivedFrequency _ 0. "zero means unknown" ! ! !WaveEditor methodsFor: 'menu' stamp: 'di 6/21/1999 17:58'! saveInstrument | name | name _ FillInTheBlank request: 'Instrument name?'. name isEmpty ifTrue: [^ self]. AbstractSound soundNamed: name put: self makeLoopedSampledSound. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/23/2003 16:25'! saveToFile "Read my samples from an image file." | fileName samples f | fileName _ FillInTheBlank request: 'File name?'. fileName ifNil: [^ self]. (fileName asLowercase endsWith: '.aif') ifFalse: [fileName _ fileName, '.aif']. (graph data isKindOf: SoundBuffer) ifTrue: [samples _ graph data] ifFalse: [samples _ SoundBuffer fromArray: graph data]. f _ (FileStream newFileNamed: fileName) binary. (SampledSound samples: samples samplingRate: samplingRate) storeAIFFSamplesOn: f. f close. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 7/31/1998 11:06'! setLoopEnd graph cursor: (self zeroCrossingAfter: graph cursor) - 1. self loopEnd: graph cursor. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 7/9/1998 08:21'! setLoopStart "Assuming that the loop end and approximate frequency have been set, this method uses the current cursor position to determine the loop length and the number of cycles." | start len | start _ graph cursor. ((start >= loopEnd) or: [perceivedFrequency = 0]) ifTrue: [ ^ self inform: 'Please set the loop end and the approximate frequency first, then position the cursor one or more cycles before the loop end and try this again.']. len _ (loopEnd - start) + 1. loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded. self loopLength: len. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'! setOneCycle "Set the approximate frequency based on a single cycle specified by the user. To use this, first set the loop end, then place the cursor one full cycle before the loop end and invoke this method." | len | len _ loopEnd - graph cursor. len > 0 ifTrue: [ loopCycles _ 1. self loopLength: len]. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'! setUnlooped "Make this sound play straight through without looping." loopLength _ 0. loopCycles _ 1. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 8/1/1998 11:05'! setUnpitched "Make this instrument be unpitched and unlooped. Suitable for percussive sounds that should not be pitch-shifted when played. By convention, such sounds are played at a pitch of 100.0 to obtain their original pitch." loopLength _ 0. loopCycles _ 0. perceivedFrequency _ 100.0. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/15/2003 20:06'! showEnvelope "Show an envelope wave constructed by collecting the maximum absolute value of the samples in fixed-size time windows of mSecsPerQuantum." | data mSecsPerQuantum samplesPerQuantum result endOfQuantum maxThisQuantum s nSamples | data _ graph data. mSecsPerQuantum _ 8. samplesPerQuantum _ (mSecsPerQuantum / 1000.0) * self samplingRate. result _ WriteStream on: (Array new: data size // samplesPerQuantum). endOfQuantum _ samplesPerQuantum. maxThisQuantum _ 0. nSamples _ (data isKindOf: SoundBuffer) ifTrue: [data monoSampleCount] ifFalse: [data size]. 1 to: nSamples do: [:i | i asFloat > endOfQuantum ifTrue: [ result nextPut: maxThisQuantum. maxThisQuantum _ 0. endOfQuantum _ endOfQuantum + samplesPerQuantum]. s _ data at: i. s < 0 ifTrue: [s _ 0 - s]. s > maxThisQuantum ifTrue: [maxThisQuantum _ s]]. (SimpleWaveEditor openOn: result contents) hideKeyboard. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/15/2003 20:16'! showFFTAtCursor | data start availableSamples nu n fft r | data _ graph data. start _ graph cursor max: 1. availableSamples _ (data size - start) + 1. nu _ 12. nu > (availableSamples highBit - 1) ifTrue: [^ self inform: 'Too few samples after the cursor to take an FFT.']. n _ 2 raisedTo: nu. fft _ FFT new nu: nu. fft realData: ((start to: start + n - 1) collect: [:i | data at: i]). fft transformForward: true. r _ (1 to: n // 2) collect: [:i | ((fft realData at: i) squared + (fft imagData at: i) squared) sqrt]. (SimpleWaveEditor openOn: r) hideKeyboard. ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:48'! trimAfterCursor graph data: (graph data copyFrom: 1 to: graph cursor). ! ! !WaveEditor methodsFor: 'menu' stamp: 'jm 6/30/1998 17:52'! trimBeforeCursor graph data: (graph data copyFrom: graph cursor to: graph data size). graph cursor: 1. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/5/1998 12:43'! data: newData graph data: newData. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/3/2004 18:16'! graph ^ graph ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 09:48'! loopCycles ^ loopCycles ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 20:21'! loopCycles: aNumber loopCycles _ aNumber. self loopLength: loopLength. "updates frequency" ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 6/30/1998 17:20'! loopEnd ^ loopEnd ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/31/1998 14:01'! loopEnd: aNumber loopEnd _ (aNumber asInteger max: 1) min: graph data size. possibleLoopStarts _ nil. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/7/1998 08:38'! loopLength ^ loopLength ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/8/1998 21:03'! loopLength: aNumber loopLength _ aNumber. ((loopCycles > 0) and: [loopLength > 0]) ifTrue: [ perceivedFrequency _ samplingRate asFloat * loopCycles / loopLength]. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 10:08'! loopStart ^ (loopEnd - loopLength) truncated + 1 ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:46'! loopStart: index | start len | start _ self fractionalLoopStartAt: index. len _ (loopEnd asFloat - start) + 1.0. loopCycles _ (len / (samplingRate / perceivedFrequency)) rounded. self loopLength: len. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:31'! perceivedFrequency ^ perceivedFrequency ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 8/17/1998 20:32'! perceivedFrequency: aNumber perceivedFrequency _ aNumber. (loopCycles > 0) ifTrue: [ loopLength _ samplingRate asFloat * loopCycles / perceivedFrequency]. ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'! samplingRate ^ samplingRate ! ! !WaveEditor methodsFor: 'accessing' stamp: 'jm 7/4/1998 10:44'! samplingRate: samplesPerSecond samplingRate _ samplesPerSecond. ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 7/30/1998 18:51'! autoCorrolationBetween: index1 and: index2 length: length "Answer the cummulative error between the portions of my waveform starting at the given two indices and extending for the given length. The larger this error, the greater the difference between the two waveforms." | data error i1 e | data _ graph data. error _ 0. i1 _ index1. index2 to: (index2 + length - 1) do: [:i2 | e _ (data at: i1) - (data at: i2). e < 0 ifTrue: [e _ 0 - e]. error _ error + e. i1 _ i1 + 1]. ^ error ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 7/28/1998 02:29'! errorBetween: sampleArray1 and: sampleArray2 "Answer the cummulative error between the two sample arrays, which are assumed to be the same size." | error e | error _ 0. 1 to: sampleArray1 size do: [:i | e _ (sampleArray1 at: i) - (sampleArray2 at: i). e < 0 ifTrue: [e _ 0 - e]. error _ error + e]. ^ error ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 8/17/1998 11:25'! findPossibleLoopStartsFrom: index "Assume loopEnd is one sample before a zero-crossing." | r postLoopCycleStart i postLoopCycleLength cycleLength cycleCount err oldI | r _ OrderedCollection new. "Record the start and length of the first cycle after the loop endpoint." postLoopCycleStart _ loopEnd + 1. "Assumed to be a zero-crossing." i _ self zeroCrossingAfter: postLoopCycleStart + (0.9 * samplingRate / perceivedFrequency) asInteger. postLoopCycleLength _ i - loopEnd - 1. "Step backwards one cycle at a time, using zero-crossings to find the beginning of each cycle, and record the auto-corrolation error between each cycle and the cycle following the loop endpoint. Assume pitch may shift gradually." i _ self zeroCrossingAfter: postLoopCycleStart - (1.1 * postLoopCycleLength) asInteger. cycleLength _ postLoopCycleStart - i. cycleCount _ 1. [cycleLength > 0] whileTrue: [ err _ self autoCorrolationBetween: i and: postLoopCycleStart length: postLoopCycleLength. r add: (Array with: i with: err with: cycleCount with: (((loopEnd - i) asFloat / self samplingRate) roundTo: 0.01)). oldI _ i. i _ self zeroCrossingAfter: oldI - (1.1 * cycleLength) asInteger. cycleLength _ oldI - i. "will be zero when start of data is encountered" cycleCount _ cycleCount + 1]. r _ r asSortedCollection: [:e1 :e2 | (e1 at: 2) < (e2 at: 2)]. ^ r asArray ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 8/17/1998 11:27'! fractionalLoopStartAt: index "Answer the fractional index starting point near the given integral index that results in the closest match with the cycle following the loop end." "Note: could do this more efficiently by sliding downhill on the error curve to find lowest error." | oneCycle w1 minErr w2 err bestIndex | oneCycle _ (samplingRate / perceivedFrequency) rounded. w1 _ self interpolatedWindowAt: loopEnd + 1 width: oneCycle. minErr _ SmallInteger maxVal. ((index - 2) max: 1) to: ((index + 2) min: graph data size) by: 0.01 do: [:i | w2 _ self interpolatedWindowAt: i width: oneCycle. err _ self errorBetween: w1 and: w2. err < minErr ifTrue: [ bestIndex _ i. minErr _ err]]. ^ bestIndex ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 6/15/2003 20:06'! hideKeyboard keyboard delete. ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 7/31/1998 11:54'! interpolatedWindowAt: index width: nSamples "Return an array of N samples starting at the given index in my data." | scale data baseIndex scaledFrac scaledOneMinusFrac prevSample nextSample v | scale _ 10000. data _ graph data. index isInteger ifTrue: [^ (index to: index + nSamples - 1) collect: [:i | data at: i]]. baseIndex _ index truncated. scaledFrac _ ((index asFloat - baseIndex) * scale) truncated. scaledOneMinusFrac _ scale - scaledFrac. prevSample _ data at: baseIndex. ^ (baseIndex + 1 to: baseIndex + nSamples) collect: [:i | nextSample _ data at: i. v _ ((nextSample * scaledFrac) + (prevSample * scaledOneMinusFrac)) // scale. prevSample _ nextSample. v]. ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 9/19/1998 15:03'! normalize: sampleArray "Return a copy of the given sample array scaled to use the maximum 16-bit sample range. Remove any D.C. offset." | max abs scale out | max _ 0. sampleArray do: [:s | s > 0 ifTrue: [abs _ s] ifFalse: [abs _ 0 - s]. abs > max ifTrue: [max _ abs]]. scale _ ((1 << 15) - 1) asFloat / max. out _ sampleArray species new: sampleArray size. 1 to: sampleArray size do: [:i | out at: i put: (scale * (sampleArray at: i)) truncated]. ^ out ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 6/15/2003 20:15'! scrollTime: relativeValue graph startIndex: relativeValue * (graph data size - (graph width // 2)). graph changed. ! ! !WaveEditor methodsFor: 'other' stamp: 'di 6/21/1999 17:59'! step keyboard soundPrototype: self makeLoopedSampledSound! ! !WaveEditor methodsFor: 'other' stamp: 'jm 9/20/1998 09:13'! stretch: sampleArray by: stretchFactor "Return an array consisting of the given samples \stretched in time by the given factor." | out end incr i frac index | out _ OrderedCollection new: (stretchFactor * sampleArray size) asInteger + 1. end _ (sampleArray size - 1) asFloat. incr _ 1.0 / stretchFactor. i _ 1.0. [i < end] whileTrue: [ frac _ i fractionPart. index _ i truncated. i _ i + incr. out addLast: (((1.0 - frac) * (sampleArray at: index)) + (frac * (sampleArray at: index + 1))) rounded]. ^ out asArray ! ! !WaveEditor methodsFor: 'other' stamp: 'jm 8/10/1998 15:08'! zeroCrossingAfter: index "Find the index of the next negative-to-non-negative transition at or after the current index. The result is the index, i, of a zero crossing such that the sample at i-1 is negative and the sample at i is zero or positive. Answer the index of the last sample if the end of the array is encountered before finding a zero crossing." | data end i | data _ graph data. end _ data size. index <= 1 ifTrue: [^ 1]. i _ index - 1. [(i <= end) and: [(data at: i) >= 0]] whileTrue: [i _ i + 1]. "find next negative sample" i >= end ifTrue: [^ end]. i _ i + 1. [(i <= end) and: [(data at: i) < 0]] whileTrue: [i _ i + 1]. "find next non-negative sample" ^ i ! ! !WaveEditor class methodsFor: 'instance creation' stamp: 'jm 9/6/1999 11:21'! openOn: dataCollection "Open a new WaveEditor on the given sequencable collection of data." ^ (self new data: dataCollection) openInWorld ! ! WeakArray is an array which holds only weakly on its elements. This means whenever an object is only referenced by instances of WeakArray it will be garbage collected.! !WeakArray class methodsFor: 'class initialization' stamp: 'ar 10/7/1998 16:45'! initialize "WeakArray initialize" "Do we need to initialize specialObjectsArray?" Smalltalk specialObjectsArray size < 42 ifTrue:[Smalltalk recreateSpecialObjectsArray]. "Check if Finalization is supported by this VM" IsFinalizationSupported _ nil. self isFinalizationSupported ifFalse:[^self]. FinalizationProcess notNil ifTrue:[FinalizationProcess terminate]. FinalizationSemaphore := Smalltalk specialObjectsArray at: 42. FinalizationDependents isNil ifTrue:[ FinalizationDependents := WeakArray new: 10. ]. FinalizationLock := Semaphore forMutualExclusion. FinalizationProcess := [self finalizationProcess] newProcess. FinalizationProcess priority: Processor userInterruptPriority. FinalizationProcess resume.! ! !WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'! addWeakDependent: anObject | finished index weakDependent | self isFinalizationSupported ifFalse:[^self]. FinalizationLock critical:[ finished := false. index := 0. [index := index + 1. finished not and:[index <= FinalizationDependents size]] whileTrue:[ weakDependent := FinalizationDependents at: index. weakDependent isNil ifTrue:[ FinalizationDependents at: index put: anObject. finished := true. ]. ]. finished ifFalse:[ "Grow linearly" FinalizationDependents := FinalizationDependents, (WeakArray new: 10). FinalizationDependents at: index put: anObject. ]. ] ifError:[:msg :rcvr| rcvr error: msg].! ! !WeakArray class methodsFor: 'accessing' stamp: 'ar 10/7/1998 15:30'! isFinalizationSupported "Check if this VM supports the finalization mechanism" | tempObject | IsFinalizationSupported ifNotNil:[^IsFinalizationSupported]. tempObject _ WeakArray new: 1. "Check if the class format 4 is correctly understood by the VM. If the weak class support is not installed then the VM will report any weak class as containing 32bit words - not pointers" (tempObject at: 1) = nil ifFalse:[^IsFinalizationSupported _false]. "Check if objects are correctly freed" self pvtCreateTemporaryObjectIn: tempObject. Smalltalk garbageCollect. ^IsFinalizationSupported _ (tempObject at: 1) == nil! ! !WeakArray class methodsFor: 'accessing' stamp: 'ar 10/8/1998 11:17'! removeWeakDependent: anObject self isFinalizationSupported ifFalse:[^self]. FinalizationLock critical:[ 1 to: FinalizationDependents size do:[:i| ((FinalizationDependents at: i) == anObject) ifTrue:[ FinalizationDependents at: i put: nil. ]. ]. ] ifError:[:msg :rcvr| rcvr error: msg].! ! !WeakArray class methodsFor: 'private' stamp: 'ar 10/8/1998 11:19'! finalizationProcess [true] whileTrue:[ FinalizationSemaphore wait. FinalizationLock critical:[ FinalizationDependents do:[:weakDependent| weakDependent isNil ifFalse:[weakDependent finalizeValues]. ]. ] ifError:[:msg :rcvr| rcvr error: msg]. ].! ! !WeakArray class methodsFor: 'private' stamp: 'ar 10/7/1998 15:24'! pvtCreateTemporaryObjectIn: tempObject "We have to create the temporary object in a separate stack frame" tempObject at: 1 put: Object new! ! I am an association holding only weakly on my key.! !WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:45'! < aLookupKey "Refer to the comment in Magnitude|<." ^self key < aLookupKey key! ! !WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'! = aLookupKey self species = aLookupKey species ifTrue: [^self key = aLookupKey key] ifFalse: [^false]! ! !WeakKeyAssociation methodsFor: 'comparing' stamp: 'ar 3/21/98 15:46'! hash "Hash is reimplemented because = is implemented." ^self key hash! ! !WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'! printOn: aStream self key printOn: aStream. aStream nextPutAll: '->'. self value printOn: aStream! ! !WeakKeyAssociation methodsFor: 'printing' stamp: 'ar 3/21/98 15:53'! storeOn: aStream aStream nextPut: $(; nextPutAll: self class name; nextPutAll:' key: '. self key storeOn: aStream. aStream nextPutAll: ' value: '. self value storeOn: aStream. aStream nextPut: $)! ! !WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:54'! key ^key isNil ifTrue:[nil] ifFalse:[key at: 1]! ! !WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:45'! key: aKey key := WeakArray with: aKey! ! !WeakKeyAssociation methodsFor: 'accessing' stamp: 'ar 3/21/98 15:44'! key: aKey value: anObject key := WeakArray with: key. value := anObject.! ! I am a dictionary holding only weakly on my keys. This is a bit dangerous since at any time my keys can go away. Clients are responsible to register my instances by WeakArray such that the appropriate actions can be taken upon loss of any keys. See WeakRegistry for an example of use. ! !WeakKeyDictionary methodsFor: 'finalization' stamp: 'ar 3/21/98 16:15'! finalizeValues "default action is to re-hash the receiver and to remove nil-keys" self rehash. self removeKey: nil ifAbsent:[].! ! !WeakKeyDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:02'! 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 | key isNil ifTrue:[^anObject]. index _ self findElementOrNil: key. element _ array at: index. element == nil ifTrue: [self atNewIndex: index put: (WeakKeyAssociation key: key value: anObject)] ifFalse: [element value: anObject]. ^ anObject! ! !WeakKeyDictionary methodsFor: 'private' stamp: 'ar 3/22/98 00:21'! rehash "Overriden to copy the size also - we may have lost any number of elements" | newSelf | newSelf := self species new: self size. self associationsDo:[:each| newSelf noCheckAdd: each]. array := newSelf array. tally := newSelf size. ! ! !WeakKeyDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:00'! add: anAssociation self at: anAssociation key put: anAssociation value. ^ anAssociation! ! I am a registry for objects needing finalization. When an object is added the object as well as its executor is stored. When the object is garbage collected, the executor can take the appropriate action for any resources associated with the object. See also: Object executor Object actAsExecutor Object finalize ! !WeakRegistry methodsFor: 'finalization' stamp: 'ar 3/22/98 00:19'! finalizeValues "Some of our elements may have gone away. Look for those and activate the associated executors." | finiObjects | finiObjects := nil. "First collect the objects." self protected:[ valueDictionary associationsDo:[:assoc| assoc key isNil ifTrue:[ finiObjects isNil ifTrue:[finiObjects := OrderedCollection with: assoc value] ifFalse:[finiObjects add: assoc value]] ]. finiObjects isNil ifFalse:[valueDictionary finalizeValues]. ]. "Then do the finalization" finiObjects isNil ifTrue:[^self]. finiObjects do:[:each| each finalize]. ! ! !WeakRegistry methodsFor: 'adding' stamp: 'ar 3/21/98 16:33'! add: anObject "Add anObject to the receiver. Store the object as well as the associated executor." | executor | executor := anObject executor. self protected:[ valueDictionary at: anObject put: executor. ]. ^anObject! ! !WeakRegistry methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:40'! size ^ self protected: [valueDictionary size]! ! !WeakRegistry methodsFor: 'accessing' stamp: 'ar 3/20/98 19:31'! species ^Set! ! !WeakRegistry methodsFor: 'initialize' stamp: 'ar 3/21/98 16:08'! initialize: n valueDictionary := WeakKeyDictionary new: n. accessLock := Semaphore forMutualExclusion.! ! !WeakRegistry methodsFor: 'private' stamp: 'ar 10/8/1998 11:18'! protected: aBlock "Execute aBlock protected by the accessLock" ^accessLock isNil ifTrue:[aBlock value] ifFalse:[accessLock critical: aBlock ifError:[:msg :rcvr| rcvr error: msg]]! ! !WeakRegistry methodsFor: 'enumerating' stamp: 'ar 3/21/98 18:36'! do: aBlock ^self protected:[ valueDictionary keysDo: aBlock. ]. ! ! !WeakRegistry methodsFor: 'removing' stamp: 'ar 3/21/98 21:12'! remove: oldObject ifAbsent: exceptionBlock "Remove oldObject as one of the receiver's elements." | removedObject | oldObject isNil ifTrue:[^oldObject]. self protected:[ removedObject := valueDictionary removeKey: oldObject ifAbsent:[nil]. ]. ^removedObject isNil ifTrue:[exceptionBlock value] ifFalse:[removedObject]. ! ! !WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:32'! new ^self new: 5! ! !WeakRegistry class methodsFor: 'instance creation' stamp: 'ar 3/21/98 15:33'! new: n | registry | registry := super new initialize: n. WeakArray addWeakDependent: registry. ^registry! ! !WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:11'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key _ aKey. self value: anObject! ! !WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'! value ^self at: 1! ! !WeakValueAssociation methodsFor: 'accessing' stamp: 'r++ 5/27/2000 18:08'! value: anObject "Store the argument, anObject, as the value of the receiver." self at: 1 put: anObject! ! !WeakValueAssociation class methodsFor: 'instance creation' stamp: 'r++ 5/27/2000 18:07'! key: anObject value: bObject ^ self new key: anObject value: bObject! ! !WeakValueAssociation class methodsFor: 'as yet unclassified' stamp: 'r++ 5/27/2000 18:12'! new ^ self new: 1! ! I am a dictionary holding only weakly on my values. Clients may expect to get a nil value for any object they request.! !WeakValueDictionary methodsFor: 'adding' stamp: 'ar 3/21/98 16:02'! add: anAssociation self at: anAssociation key put: anAssociation value. ^ anAssociation! ! !WeakValueDictionary methodsFor: 'accessing' stamp: 'ar 3/21/98 16:01'! 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: (WeakValueAssociation key: key value: anObject)] ifFalse: [element value: anObject]. ^ anObject! ! Weeks begin in #Monday and end in #Sunday! !Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:13'! asDate "Answer the first day of the week." ^ Date newDay: self dayOfMonth month: self monthName year: self year! ! !Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:14'! next ^ self class fromDate: (self firstDate addDays: 7)! ! !Week methodsFor: 'converting' stamp: 'LC 7/26/1998 23:14'! previous ^ self class fromDate: (self firstDate subtractDays: 7)! ! !Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:14'! duration ^ 7! ! !Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 13:17'! firstDate ^ self asDate! ! !Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:17'! index ^ self indexInMonth: self firstDate month! ! !Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:16'! indexInMonth: aMonth "1=first week, 2=second week, etc." ^ (Date dayOfWeek: aMonth weekday) + self dayOfMonth - 2 // 7 + 1! ! !Week methodsFor: 'inquiries' stamp: 'LC 7/26/1998 23:17'! lastDate ^ self firstDate addDays: 6! ! !Week methodsFor: 'enumerating' stamp: 'LC 7/27/1998 04:08'! do: aBlock | date | date _ self asDate. 7 timesRepeat: [aBlock value: date. date _ date addDays: 1]! ! !Week methodsFor: 'printing' stamp: 'LC 7/28/1998 00:37'! printOn: aStream aStream nextPutAll: self month printString, ', ', (#('1st week' '2nd week' '3rd week' '4th week' '5th week' '6th week') at: self index)! ! !Week class methodsFor: 'instance creation' stamp: 'sge 5/19/2000 21:02'! fromDate: aDate | startDay | startDay _ aDate previous: (self startMonday ifTrue: [#Monday] ifFalse: [#Sunday]). ^ self newDay: startDay dayOfMonth month: startDay monthName year: startDay year! ! !Week class methodsFor: 'class variables' stamp: 'sge 5/18/2000 05:50'! startMonday StartMonday ifNil: [StartMonday _ true]. ^ StartMonday! ! !Week class methodsFor: 'class variables' stamp: 'sge 5/18/2000 06:24'! toggleStartMonday StartMonday _ self startMonday not! ! This subclass of PasteUpMorph provides special support for viewing of a world in an inner window (WorldWindow).! !WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/22/1999 09:51'! hostWindow: x hostWindow _ x. self canvas: nil. "safer to start from scratch" self viewBox: hostWindow panelRect. ! ! !WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/20/1999 15:11'! initialize super initialize. parentWorld _ World. ! ! !WiWPasteUpMorph methodsFor: 'initialization' stamp: 'RAA 11/21/1999 23:08'! viewBox: newViewBox | vb | self damageRecorder reset. "since we may have moved, old data no longer valid" ((vb _ self viewBox) == nil or: [vb ~= newViewBox]) ifTrue: [self canvas: nil]. worldState viewBox: newViewBox. bounds _ newViewBox. self assuredCanvas. "Paragraph problem workaround; clear selections to avoid screen droppings:" self handsDo: [:h | h newKeyboardFocus: nil]. self fullRepaintNeeded. ! ! !WiWPasteUpMorph methodsFor: 'activation' stamp: 'jm 10/5/2002 06:40'! becomeTheActiveWorldWith: evt World == self ifTrue: [^ self]. self damageRecorder reset. "since we may have moved, old data no longer valid" hostWindow setStripeColorsFrom: Color green. self canvas: nil. "safer to start from scratch" displayChangeSignatureOnEntry _ Display displayChangeSignature. World _ self. self viewBox: hostWindow panelRect. self startSteppingSubmorphsOf: self. self changed. pendingEvent _ nil. evt ifNotNil: [self primaryHand handleEvent: (evt setHand: self primaryHand)]. ! ! !WiWPasteUpMorph methodsFor: 'activation' stamp: 'jm 10/5/2002 06:41'! revertToParentWorldWithEvent: evt "RAA 27 Nov 99 - if the display changed while we were in charge, parent may need to redraw" self damageRecorder reset. "Terminate local display" World _ parentWorld. World assuredCanvas. hostWindow setStripeColorsFrom: Color red. (displayChangeSignatureOnEntry = Display displayChangeSignature) ifFalse: [World fullRepaintNeeded; displayWorld]. evt ifNotNil: [World restartWorldCycleWithEvent: evt]. ! ! !WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/14/1999 11:56'! doDeferredUpdating "If this platform supports deferred updates, then make my canvas be the Display (or a rectangular portion of it), set the Display to deferred update mode, and answer true. Otherwise, do nothing and answer false. One can set the class variable DisableDeferredUpdates to true to completely disable the deferred updating feature." DisableDeferredUpdates ifNil: [DisableDeferredUpdates _ false]. DisableDeferredUpdates ifTrue: [^ false]. (Display deferUpdates: true) ifNil: [^ false]. "deferred updates not supported" self resetViewBox. ^ true ! ! !WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/23/1999 09:01'! doOneCycle pendingEvent ifNotNil: [ self primaryHand handleEvent: (pendingEvent setHand: self primaryHand). pendingEvent _ nil. ]. ^super doOneCycle.! ! !WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/23/1999 09:06'! restartWorldCycleWithEvent: evt "redispatch that click in outer world" pendingEvent _ evt. Project current spawnNewProcessAndTerminateOld: true ! ! !WiWPasteUpMorph methodsFor: 'update cycle' stamp: 'RAA 11/25/1999 10:11'! runStepMethods "self == World ifFalse: [^ self]." "not sure why this was here, but MVC doesn't like it" super runStepMethods! ! !WiWPasteUpMorph methodsFor: 'drawing' stamp: 'ar 3/14/2000 16:07'! invalidRect: damageRect self == World ifTrue: [self damageRecorder ifNotNil: [self damageRecorder recordInvalidRect: damageRect]] ifFalse: [super invalidRect: (damageRect intersect: bounds)] ! ! !WiWPasteUpMorph methodsFor: 'drawing' stamp: 'jm 10/14/2002 07:49'! restoreDisplay "RAA 27 Nov 99 - we do not change our size just because the Display changed" self == World ifTrue: [ "otherwise, we're a morphic window in MVC and the restoreDisplay was, unusually, issued from that world's menu rather than from the MVC screen menu" DisplayScreen startUp]. self fullRepaintNeeded. ! ! !WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/14/1999 12:05'! extent: x super extent: x. self resetViewBox.! ! !WiWPasteUpMorph methodsFor: 'geometry' stamp: 'RAA 11/23/1999 11:11'! resetViewBox | c | (c _ self canvas) == nil ifTrue: [^self resetViewBoxForReal]. c form == Display ifFalse: [^self resetViewBoxForReal]. c origin = (0@0) ifFalse: [^self resetViewBoxForReal]. c clipRect extent = (self viewBox intersect: parentWorld viewBox) extent ifFalse: [^self resetViewBoxForReal]. ! ! !WiWPasteUpMorph methodsFor: 'geometry' stamp: 'ar 5/25/2000 18:02'! resetViewBoxForReal | newClip | self viewBox ifNil: [^self]. newClip _ self viewBox intersect: parentWorld viewBox. self canvas: ( (Display getCanvas) copyOffset: 0@0 clipRect: newClip )! ! !WiWPasteUpMorph methodsFor: 'events' stamp: 'di 11/26/1999 08:14'! mouseDown: evt (World == self or: [World isNil]) ifTrue: [^ super mouseDown: evt]. (self bounds containsPoint: evt cursorPoint) ifFalse: [^ self]. self becomeTheActiveWorldWith: evt. ! ! !WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'RAA 11/27/1999 15:30'! displayWorld "RAA 27 Nov 99 - if we are not active, then the parent should do the drawing" World == self ifTrue: [^super displayWorld]. parentWorld ifNotNil: [^parentWorld displayWorld]. ^super displayWorld "in case MVC needs it"! ! !WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'di 11/27/1999 10:27'! goBack PopUpMenu notify: 'Project changes are not yet allowed from inner worlds.'! ! !WiWPasteUpMorph methodsFor: 'as yet unclassified' stamp: 'di 11/27/1999 10:27'! jumpToProject PopUpMenu notify: 'Project changes are not yet allowed from inner worlds.'! ! My instances are used to transform objects from a source coordinate system to a destination coordinate system. Each instance contains a scale and a translation which can be applied to objects that respond to scaleBy: and translateBy:. It can be created with a default identity scale and translation, or with a specified scale and translation, or with a scale and translation computed from a window (a Rectangle in the source coordinate system) and a viewport (a Rectangle in the destination coordinate system). In applying a WindowingTransformation to an object, the object is first scaled (around the origin of the source coordinate system) and then translated. WindowingTransformations can be composed to form a single compound transformation.! WordArrays store 32-bit unsigned Integer values. ! !WordArray methodsFor: 'converting' stamp: 'ar 9/14/1998 23:46'! asWordArray ^self! ! !WordArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! atAllPut: value "Fill the receiver with the given value" <primitive: 145> super atAllPut: value! ! !WordArray methodsFor: 'accessing' stamp: 'tk 3/13/2000 14:46'! bytesPerElement "Number of bytes in each item. This multiplied by (self size)*8 gives the number of bits stored." ^ 4! ! !WordArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !WordArray methodsFor: 'private' stamp: 'ar 2/15/1999 00:51'! replaceFrom: start to: stop with: replacement startingAt: repStart <primitive: 105> ^super replaceFrom: start to: stop with: replacement startingAt: repStart ! ! !WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/24/2000 22:34'! restoreEndianness "This word object was just read in from a stream. It was stored in Big Endian (Mac) format. Reverse the byte order if the current machine is Little Endian." Smalltalk endianness == #little ifTrue: [ self swapBytesFrom: 1 to: self size] ! ! !WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/22/2000 12:04'! 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. ! ! !WordArray methodsFor: 'fileIn/Out' stamp: 'tk 1/25/2000 18:16'! writeOn: aStream | reversed convertToBytes | "Store the array of bits onto the argument, aStream. (leading byte ~= 16r80) identifies this as raw bits (uncompressed). Always store in Big Endian (Mac) byte order. Do the writing at BitBlt speeds." convertToBytes _ aStream originalContents "collection" class isBytes. (aStream isKindOf: FileStream) ifTrue: [convertToBytes _ false]. "knows how" Smalltalk endianness == #big ifTrue: ["no change" aStream nextInt32Put: self size. convertToBytes ifTrue: [self do: [:vv | aStream nextNumber: 4 put: vv]] "Later define (aStream nextPutWordsAll:) that uses BitBlt to put words on a byteStream quickly" ifFalse: [aStream nextPutAll: self]] ifFalse: [ reversed _ self clone. reversed swapBytesFrom: 1 to: reversed size. aStream nextInt32Put: reversed size. convertToBytes ifTrue: [reversed do: [:vv | aStream nextNumber: 4 put: vv]] ifFalse: [aStream nextPutAll: reversed]] ! ! !WordArray class methodsFor: 'as yet unclassified' stamp: 'ar 12/23/1999 14:34'! newFromStream: s | len | s next = 16r80 ifTrue: ["A compressed format. Could copy what BitMap does, or use a special sound compression format. Callers normally compress their own way." ^ self error: 'not implemented']. s skip: -1. len _ s nextInt32. ^ s nextWordsInto: (self new: len)! ! !Workspace methodsFor: 'binding' stamp: 'jm 7/12/2003 15:25'! bindings ^ bindings ! ! !Workspace methodsFor: 'accessing' stamp: 'jsp 3/23/1999 12:19'! setBindings: aDictionary "Sets the Workspace to use the specified dictionary as its namespace" bindings _ aDictionary. ! ! !Workspace methodsFor: 'as yet unclassified' stamp: 'sw 10/6/1999 15:17'! addModelItemsToWindowMenu: aMenu aMenu addLine. aMenu add: 'save contents to file...' target: self action: #saveContentsInFile ! ! !Workspace methodsFor: 'as yet unclassified' stamp: 'dew 3/9/2000 00:13'! saveContentsInFile "A bit of a hack to pass along this message to the controller or morph. (Possibly this Workspace menu item could be deleted, since it's now in the text menu.)" | textMorph textView | textMorph _ self dependents detect: [:dep | dep isKindOf: PluggableTextMorph] ifNone: [nil]. textMorph notNil ifTrue: [^ textMorph saveContentsInFile]. textView _ self dependents detect: [:dep | dep isKindOf: PluggableTextView] ifNone: [nil]. textView notNil ifTrue: [^ textView controller saveContentsInFile]. ! ! I hold the state for a Morphic world. ! !WorldState methodsFor: 'initialization' stamp: 'jm 10/4/2002 18:26'! initialize hands _ #(). activeHand _ viewBox _ canvas _ nil. damageRecorder _ DamageRecorder new. stepList _ OrderedCollection new. lastStepTime _ lastCycleTime _ 0. ! ! !WorldState methodsFor: 'update cycle' stamp: 'di 6/7/1999 17:47'! lastCycleTime ^ lastCycleTime! ! !WorldState methodsFor: 'update cycle' stamp: 'di 6/7/1999 17:52'! lastCycleTime: x lastCycleTime _ x! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/10/1999 23:06'! adjustWakeupTimes "Fix the wakeup times in my step list. This is necessary when this world has been restarted after a pause, say because some other view had control, after a snapshot, or because the millisecond clock has wrapped around. (The latter is a rare occurence with a 32-bit clock!!)" | earliestTime t now m oldWakeupTime | "find earliest wakeup time" earliestTime _ SmallInteger maxVal. stepList do: [:entry | t _ entry at: 2. t < earliestTime ifTrue: [earliestTime _ t]]. "recompute all wakeup times, using earliestTime as the origin" now _ Time millisecondClockValue. stepList do: [:entry | m _ entry at: 1. oldWakeupTime _ entry at: 2. entry at: 2 put: now + ((oldWakeupTime - earliestTime) min: m stepTime)]. lastStepTime _ now. ! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/10/1999 23:06'! adjustWakeupTimesIfNecessary "Fix the wakeup times in my step list if necessary. This is needed after a snapshot, after a long pause (say because some other view had control or because the user was selecting from an MVC-style menu) or when the millisecond clock wraps around (a very rare occurence with a 32-bit clock!!)." | now | now _ Time millisecondClockValue. ((now < lastStepTime) or: [(now - lastStepTime) > 5000]) ifTrue: [self adjustWakeupTimes]. "clock slipped" ! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/10/1999 22:14'! isStepping: aMorph "Return true if the given morph is in the step list." stepList do: [:entry | entry first == aMorph ifTrue: [^ true]]. "already stepping" ^ false! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/7/1999 17:47'! lastStepTime ^ lastStepTime! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/7/1999 17:52'! lastStepTime: x lastStepTime _ x! ! !WorldState methodsFor: 'stepping' stamp: 'sw 10/20/1999 14:50'! runStepMethodsIn: aWorld "Run morph 'step' methods whose time has come. Purge any morphs that are no longer in this world. ar 3/13/1999: Remove buggy morphs from the step list so that they don't raise repeated errors." | now deletions wakeupTime morphToStep | stepList size = 0 ifTrue: [^ self]. now _ Time millisecondClockValue. ((now < lastStepTime) or: [(now - lastStepTime) > 5000]) ifTrue: [self adjustWakeupTimes]. "clock slipped" deletions _ nil. "Note: Put the following into an error handler to prevent errors happening on stepping" [stepList do: [:entry | wakeupTime _ entry at: 2. morphToStep _ entry at: 1. morphToStep world == aWorld ifTrue: [wakeupTime <= now ifTrue: [morphToStep stepAt: now. entry at: 2 put: now + morphToStep stepTime]] ifFalse: [deletions ifNil: [deletions _ OrderedCollection new]. deletions addLast: morphToStep]]] ifError: [:err :rcvr | self stopStepping: morphToStep. "Stop this guy right now" morphToStep setProperty: #errorOnStep toValue: true. "Remember stepping" Processor activeProcess errorHandler: nil. "So we don't handle this guy twice" rcvr error: err. "And re-raise the error from here so the stack is still valid"]. deletions ifNotNil: [deletions do: [:deletedM | self stopStepping: deletedM. deletedM stopStepping]]. lastStepTime _ now! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/10/1999 22:10'! startStepping: aMorph "Add the given morph to the step list. Do nothing if it is already being stepped." stepList do: [:entry | entry first = aMorph ifTrue: [^ self]]. "already stepping" self adjustWakeupTimesIfNecessary. stepList add: (Array with: aMorph with: Time millisecondClockValue). ! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/7/1999 17:47'! stepList ^ stepList! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/7/1999 17:52'! stepList: x stepList _ x! ! !WorldState methodsFor: 'stepping' stamp: 'di 6/10/1999 22:15'! stopStepping: aMorph "Remove the given morph from the step list." stepList copy do: [:entry | entry first == aMorph ifTrue: [stepList remove: entry ifAbsent: []]]. ! ! !WorldState methodsFor: 'canvas' stamp: 'jm 11/24/2002 19:04'! assuredCanvas (canvas isNil or: [(canvas extent ~= viewBox extent) or: [canvas form depth ~= Display depth]]) ifTrue: [ "allocate a new offscreen canvas the size of the window" self canvas: (FormCanvas extent: viewBox extent)]. ^ self canvas ! ! !WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! canvas ^ canvas! ! !WorldState methodsFor: 'canvas' stamp: 'di 7/19/1999 16:45'! canvas: x canvas _ x. damageRecorder == nil ifTrue: [damageRecorder _ DamageRecorder new] ifFalse: [damageRecorder doFullRepaint]! ! !WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:45'! damageRecorder ^ damageRecorder! ! !WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:44'! viewBox ^ viewBox! ! !WorldState methodsFor: 'canvas' stamp: 'di 6/7/1999 17:58'! viewBox: x viewBox _ x! ! !WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:42'! activeHand ^ activeHand! ! !WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:50'! activeHand: x activeHand _ x! ! !WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:40'! hands ^ hands! ! !WorldState methodsFor: 'hands' stamp: 'di 6/7/1999 17:51'! hands: x hands _ x! ! !WorldState methodsFor: 'remote server' stamp: 'jm 11/24/2002 19:02'! remoteServer ^ remoteServer ! ! !WorldState methodsFor: 'remote server' stamp: 'jm 11/24/2002 19:02'! remoteServer: aNebraskaServerOrNil remoteServer ifNotNil: [remoteServer destroy]. remoteServer _ aNebraskaServerOrNil. ! ! Serves as a model for a WorldView -- a morphic world viewed within an mvc project.! !WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:50'! fullScreenSize "Answer the size to which a window displaying the receiver should be set" ^ (0@0 extent: DisplayScreen actualScreenSize) copy! ! !WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:51'! initialExtent initialExtent ifNotNil: [^ initialExtent]. ^ super initialExtent! ! !WorldViewModel methodsFor: 'as yet unclassified' stamp: 'sw 9/21/1998 17:51'! initialExtent: anExtent initialExtent _ anExtent! ! I represent an accessor for a sequence of objects that can only store objects in the sequence.! !WriteStream methodsFor: 'accessing' stamp: 'di 3/8/1999 09:02'! nextPut: anObject "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." <primitive: 66> position >= writeLimit ifTrue: [^ self pastEndPut: anObject] ifFalse: [position _ position + 1. ^collection at: position put: anObject]! ! !WriteStream methodsFor: 'accessing' stamp: 'ls 8/20/1998 10:19'! nextPutAll: aCollection | newEnd | collection class == aCollection class ifFalse: [ ^super nextPutAll: aCollection ]. newEnd _ position + aCollection size. newEnd > writeLimit ifTrue: [ collection _ collection, (collection species new: (newEnd - writeLimit + (collection size max: 20)) ). writeLimit _ collection size ]. collection replaceFrom: position+1 to: newEnd with: aCollection. position _ newEnd.! ! !WriteStream methodsFor: 'positioning' stamp: 'ar 11/12/1998 21:27'! resetToStart readLimit _ position _ 0.! ! !WriteStream methodsFor: 'character writing' stamp: 'sr 4/8/2000 01:49'! tab: anInteger "Append anInteger tab characters to the receiver." anInteger timesRepeat: [self nextPut: Character tab]! ! !WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:55'! braceArray "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ collection! ! !WriteStream methodsFor: 'private' stamp: 'di 11/18/1999 22:50'! braceArray: anArray "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." collection _ anArray. position _ 0. readLimit _ 0. writeLimit _ anArray size.! ! !WriteStream methodsFor: 'private' stamp: 'djp 11/6/1999 23:15'! withAttributes: attributes do: strmBlock "No-op here is overriden in TextStream for font emphasis" ^ strmBlock value! ! !ZLibReadStream methodsFor: 'initialize' stamp: 'ar 12/27/1999 15:38'! on: aCollection from: firstIndex to: lastIndex "Check the header of the ZLib stream." | method byte | super on: aCollection from: firstIndex to: lastIndex. method _ self nextBits: 8. (method bitAnd: 15) = 8 ifFalse:[^self error:'Unknown compression method']. (method bitShift: -4) + 8 > 15 ifTrue:[^self error:'Invalid window size']. byte _ self nextBits: 8. (method bitShift: 8) + byte \\ 31 = 0 ifFalse:[^self error:'Incorrect header']. (byte anyMask: 32) ifTrue:[^self error:'Need preset dictionary']. ! ! !ZLibWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/27/1999 15:48'! on: aCollection super on: aCollection. encoder nextBits: 8 put: 120. "deflate method with 15bit window size" encoder nextBits: 8 put: 1. "check sum; no preset dictionary" ! ! !ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:38'! close self flush. (encodedStream respondsTo: #close) ifTrue:[encodedStream close].! ! !ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'! commit encodedStream next: position putAll: collection. position _ readLimit _ 0.! ! !ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 15:51'! flush self flushBits. self commit.! ! !ZipEncoder methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 16:35'! flushBits "Flush currently unsent bits" [bitPosition > 0] whileTrue:[ self nextBytePut: (bitBuffer bitAnd: 255). bitBuffer _ bitBuffer bitShift: -8. bitPosition _ bitPosition - 8]. bitPosition _ 0.! ! !ZipEncoder methodsFor: 'initialize-release' stamp: 'jm 6/6/2003 07:39'! on: aCollectionOrStream (aCollectionOrStream isKindOf: Stream) ifTrue: [encodedStream _ aCollectionOrStream] ifFalse: [encodedStream _ WriteStream on: aCollectionOrStream]. encodedStream isBinary ifTrue: [super on: (ByteArray new: 4096)] ifFalse: [super on: (String new: 4096)]. bitPosition _ bitBuffer _ 0. ! ! !ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:45'! bitPosition ^encodedStream position + position * 8 + bitPosition.! ! !ZipEncoder methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! encodedStream ^encodedStream! ! !ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! nextBits: nBits put: value "Store a value of nBits" "self assert:[value >= 0 and:[(1 bitShift: nBits) > value]]." bitBuffer _ bitBuffer bitOr: (value bitShift: bitPosition). bitPosition _ bitPosition + nBits. [bitPosition >= 8] whileTrue:[ self nextBytePut: (bitBuffer bitAnd: 255). bitBuffer _ bitBuffer bitShift: -8. bitPosition _ bitPosition - 8].! ! !ZipEncoder methodsFor: 'accessing' stamp: 'ar 1/2/2000 16:34'! nextBytePut: anObject "Primitive. Insert the argument at the next position in the Stream represented by the receiver. Fail if the collection of this stream is not an Array or a String. Fail if the stream is positioned at its end, or if the position is out of bounds in the collection. Fail if the argument is not of the right type for the collection. Optional. See Object documentation whatIsAPrimitive." <primitive: 66> position >= writeLimit ifTrue: [^ self pastEndPut: anObject] ifFalse: [position _ position + 1. ^collection byteAt: position put: anObject]! ! !ZipEncoder methodsFor: 'block encoding' stamp: 'ar 12/30/1999 18:39'! sendBlock: literalStream with: distanceStream with: litTree with: distTree "Send the current block using the encodings from the given literal/length and distance tree" | result | result _ 0. [literalStream atEnd] whileFalse:[ result _ result + (self privateSendBlock: literalStream with: distanceStream with: litTree with: distTree). self commit. ]. self nextBits: (litTree bitLengthAt: EndBlock) put: (litTree codeAt: EndBlock). ^result! ! !ZipEncoder methodsFor: 'private' stamp: 'ar 1/2/2000 16:38'! pastEndPut: anObject "Flush the current buffer and store the new object at the beginning" self commit. ^self nextBytePut: anObject asInteger! ! !ZipEncoder methodsFor: 'private' stamp: 'ar 12/30/1999 18:38'! privateSendBlock: literalStream with: distanceStream with: litTree with: distTree "Send the current block using the encodings from the given literal/length and distance tree" | lit dist code extra sum | <primitive:'primitiveZipSendBlock'> sum _ 0. [lit _ literalStream next. dist _ distanceStream next. lit == nil] whileFalse:[ dist = 0 ifTrue:["lit is a literal" sum _ sum + 1. self nextBits: (litTree bitLengthAt: lit) put: (litTree codeAt: lit). ] ifFalse:["lit is match length" sum _ sum + lit + MinMatch. code _ (MatchLengthCodes at: lit + 1). self nextBits: (litTree bitLengthAt: code) put: (litTree codeAt: code). extra _ ExtraLengthBits at: code-NumLiterals. extra = 0 ifFalse:[ lit _ lit - (BaseLength at: code-NumLiterals). self nextBits: extra put: lit. ]. dist _ dist - 1. dist < 256 ifTrue:[code _ DistanceCodes at: dist + 1] ifFalse:[code _ DistanceCodes at: 257 + (dist bitShift: -7)]. "self assert:[code < MaxDistCodes]." self nextBits: (distTree bitLengthAt: code) put: (distTree codeAt: code). extra _ ExtraDistanceBits at: code+1. extra = 0 ifFalse:[ dist _ dist - (BaseDistance at: code+1). self nextBits: extra put: dist. ]. ]. ]. ^sum! ! ZipEncoderNode represents a node in a huffman tree for encoding ZipStreams. Instance variables: value <Integer> - Encoded value frequency <Integer> - Number of occurences of the encoded value height <Integer> - Height of the node in the tree bitLength <Integer> - bit length of the code code <Integer> - Assigned code for this node parent <ZipEncoderNode> - Parent of this node left <ZipEncoderNode> - First child of this node right <ZipEncoderNode> - Second child of this node ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 19:41'! bitLength ^bitLength ifNil:[0]! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/30/1999 14:28'! code ^code ifNil:[0]! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:51'! code: aCode self assert:[aCode >= 0 and:[(1 bitShift: bitLength) > aCode]]. code _ aCode.! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:36'! frequency ^frequency! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/28/1999 00:56'! frequency: aNumber frequency _ aNumber! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/26/1999 10:44'! height ^height! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! left ^left! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! left: aNode aNode parent: self. left _ aNode.! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! parent ^parent! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! parent: aNode parent _ aNode! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! right ^right! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/25/1999 20:06'! right: aNode aNode parent: self. right _ aNode.! ! !ZipEncoderNode methodsFor: 'accessing' stamp: 'ar 12/24/1999 23:43'! value ^value! ! !ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/26/1999 11:49'! encodeBitLength: blCounts from: aTree | index | "Note: If bitLength is not nil then the tree must be broken" bitLength == nil ifFalse:[self error:'Huffman tree is broken']. parent = nil ifTrue:[bitLength _ 0] ifFalse:[bitLength _ parent bitLength + 1]. self isLeaf ifTrue:[ index _ bitLength + 1. blCounts at: index put: (blCounts at: index) + 1. ] ifFalse:[ left encodeBitLength: blCounts from: aTree. right encodeBitLength: blCounts from: aTree. ].! ! !ZipEncoderNode methodsFor: 'encoding' stamp: 'ar 12/27/1999 14:27'! rotateToHeight: maxHeight "Rotate the tree to achieve maxHeight depth" | newParent | height < 4 ifTrue:[^self]. self left: (left rotateToHeight: maxHeight-1). self right: (right rotateToHeight: maxHeight-1). height _ (left height max: right height) + 1. height <= maxHeight ifTrue:[^self]. (left height - right height) abs <= 2 ifTrue:[^self]. left height < right height ifTrue:[ right right height >= right left height ifTrue:[ newParent _ right. self right: newParent left. newParent left: self. ] ifFalse:[ newParent _ right left. right left: newParent right. newParent right: right. self right: newParent left. newParent left: self. ]. ] ifFalse:[ left left height >= left right height ifTrue:[ newParent _ left. self left: newParent right. newParent right: self. ] ifFalse:[ newParent _ left right. left right: newParent left. newParent left: left. self left: newParent right. newParent right: self. ]. ]. parent computeHeight. ^parent! ! !ZipEncoderNode methodsFor: 'testing' stamp: 'ar 12/24/1999 23:17'! isLeaf ^left == nil! ! !ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:45'! computeHeight ^self isLeaf ifTrue:[height _ 0] ifFalse:[height _ (left computeHeight max: right computeHeight) + 1].! ! !ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/25/1999 18:14'! leafNodes self isLeaf ifTrue:[^Array with: self] ifFalse:[^left leafNodes, right leafNodes]! ! !ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 12:05'! setBitLengthTo: bl bitLength _ bl! ! !ZipEncoderNode methodsFor: 'private' stamp: 'ar 12/26/1999 10:46'! setValue: v frequency: f height: h value _ v. frequency _ f. height _ h.! ! !ZipEncoderNode methodsFor: 'printing' stamp: 'ar 12/26/1999 10:46'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll:'value = '; print: value; nextPutAll:', freq = '; print: frequency; nextPutAll:', bitLength = '; print: bitLength; nextPutAll:', code = '; print: code; nextPutAll:', height = '; print: height; nextPut:$).! ! !ZipEncoderNode class methodsFor: 'instance creation' stamp: 'ar 12/26/1999 10:47'! value: v frequency: f height: h ^self new setValue: v frequency: f height: h! ! ZipEncoderTree represents a huffman tree for encoding ZipStreams. Instance variables: bitLengths <WordArray> - Bit lengths of each generated code codes <WordArray> - Codes for each value maxCode <Integer> - Maximum value with non-zero frequency! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:43'! bitLengthAt: index ^bitLengths at: index+1! ! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:32'! bitLengths "Return an array of all bitLength values for valid codes" ^bitLengths! ! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:04'! codeAt: index ^codes at: index+1! ! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/30/1999 01:24'! codes "Return an array of all valid codes" ^codes! ! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 17:15'! maxCode ^maxCode! ! !ZipEncoderTree methodsFor: 'accessing' stamp: 'ar 12/25/1999 21:45'! maxCode: aNumber maxCode _ aNumber.! ! !ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:34'! buildCodes: nodeList counts: blCounts maxDepth: depth "Build the codes for all nodes" | nextCode code node length | nextCode _ WordArray new: depth+1. code _ 0. 1 to: depth do:[:bits| code _ (code + (blCounts at: bits)) << 1. nextCode at: bits+1 put: code]. self assert:[(code + (blCounts at: depth+1) - 1) = (1 << depth - 1)]. 0 to: maxCode do:[:n| node _ nodeList at: n+1. length _ node bitLength. length = 0 ifFalse:[ code _ nextCode at: length+1. node code: (self reverseBits: code length: length). nextCode at: length+1 put: code+1. ]. ].! ! !ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! buildHierarchyFrom: aHeap "Build the node hierarchy based on the leafs in aHeap" | left right parent | [aHeap size > 1] whileTrue:[ left _ aHeap removeFirst. right _ aHeap removeFirst. parent _ ZipEncoderNode value: -1 frequency: (left frequency + right frequency) height: (left height max: right height) + 1. left parent: parent. right parent: parent. parent left: left. parent right: right. aHeap add: parent]. ^aHeap removeFirst ! ! !ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 14:19'! buildTree: nodeList maxDepth: depth "Build either the literal or the distance tree" | heap rootNode blCounts | heap _ Heap new: nodeList size // 3. heap sortBlock: self nodeSortBlock. "Find all nodes with non-zero frequency and add to heap" maxCode _ 0. nodeList do:[:dNode| dNode frequency = 0 ifFalse:[ maxCode _ dNode value. heap add: dNode]]. "The pkzip format requires that at least one distance code exists, and that at least one bit should be sent even if there is only one possible code. So to avoid special checks later on we force at least two codes of non zero frequency." heap size = 0 ifTrue:[ self assert:[maxCode = 0]. heap add: nodeList first. heap add: nodeList second. maxCode _ 1]. heap size = 1 ifTrue:[ nodeList first frequency = 0 ifTrue:[heap add: nodeList first] ifFalse:[heap add: nodeList second]. maxCode _ maxCode max: 1]. rootNode _ self buildHierarchyFrom: heap. rootNode height > depth ifTrue:[ rootNode _ rootNode rotateToHeight: depth. rootNode height > depth ifTrue:[self error:'Cannot encode tree']]. blCounts _ WordArray new: depth+1. rootNode encodeBitLength: blCounts from: self. self buildCodes: nodeList counts: blCounts maxDepth: depth. self setValuesFrom: nodeList.! ! !ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/30/1999 01:24'! buildTreeFrom: frequencies maxDepth: depth "Build the receiver from the given frequency values" | nodeList | nodeList _ Array new: frequencies size. 1 to: frequencies size do:[:i| nodeList at: i put: (ZipEncoderNode value: i-1 frequency: (frequencies at: i) height: 0) ]. self buildTree: nodeList maxDepth: depth.! ! !ZipEncoderTree methodsFor: 'encoding' stamp: 'ar 12/26/1999 10:42'! nodeSortBlock ^[:n1 :n2| n1 frequency = n2 frequency ifTrue:[n1 height <= n2 height] ifFalse:[n1 frequency <= n2 frequency]].! ! !ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/30/1999 14:26'! bitLengths: blArray codes: codeArray bitLengths _ blArray as: WordArray. codes _ codeArray as: WordArray. self assert:[(self bitLengthAt: maxCode) > 0].! ! !ZipEncoderTree methodsFor: 'private' stamp: 'ar 12/26/1999 11:02'! reverseBits: code length: length "Bit reverse the given code" | result bit bits | result _ 0. bits _ code. 1 to: length do:[:i| bit _ bits bitAnd: 1. result _ result << 1 bitOr: bit. bits _ bits >> 1]. ^result! ! !ZipEncoderTree methodsFor: 'private' stamp: 'sma 6/1/2000 11:52'! setValuesFrom: nodeList self bitLengths: (nodeList collect: [:n | n bitLength] from: 1 to: maxCode + 1) codes: (nodeList collect: [:n | n code] from: 1 to: maxCode + 1)! ! !ZipEncoderTree class methodsFor: 'instance creation' stamp: 'ar 12/30/1999 01:25'! buildTreeFrom: frequencies maxDepth: depth ^self new buildTreeFrom: frequencies maxDepth: depth! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:38'! close self deflateBlock. self flushBlock: true. encoder close.! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:40'! initialize super initialize. literals _ ByteArray new: WindowSize. distances _ WordArray new: WindowSize. literalFreq _ WordArray new: MaxLiteralCodes. distanceFreq _ WordArray new: MaxDistCodes. self initializeNewBlock. ! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/29/1999 18:29'! initializeNewBlock "Initialize the encoder for a new block of data" literalFreq atAllPut: 0. distanceFreq atAllPut: 0. literalFreq at: EndBlock+1 put: 1. litCount _ 0. matchCount _ 0.! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 1/2/2000 17:23'! on: aCollectionOrStream encoder _ ZipEncoder on: aCollectionOrStream. encoder isBinary ifTrue:[super on: ByteArray new] ifFalse:[super on: String new]! ! !ZipWriteStream methodsFor: 'initialize-release' stamp: 'ar 12/30/1999 00:39'! release "We're done with compression. Do some cleanup." literals _ distances _ literalFreq _ distanceFreq _ nil.! ! !ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/30/1999 00:37'! encodedStream ^encoder encodedStream! ! !ZipWriteStream methodsFor: 'accessing' stamp: 'ar 12/29/1999 18:32'! forcedMethod "Return a symbol describing an enforced method or nil if the method should be chosen adaptively. Valid symbols are #stored - store blocks (do not compress) #fixed - use fixed huffman trees #dynamic - use dynamic huffman trees." ^nil! ! !ZipWriteStream methodsFor: 'deflating' stamp: 'ar 12/30/1999 14:27'! deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch "^DeflatePlugin doPrimitive:#primitiveDeflateBlock" <primitive:'primitiveDeflateBlock'> ^super deflateBlock: lastIndex chainLength: chainLength goodMatch: goodMatch! ! !ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! encodeLiteral: lit "Encode the given literal" litCount _ litCount + 1. literals at: litCount put: lit. distances at: litCount put: 0. literalFreq at: lit+1 put: (literalFreq at: lit+1) + 1. ^self shouldFlush! ! !ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:05'! encodeMatch: length distance: dist "Encode the given match of length length starting at dist bytes ahead" | literal distance | dist > 0 ifFalse:[^self error:'Distance must be positive']. length < MinMatch ifTrue:[^self error:'Match length must be at least ', MinMatch printString]. litCount _ litCount + 1. matchCount _ matchCount + 1. literals at: litCount put: length - MinMatch. distances at: litCount put: dist. literal _ (MatchLengthCodes at: length - MinMatch + 1). literalFreq at: literal+1 put: (literalFreq at: literal+1) + 1. dist < 257 ifTrue:[distance _ DistanceCodes at: dist] ifFalse:[distance _ DistanceCodes at: 257 + (dist - 1 bitShift: -7)]. distanceFreq at: distance+1 put: (distanceFreq at: distance+1) + 1. ^self shouldFlush! ! !ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! flushBlock ^self flushBlock: false! ! !ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/30/1999 11:54'! flushBlock: lastBlock "Send the current block" | lastFlag bitsRequired method bitsSent storedLength fixedLength dynamicLength blTree lTree dTree blBits blFreq | lastFlag _ lastBlock ifTrue:[1] ifFalse:[0]. "Compute the literal/length and distance tree" lTree _ ZipEncoderTree buildTreeFrom: literalFreq maxDepth: MaxBits. dTree _ ZipEncoderTree buildTreeFrom: distanceFreq maxDepth: MaxBits. "Compute the bit length tree" blBits _ lTree bitLengths, dTree bitLengths. blFreq _ WordArray new: MaxBitLengthCodes. self scanBitLengths: blBits into: blFreq. blTree _ ZipEncoderTree buildTreeFrom: blFreq maxDepth: MaxBitLengthBits. "Compute the bit length for the current block. Note: Most of this could be computed on the fly but it's getting really ugly in this case so we do it afterwards." storedLength _ self storedBlockSize. fixedLength _ self fixedBlockSizeFor: lTree and: dTree. dynamicLength _ self dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq. VerboseLevel > 1 ifTrue:[ Transcript cr; show:'Block sizes (S/F/D):'; space; print: storedLength // 8; nextPut:$/; print: fixedLength // 8; nextPut:$/; print: dynamicLength // 8; space; endEntry]. "Check which method to use" method _ self forcedMethod. method == nil ifTrue:[ method _ (storedLength < fixedLength and:[storedLength < dynamicLength]) ifTrue:[#stored] ifFalse:[fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]]. (method == #stored and:[blockStart < 0]) ifTrue:[ "Cannot use #stored if the block is not available" method _ fixedLength < dynamicLength ifTrue:[#fixed] ifFalse:[#dynamic]]. bitsSent _ encoder bitPosition. "# of bits sent before this block" bitsRequired _ nil. (method == #stored) ifTrue:[ VerboseLevel > 0 ifTrue:[Transcript show:'S']. bitsRequired _ storedLength. encoder nextBits: 3 put: StoredBlock << 1 + lastFlag. self sendStoredBlock]. (method == #fixed) ifTrue:[ VerboseLevel > 0 ifTrue:[Transcript show:'F']. bitsRequired _ fixedLength. encoder nextBits: 3 put: FixedBlock << 1 + lastFlag. self sendFixedBlock]. (method == #dynamic) ifTrue:[ VerboseLevel > 0 ifTrue:[Transcript show:'D']. bitsRequired _ dynamicLength. encoder nextBits: 3 put: DynamicBlock << 1 + lastFlag. self sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: blBits]. bitsRequired = (encoder bitPosition - bitsSent) ifFalse:[self error:'Bits size mismatch']. lastBlock ifTrue:[self release] ifFalse:[self initializeNewBlock].! ! !ZipWriteStream methodsFor: 'encoding' stamp: 'ar 12/29/1999 18:08'! shouldFlush "Check if we should flush the current block. Flushing can be useful if the input characteristics change." | nLits | litCount = literals size ifTrue:[^true]. "We *must* flush" (litCount bitAnd: 16rFFF) = 0 ifFalse:[^false]. "Only check every N kbytes" matchCount * 10 <= litCount ifTrue:[ "This is basically random data. There is no need to flush early since the overhead for encoding the trees will add to the overall size" ^false]. "Try to adapt to the input data. We flush if the ratio between matches and literals changes beyound a certain threshold" nLits _ litCount - matchCount. nLits <= matchCount ifTrue:[^false]. "whow!! so many matches" ^nLits * 4 <= matchCount! ! !ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 1/2/2000 16:36'! sendStoredBlock "Send an uncompressed block" | inBytes | inBytes _ blockPosition - blockStart. encoder flushBits. "Skip to byte boundary" encoder nextBits: 16 put: inBytes. encoder nextBits: 16 put: (inBytes bitXor: 16rFFFF). encoder flushBits. 1 to: inBytes do:[:i| encoder nextBytePut: (collection byteAt: blockStart+i)].! ! !ZipWriteStream methodsFor: 'stored blocks' stamp: 'ar 12/30/1999 00:42'! storedBlockSize "Compute the length for the current block when stored as is" ^3 "block type bits" + (8 - (encoder bitPosition + 3 bitAnd: 7) bitAnd: 7)"skipped bits to byte boundary" + 32 "byte length + chksum" + (blockPosition - blockStart * 8) "actual data bits".! ! !ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! fixedBlockSizeFor: lTree and: dTree "Compute the length for the current block using fixed huffman trees" | bits extra | bits _ 3 "block type". "Compute the size of the compressed block" 0 to: NumLiterals do:[:i| "encoding of literals" bits _ bits + ((literalFreq at: i+1) * (FixedLiteralTree bitLengthAt: i))]. NumLiterals+1 to: lTree maxCode+1 do:[:i| "Encoding of match lengths" extra _ ExtraLengthBits at: i-NumLiterals. bits _ bits + ((literalFreq at: i+1) * ((FixedLiteralTree bitLengthAt: i) + extra))]. 0 to: dTree maxCode do:[:i| "encoding of distances" extra _ ExtraDistanceBits at: i+1. bits _ bits + ((distanceFreq at: i+1) * ((FixedDistanceTree bitLengthAt: i) + extra))]. ^bits! ! !ZipWriteStream methodsFor: 'fixed blocks' stamp: 'ar 12/29/1999 18:18'! sendFixedBlock "Send a block using fixed huffman trees" self sendCompressedBlock: FixedLiteralTree with: FixedDistanceTree.! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 01:55'! dynamicBlockSizeFor: lTree and: dTree using: blTree and: blFreq "Compute the length for the current block using dynamic huffman trees" | bits index extra treeBits freq | bits _ 3 "block type" + 5 "literal codes length" + 5 "distance codes length". "Compute the # of bits for sending the bit length tree" treeBits _ 4. "Max index for bit length tree" index _ MaxBitLengthCodes. [index >= 4] whileTrue:[ (index = 4 or:[(blFreq at: (BitLengthOrder at: index)+1) > 0]) ifTrue:[treeBits _ treeBits + (index * 3). index _ -1] ifFalse:[index _ index - 1]]. "Compute the # of bits for sending the literal/distance tree. Note: The frequency are already stored in the blTree" 0 to: 15 do:[:i| "First, the non-repeating values" freq _ blFreq at: i+1. freq > 0 ifTrue:[treeBits _ treeBits + (freq * (blTree bitLengthAt: i))]]. "Now the repeating values" (Repeat3To6 to: Repeat11To138) with: #(2 3 7) do:[:i :addl| freq _ blFreq at: i+1. freq > 0 ifTrue:[ treeBits _ treeBits + (freq * ((blTree bitLengthAt: i) + addl "addl bits"))]]. VerboseLevel > 1 ifTrue:[ Transcript show:'['; print: treeBits; show:' bits for dynamic tree]']. bits _ bits + treeBits. "Compute the size of the compressed block" 0 to: NumLiterals do:[:i| "encoding of literals" freq _ literalFreq at: i+1. freq > 0 ifTrue:[bits _ bits + (freq * (lTree bitLengthAt: i))]]. NumLiterals+1 to: lTree maxCode do:[:i| "encoding of match lengths" freq _ literalFreq at: i+1. extra _ ExtraLengthBits at: i-NumLiterals. freq > 0 ifTrue:[bits _ bits + (freq * ((lTree bitLengthAt: i) + extra))]]. 0 to: dTree maxCode do:[:i| "encoding of distances" freq _ distanceFreq at: i+1. extra _ ExtraDistanceBits at: i+1. freq > 0 ifTrue:[bits _ bits + (freq * ((dTree bitLengthAt: i) + extra))]]. ^bits! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! scanBitLength: bitLength repeatCount: repeatCount into: anArray "Update the frequency for the aTree based on the given values" | count | count _ repeatCount. bitLength = 0 ifTrue:[ [count >= 11] whileTrue:[ anArray at: Repeat11To138+1 put: (anArray at: Repeat11To138+1) + 1. count _ (count - 138) max: 0]. [count >= 3] whileTrue:[ anArray at: Repeat3To10+1 put: (anArray at: Repeat3To10+1) + 1. count _ (count - 10) max: 0]. count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. ] ifFalse:[ anArray at: bitLength+1 put: (anArray at: bitLength+1) + 1. count _ count - 1. [count >= 3] whileTrue:[ anArray at: Repeat3To6+1 put: (anArray at: Repeat3To6+1) + 1. count _ (count - 6) max: 0]. count > 0 ifTrue:[anArray at: bitLength+1 put: (anArray at: bitLength+1) + count]. ].! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:55'! scanBitLengths: bits into: anArray "Scan the trees and determine the frequency of the bit lengths. For repeating codes, emit a repeat count." | lastValue lastCount value | bits size = 0 ifTrue:[^self]. lastValue _ bits at: 1. lastCount _ 1. 2 to: bits size do:[:i| value _ bits at: i. value = lastValue ifTrue:[lastCount _ lastCount + 1] ifFalse:[self scanBitLength: lastValue repeatCount: lastCount into: anArray. lastValue _ value. lastCount _ 1]]. self scanBitLength: lastValue repeatCount: lastCount into: anArray.! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! sendBitLength: bitLength repeatCount: repeatCount tree: aTree "Send the given bitLength, repeating repeatCount times" | count | count _ repeatCount. bitLength = 0 ifTrue:[ [count >= 11] whileTrue:[ self sendBitLength: Repeat11To138 tree: aTree. encoder nextBits: 7 put: (count min: 138) - 11. count _ (count - 138) max: 0]. [count >= 3] whileTrue:[ self sendBitLength: Repeat3To10 tree: aTree. encoder nextBits: 3 put: (count min: 10) - 3. count _ (count - 10) max: 0]. count timesRepeat:[self sendBitLength: bitLength tree: aTree]. ] ifFalse:[ self sendBitLength: bitLength tree: aTree. count _ count - 1. [count >= 3] whileTrue:[ self sendBitLength: Repeat3To6 tree: aTree. encoder nextBits: 2 put: (count min: 6) - 3. count _ (count - 6) max: 0]. count timesRepeat:[self sendBitLength: bitLength tree: aTree]. ].! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! sendBitLength: bitLength tree: aTree "Send the given bitLength" encoder nextBits: (aTree bitLengthAt: bitLength) put: (aTree codeAt: bitLength).! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! sendBitLengthTree: blTree "Send the bit length tree" | blIndex bitLength | MaxBitLengthCodes to: 4 by: -1 do:[:maxIndex| blIndex _ BitLengthOrder at: maxIndex. bitLength _ blIndex <= blTree maxCode ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. (maxIndex = 4 or:[bitLength > 0]) ifTrue:[ encoder nextBits: 4 put: maxIndex - 4. 1 to: maxIndex do:[:j| blIndex _ BitLengthOrder at: j. bitLength _ blIndex <= blTree maxCode ifTrue:[blTree bitLengthAt: blIndex] ifFalse:[0]. encoder nextBits: 3 put: bitLength]. ^self]].! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 00:48'! sendCompressedBlock: litTree with: distTree "Send the current block using the encodings from the given literal/length and distance tree" | sum | sum _ encoder sendBlock: (ReadStream on: literals from: 1 to: litCount) with: (ReadStream on: distances from: 1 to: litCount) with: litTree with: distTree. sum = (blockPosition - blockStart) ifFalse:[self error:'Wrong number of bytes'].! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/29/1999 18:19'! sendDynamicBlock: blTree literalTree: lTree distanceTree: dTree bitLengths: bits "Send a block using dynamic huffman trees" self sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits. self sendCompressedBlock: lTree with: dTree.! ! !ZipWriteStream methodsFor: 'dynamic blocks' stamp: 'ar 12/30/1999 11:40'! sendLiteralTree: lTree distanceTree: dTree using: blTree bitLengths: bits "Send all the trees needed for dynamic huffman tree encoding" | lastValue lastCount value | encoder nextBits: 5 put: (lTree maxCode - 256). encoder nextBits: 5 put: (dTree maxCode). self sendBitLengthTree: blTree. bits size = 0 ifTrue:[^self]. lastValue _ bits at: 1. lastCount _ 1. 2 to: bits size do:[:i| value _ bits at: i. value = lastValue ifTrue:[lastCount _ lastCount + 1] ifFalse:[self sendBitLength: lastValue repeatCount: lastCount tree: blTree. lastValue _ value. lastCount _ 1]]. self sendBitLength: lastValue repeatCount: lastCount tree: blTree.! ! !ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 00:31'! initialize "ZipWriteStream initialize" #( MaxBits MaxBitLengthBits EndBlock StoredBlock FixedBlock DynamicBlock NumLiterals MaxLengthCodes MaxDistCodes MaxBitLengthCodes MaxLiteralCodes Repeat3To6 Repeat3To10 Repeat11To138 ExtraLengthBits ExtraDistanceBits ExtraBitLengthBits BitLengthOrder BaseLength MatchLengthCodes BaseDistance DistanceCodes FixedLiteralTree FixedDistanceTree ) do:[:sym| ZipConstants declare: sym from: Undeclared. ]. VerboseLevel _ 0. MaxBits _ 15. MaxBitLengthBits _ 7. EndBlock _ 256. StoredBlock _ 0. FixedBlock _ 1. DynamicBlock _ 2. NumLiterals _ 256. MaxLengthCodes _ 29. MaxDistCodes _ 30. MaxBitLengthCodes _ 19. MaxLiteralCodes _ NumLiterals + MaxLengthCodes + 1. "+ End of Block" Repeat3To6 _ 16. "Repeat previous bit length 3-6 times (2 bits repeat count)" Repeat3To10 _ 17. "Repeat previous bit length 3-10 times (3 bits repeat count)" Repeat11To138 _ 18. "Repeat previous bit length 11-138 times (7 bits repeat count)" self initializeExtraBits. self initializeLengthCodes. self initializeDistanceCodes. self initializeFixedTrees.! ! !ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:26'! initializeDistanceCodes | dist | BaseDistance _ WordArray new: MaxDistCodes. DistanceCodes _ WordArray new: 512. dist _ 0. 1 to: 16 do:[:code| BaseDistance at: code put: dist. 1 to: (1 bitShift: (ExtraDistanceBits at: code)) do:[:n| dist _ dist + 1. DistanceCodes at: dist put: code-1]]. dist = 256 ifFalse:[self error:'Whoops?!!']. dist _ dist >> 7. 17 to: MaxDistCodes do:[:code| BaseDistance at: code put: dist << 7. 1 to: (1 bitShift: (ExtraDistanceBits at: code)-7) do:[:n| dist _ dist + 1. DistanceCodes at: 256 + dist put: code-1]]. ! ! !ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:27'! initializeExtraBits ExtraLengthBits _ WordArray withAll: #(0 0 0 0 0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 4 4 4 4 5 5 5 5 0). ExtraDistanceBits _ WordArray withAll: #(0 0 0 0 1 1 2 2 3 3 4 4 5 5 6 6 7 7 8 8 9 9 10 10 11 11 12 12 13 13). ExtraBitLengthBits _ WordArray withAll: #(0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 2 3 7). BitLengthOrder _ WordArray withAll: #(16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15). ! ! !ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/30/1999 14:25'! initializeFixedTrees "ZipWriteStream initializeFixedTrees" | counts nodes | FixedLiteralTree _ ZipEncoderTree new. FixedLiteralTree maxCode: 287. counts _ WordArray new: MaxBits+1. counts at: 7+1 put: 24. counts at: 8+1 put: 144+8. counts at: 9+1 put: 112. nodes _ Array new: 288. 1 to: 288 do:[:i| nodes at: i put: (ZipEncoderNode value: i-1 frequency: 0 height: 0)]. 0 to: 143 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. 144 to: 255 do:[:i| (nodes at: i+1) setBitLengthTo: 9]. 256 to: 279 do:[:i| (nodes at: i+1) setBitLengthTo: 7]. 280 to: 287 do:[:i| (nodes at: i+1) setBitLengthTo: 8]. FixedLiteralTree buildCodes: nodes counts: counts maxDepth: MaxBits. FixedLiteralTree setValuesFrom: nodes. FixedDistanceTree _ ZipEncoderTree new. FixedDistanceTree maxCode: MaxDistCodes. FixedDistanceTree bitLengths: ((WordArray new: MaxDistCodes+1) atAllPut: 5) codes: ((0 to: MaxDistCodes) collect:[:i| FixedDistanceTree reverseBits: i length: 5]).! ! !ZipWriteStream class methodsFor: 'class initialization' stamp: 'ar 12/29/1999 18:26'! initializeLengthCodes | length | BaseLength _ WordArray new: MaxLengthCodes. MatchLengthCodes _ WordArray new: MaxMatch - MinMatch + 1. length _ 0. 1 to: MaxLengthCodes - 1 do:[:code| BaseLength at: code put: length. 1 to: (1 bitShift: (ExtraLengthBits at: code)) do:[:n| length _ length + 1. MatchLengthCodes at: length put: NumLiterals + code]]. ! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! baseDistance ^BaseDistance! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! baseLength ^BaseLength! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! distanceCodes ^DistanceCodes! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! extraDistanceBits ^ExtraDistanceBits! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/30/1999 15:55'! extraLengthBits ^ExtraLengthBits! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:42'! matchLengthCodes ^MatchLengthCodes! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! maxDistanceCodes ^MaxDistCodes! ! !ZipWriteStream class methodsFor: 'accessing' stamp: 'ar 12/29/1999 20:53'! maxLiteralCodes ^MaxLiteralCodes! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:48'! compressAndDecompress: aFile using: tempName stats: stats | fileSize tempFile result | aFile == nil ifTrue:[^nil]. fileSize _ aFile size. (fileSize < 1"00000" "or:[fileSize > 1000000]") ifTrue:[aFile close. ^nil]. Transcript cr; show:'Testing ', aFile name,' ... '. tempFile _ StandardFileStream new open: tempName forWrite: true. 'Compressing ', aFile name,'...' displayProgressAt: Sensor cursorPoint from: 1 to: aFile size during:[:bar| result _ self regressionCompress: aFile into: tempFile notifiying: bar stats: stats]. result ifTrue:[ 'Validating ', aFile name,'...' displayProgressAt: Sensor cursorPoint from: 0 to: aFile size during:[:bar| result _ self regressionDecompress: aFile from: tempFile notifying: bar stats: stats]]. aFile close. tempFile close. FileDirectory default deleteFileNamed: tempName ifAbsent:[]. result ~~ false ifTrue:[ Transcript show:' ok (', (result * 100 truncateTo: 0.01) printString,')']. ^result! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 21:11'! logProblem: reason for: aFile | errFile | errFile _ FileStream fileNamed:'problems.log'. errFile position: errFile size. errFile cr; nextPutAll: aFile name; cr; nextPutAll: reason. errFile close. Transcript show:' failed (', reason,')'. aFile close. ^false! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'! printRegressionStats: stats from: fd | raw compressed numFiles | raw _ stats at: #rawSize ifAbsent:[0]. raw = 0 ifTrue:[^self]. compressed _ stats at: #compressedSize ifAbsent:[0]. numFiles _ stats at: #numFiles ifAbsent:[0]. Transcript cr; nextPutAll: fd pathName. Transcript crtab; nextPutAll:'Files compressed: ', numFiles asStringWithCommas. Transcript crtab; nextPutAll:'Bytes compressed: ', raw asStringWithCommas. Transcript crtab; nextPutAll:'Avg. compression ratio: '; print: ((compressed / raw asFloat * 100.0) truncateTo: 0.01). Transcript endEntry.! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:44'! regressionCompress: aFile into: tempFile notifiying: progressBar stats: stats "Compress aFile into tempFile" | zip encoded buffer | aFile binary. aFile position: 0. tempFile binary. buffer _ ByteArray new: 4096. zip _ self on: (ByteArray new: 10000). encoded _ zip encodedStream. [aFile atEnd] whileFalse:[ progressBar value: aFile position. zip nextPutAll: (aFile nextInto: buffer). encoded position > 0 ifTrue:[ tempFile nextPutAll: encoded contents. encoded position: 0]]. zip close. tempFile nextPutAll: encoded contents. ^true! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:45'! regressionDecompress: aFile from: tempFile notifying: progressBar stats: stats "Validate aFile as decompressed from tempFile" | unzip rawSize compressedSize buffer1 buffer2 | rawSize _ aFile size. compressedSize _ tempFile size. aFile ascii. aFile position: 0. tempFile ascii. tempFile position: 0. buffer1 _ String new: 4096. buffer2 _ buffer1 copy. unzip _ FastInflateStream on: tempFile. [aFile atEnd] whileFalse:[ progressBar value: aFile position. buffer1 _ aFile nextInto: buffer1. buffer2 _ unzip nextInto: buffer2. buffer1 = buffer2 ifFalse:[^self logProblem: 'contents ' for: aFile]. ]. unzip next = nil ifFalse:[^self logProblem: 'EOF' for: aFile]. stats at: #rawSize put: (stats at: #rawSize ifAbsent:[0]) + rawSize. stats at: #compressedSize put: (stats at: #compressedSize ifAbsent:[0]) + compressedSize. ^compressedSize asFloat / rawSize asFloat.! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:48'! regressionTest "ZipWriteStream regressionTest" "Compress and decompress everything we can find to validate that compression works as expected." self regressionTestFrom: (FileDirectory default).! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/29/1999 23:46'! regressionTestFrom: fd "ZipWriteStream regressionTestFrom: FileDirectory default" "ZipWriteStream regressionTestFrom: (FileDirectory on:'')" "ZipWriteStream regressionTestFrom: (FileDirectory on:'C:')" | tempName stats | Transcript clear. stats _ Dictionary new. tempName _ FileDirectory default fullNameFor: '$$sqcompress$$'. FileDirectory default deleteFileNamed: tempName. self regressionTestFrom: fd using: tempName stats: stats.! ! !ZipWriteStream class methodsFor: 'regression test' stamp: 'ar 12/31/1999 17:47'! regressionTestFrom: fd using: tempName stats: stats | files file fullName | files _ fd fileNames asSortedCollection. files do:[:fName| file _ nil. fullName _ fd fullNameFor: fName. fullName = tempName ifFalse:[ file _ StandardFileStream new open: fullName forWrite: false]. self compressAndDecompress: file using: tempName stats: stats]. stats at: #numFiles put: (stats at: #numFiles ifAbsent:[0]) + files size. files _ nil. self printRegressionStats: stats from: fd. fd directoryNames asSortedCollection do:[:dName| self regressionTestFrom: (fd directoryNamed: dName) using: tempName stats: stats. ].! ! Smalltalk condenseChanges! Undeclared! Smalltalk unimplemented! Smalltalk unimplemented! Smalltalk unimplemented! Utilities clearAuthorInfo! Smalltalk version! SystemWindow clearTopWindow. HandMorph clearPasteBuffer. Smalltalk reclaimDependents. Smalltalk forgetDoIts. Smalltalk removeEmptyMessageCategories. Symbol rehash. Smalltalk garbageCollect. Array with: Metaclass instanceCount with: CompiledMethod instanceCount with: Smalltalk obsoleteClasses size ! Smalltalk obsoleteClasses ! MObject subclass: #MFile instanceVariableNames: 'name fileID ' classVariableNames: '' poolDictionaries: '' category: 'MSqueak-Optional'! ----SNAPSHOT----#(1 October 2008 7:50:28 pm) priorSource: 4095206! f! f _ MFile new.! f openReadWrite: 'test.txt'.! f nextPutAll: 'testing'.! f cr.! f close.! ----SNAPSHOT----#(1 October 2008 7:52:42 pm) priorSource: 4095845! f _ MFile new. f openReadWrite: 'test.txt'. f nextPutAll: 'testing'. f cr. f close. ! FileDirectory default! DefaultDirectory! !MFile methodsFor: 'primitives' stamp: 'jm 10/1/2008 19:56'! primImageName "Answer the full path name for the current image." "Smalltalk imageName" <primitive: 121> self primitiveFailed! ! Smalltalk imageName! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:00'! localFolder "Quick hack -- assumes Unix file delimiters." "MFile new localFolder" | imagePath | imagePath _ Smalltalk imageName. ! ! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:04' prior: 37650918! localFolder "Quick hack -- assumes Unix file delimiters." "MFile new localFolder" | imagePath delimiter i | imagePath _ Smalltalk imageName. delimiter _ $\. (imagePath includes: delimiter) ifFalse: [delimiter _ $\]. i _ imagePath size. [(i > 0) and: [(imagePath at: i) ~= delimiter]] whileTrue: [i _ i - 1]. i = 0 ifTrue: [^ '']. ^ imagePath copyFrom: 1 to: i ! ! !MFile methodsFor: 'primitives' stamp: 'jm 10/1/2008 20:04' prior: 37650703! primImageName "Answer the full path name for the current image." <primitive: 121> self primitiveFailed! ! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:04' prior: 37651132! localFolder "Quick hack -- assumes Unix file delimiters." "MFile new localFolder" | imagePath delimiter i | imagePath _ self primImageName. delimiter _ $\. (imagePath includes: delimiter) ifFalse: [delimiter _ $\]. i _ imagePath size. [(i > 0) and: [(imagePath at: i) ~= delimiter]] whileTrue: [i _ i - 1]. i = 0 ifTrue: [^ '']. ^ imagePath copyFrom: 1 to: i ! ! MFile new localFolder! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:05' prior: 37651769! localFolder "Quick hack -- assumes Unix file delimiters." "MFile new localFolder" | imagePath delimiter i | imagePath _ self primImageName. delimiter _ $/. (imagePath includes: delimiter) ifFalse: [delimiter _ $\]. i _ imagePath size. [(i > 0) and: [(imagePath at: i) ~= delimiter]] whileTrue: [i _ i - 1]. i = 0 ifTrue: [^ '']. ^ imagePath copyFrom: 1 to: i ! ! MFile new localFolder! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:05' prior: 37652242! localFolder "Quick hack -- assumes Unix file delimiters." "MFile new localFolder" | imagePath delimiter i | imagePath _ self primImageName. delimiter _ $/. (imagePath includes: delimiter) ifFalse: [delimiter _ $\]. i _ imagePath size. [(i > 0) and: [(imagePath at: i) ~= delimiter]] whileTrue: [i _ i - 1]. i = 0 ifTrue: [^ '']. ^ imagePath copyFrom: 1 to: i ! ! !MFile methodsFor: 'file ops' stamp: 'jm 10/1/2008 20:05'! localFolderPath "Answer the path for the folder containing the image file." "MFile new localFolderPath" | imagePath delimiter i | imagePath _ self primImageName. delimiter _ $/. (imagePath includes: delimiter) ifFalse: [delimiter _ $\]. i _ imagePath size. [(i > 0) and: [(imagePath at: i) ~= delimiter]] whileTrue: [i _ i - 1]. i = 0 ifTrue: [^ '']. ^ imagePath copyFrom: 1 to: i ! ! MFile removeSelector: #localFolder! !MSystem class methodsFor: 'primitives' stamp: 'jm 10/1/2008 20:10'! append: aString toFile: fileName "Append the given string to the file with the given name." | f | f _ MFile new. f openReadWrite: (f localFolderPath, fileName). f position: f size. f nextPutAll: aString. f close. ! ! !MSystem class methodsFor: 'primitives' stamp: 'jm 10/1/2008 20:12'! log: aString self append: aString toFile: 'log.txt'. ! ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:13' prior: 35710702! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" | f | self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! ----SNAPSHOT----#(1 October 2008 8:13:27 pm) priorSource: 4096011! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:13' prior: 37654095! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" | f | self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. "xxx f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. xxx" MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! ----SNAPSHOT----#(1 October 2008 8:13:52 pm) priorSource: 4100311! MSystem start! !MSystem class methodsFor: 'primitives' stamp: 'jm 10/1/2008 20:15' prior: 37653650! append: aString toFile: fileName "Append the given string to the file with the given name." | f | f _ MFile new. f openReadWrite: (f localFolderPath, fileName). f position: f size. f nextPutAll: aString. f cr. f close. ! ! MSystem start! MSystem start! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:17'! graphicsTest "This method is called when the image is started. Add a call to your own code here." "MSystem start" | f | self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. "xxx f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. xxx" MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:17' prior: 37656068! graphicsTest "This method is called when the image is started. Add a call to your own code here." "MSystem start" | | self log: 'Screen size: ', MForm new primScreenSize printString. "xxx f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. xxx" MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:18' prior: 37656823! graphicsTest | f | "This method is called when the image is started. Add a call to your own code here." "MSystem graphicsTest" self log: 'Screen size: ', MForm new primScreenSize printString. f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. ! ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:18' prior: 37657522! graphicsTest "This method is called when the image is started. Add a call to your own code here." "MSystem graphicsTest" | f | self log: 'Screen size: ', MForm new primScreenSize printString. f _ MForm new. f beDisplayDepth: 32. 0 to: 255 do: [:r | 0 to: 255 do: [:gb | f setColorR: r g: gb b: gb. f fillRectX: gb y: 0 w: 1 h: f height]]. f setColorR: 255 g: 255 b: 0. f fillRectX: 0 y: 0 w: 30 h: 30. ! ! ----SNAPSHOT----#(1 October 2008 8:18:28 pm) priorSource: 4101127! MSystem graphicsTest! ----STARTUP----#(1 October 2008 8:18:48 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:19' prior: 37654901! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" | f | self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. "self graphicsTest" MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:19' prior: 37658769! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. "self graphicsTest." MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! SystemWindow clearTopWindow. HandMorph clearPasteBuffer. Smalltalk reclaimDependents. Smalltalk forgetDoIts. Smalltalk removeEmptyMessageCategories. Symbol rehash. Smalltalk garbageCollect. Array with: Metaclass instanceCount with: CompiledMethod instanceCount with: Smalltalk obsoleteClasses size ! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image'! ----QUIT----#(1 October 2008 8:20:05 pm) priorSource: 4104026! ----STARTUP----#(1 October 2008 8:20:40 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:21' prior: 37659305! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. "self graphicsTest." MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! self tinyBenchmarks! !MSystem commentStamp: 'jm 10/1/2008 20:23' prior: 35710450! I represent the system itself. I implement some useful system facilities as class methods. I am a very lightweight version of the 'SystemDictionary' in other Smalltalk systems. My class method "startup" is called when the image is first started. ! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image'! ----STARTUP----#(1 October 2008 8:26:11 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:28' prior: 37659305! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. self graphicsTest. MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image'! ----QUIT----#(1 October 2008 8:29:04 pm) priorSource: 4105678! ----STARTUP----#(1 October 2008 8:31:10 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:32' prior: 37661401! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. "self graphicsTest." MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! MSystem start! MSystem start! ----QUIT----#(1 October 2008 8:35:12 pm) priorSource: 4107471! ----STARTUP----#(1 October 2008 8:35:43 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MicroSqueak class methodsFor: 'space analysis' stamp: 'jm 10/1/2008 20:36' prior: 35821966! stats "self stats" | classVarCount methodCount literalCount bytecodeCount classes | classVarCount _ methodCount _ literalCount _ bytecodeCount _ 0. classes _ MObject withAllSubclasses asArray. classes do: [:c | classVarCount _ classVarCount + c classPool size. (c methodDict asArray, c class methodDict asArray) do: [:m | methodCount _ methodCount + 1. literalCount _ literalCount + m literals size. bytecodeCount _ bytecodeCount + (m endPC - m initialPC + 1)]]. ^ 'MicroSqueak Stats: classes: ', classes size printString, ' class vars: ', classVarCount printString, ' methods: ', methodCount printString, ' literals: ', literalCount printString, ' bytecodes: ', bytecodeCount printString, ' '. ! ! self stats! MicroSqueak unimplemented ! MicroSqueak unimplemented ! MicroSqueak unimplemented ! MicroSqueak unimplemented ! MNumber variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Optional'! MicroSqueak unimplemented ! MicroSqueak unsent ! MicroSqueak classStats! MicroSqueak analyzeLiterals ! Utilities clearAuthorInfo! Smalltalk version! Smalltalk version! !SystemDictionary methodsFor: 'sources, change log' stamp: 'jm 10/1/2008 20:49' prior: 37238327! version "Answer the version of this release." "VersionString _ 'MicroSqueak 0.2 (January, 2004)'" ^ VersionString ! ! Smalltalk version! VersionString _ 'MicroSqueak 0.2 (January, 2004)'! Smalltalk version! Utilities clearAuthorInfo! SystemWindow clearTopWindow. HandMorph clearPasteBuffer. Smalltalk reclaimDependents. Smalltalk forgetDoIts. Smalltalk removeEmptyMessageCategories. Symbol rehash. Smalltalk garbageCollect. Array with: Metaclass instanceCount with: CompiledMethod instanceCount with: Smalltalk obsoleteClasses size ! MNumber variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Numeric'! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/1/2008 20:52' prior: 37662187! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: MForm new primScreenSize printString. self beep. self beep. "self graphicsTest." MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! Number variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Numeric'! MNumber variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Numeric'! Number variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Numeric'! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image' ! MNumber variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Numeric'! Number variableWordSubclass: #MFloat instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 Twopi ' poolDictionaries: '' category: 'MSqueak-Optional'! MicroSqueak unimplemented! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image'! ----QUIT----#(1 October 2008 8:56:32 pm) priorSource: 4108227! ----STARTUP----#(1 October 2008 8:57:37 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! MicroSqueak stats! ----QUIT----#(1 October 2008 9:04:19 pm) priorSource: 4112816! ----STARTUP----#(2 October 2008 12:37:30 pm) as /Users/jmaloney/Current/MicroSqueak/MicroSqueak for Elliot/MicroSqueakDev.image! !MSystem class methodsFor: 'system startup' stamp: 'jm 10/2/2008 12:38' prior: 37665259! start "This method is called when the image is started. Add a call to your own code here." "MSystem start" self log: 'Welcome to MicroSqueak!!'. self log: self tinyBenchmarks. self log: 'Hello, World.'.. self beep. self beep. "self graphicsTest." MObject superclass ifNil: [self quit]. "quit only when running in MicroSqueak; this avoids accidentally quitting form your normal Squeak image when you're testing the start method!!" ! ! MSystem start! MicroSqueakImageBuilder new buildImageNamed: 'msqueak.image' ! !MicroSqueak commentStamp: 'jm 10/7/2010 15:34' prior: 0! Copyright (c) 2010 John Maloney ! !MicroSqueakImageBuilder commentStamp: 'jm 10/7/2010 15:34' prior: 0! Copyright (c) 2010 John Maloney ! !MFalse commentStamp: 'jm 10/7/2010 15:34' prior: 35488010! Copyright (c) 2010 John Maloney I represent the logical value true. ! !MObject commentStamp: 'jm 10/7/2010 15:34' prior: 35625487! Copyright (c) 2010 John Maloney I provide default behavior common to all objects, such as class access, copying and printing. ! !MTrue commentStamp: 'jm 10/7/2010 15:34' prior: 35715051! Copyright (c) 2010 John Maloney I represent the logical value true. ! !MUndefinedObject commentStamp: 'jm 10/7/2010 15:34' prior: 35717643! Copyright (c) 2010 John Maloney I describe the behavior of my sole instance, nil, an object used as the value of variables or array elements that have not been initialized or for results that are meaningless. ! !MBehavior commentStamp: 'jm 10/7/2010 15:35' prior: 35447857! Copyright (c) 2010 John Maloney I describe the behavior of other objects. I provide the minimum state needed by the virtual machine to lookup and execute methods. Most objects are actually instances of my richer subclass, Class, but I may a good starting point for providing instance-specific object behavior. Note: The virtual machine depends on the exact ordering of my instance variables. Note: For debugging purposes, three dummy instance variables have been added. This allows existing VM's to find class names during debugging and stack printing. ! !MClass commentStamp: 'jm 10/7/2010 15:35' prior: 35469548! Copyright (c) 2010 John Maloney I add the following facilities to Behavior: o class name o named instance variables o an optional dictionary of class variables ! !MMetaclass commentStamp: 'jm 10/7/2010 15:35' prior: 35606368! Copyright (c) 2010 John Maloney My instances support class-specific class behavior such as class initialization and instance creation messages. There is a subclass of me for every normal class, and there is exactly one instance of each of these subclasses, one for each class. Subclasses of me get their names and class pools from their associated class. In general, the superclass hierarchy for metaclasses parallels that of their classes. For example: Integer superclass == Number, and Integer class superclass == Number class However there is a singularity at Object. Here the class hierarchy terminates, but the metaclass hierarchy must wrap around to Class, since ALL metaclasses are subclasses of Class. Thus, Object superclass == nil, but Object class superclass == Class If this is confusing, don't worry; it doesn't really matter unless you're trying to change the way classes work. ! !MCharacter commentStamp: 'jm 10/7/2010 15:35' prior: 35463946! Copyright (c) 2010 John Maloney 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. !