'From Smalltalk-80 version 1.03 of July 31, 1996 on 20 September 1996 at 10:50:05 am'!

Object subclass: #AbstractSound
	instanceVariableNames: 'samplesUntilNextControl '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound'!

!AbstractSound methodsFor: 'initialization'!
initialize

	^ self
!
setPitch: p dur: d loudness: l

	self subclassResponsibility.! !

!AbstractSound methodsFor: 'playing'!
play
	"Play this sound to the sound ouput port in real time."

	SoundPlayer playSound: self.!
playSampleCount: n into: aSoundBuffer startingAt: startIndex stereo: stereoFlag
	"Mixes the next count samples of this sound into the given buffer starting at the given index, updating the receiver's control parameters at periodic intervals."

	| pastEnd i leftRightPan remainingSamples count |
	stereoFlag ifTrue: [leftRightPan _ 500] ifFalse: [leftRightPan _ 1000].
	pastEnd _ startIndex + n.  "index just index of after last sample"
	i _ startIndex.
	[i < pastEnd] whileTrue: [
		remainingSamples _ self samplesRemaining.
		remainingSamples <= 0 ifTrue: [ ^ self ].
		count _ ((pastEnd - i) min: samplesUntilNextControl) min: remainingSamples.
		self mixSampleCount: count into: aSoundBuffer startingAt: i pan: leftRightPan.
		samplesUntilNextControl _ samplesUntilNextControl - count.
		samplesUntilNextControl <= 0 ifTrue: [
			self doControl.
			samplesUntilNextControl _ (self samplingRate // self controlRate).
		].
		i _ i + count.
	].
!
playSilently
	"Compute the samples of this sound without outputting them. Used for performance analysis."

	| buf |
	self reset.
	buf _ SoundBuffer sampleCount: (self samplingRate // 10).
	[self samplesRemaining > 0] whileTrue: [
		buf primFill: 0.
		self playSampleCount: buf sampleCount into: buf startingAt: 1 stereo: true.
	].
! !

!AbstractSound methodsFor: 'sound generation'!
doControl
	"Update the control parameters of this sound (e.g., it's envelope)."
	"Note: This is only called at a small fraction of the sampling rate."

	^ self!
mixSampleCount: count into: aSoundBuffer startingAt: index pan: pan
	"Mix the given number of samples with the samples already in the given buffer starting at the given index. Assume that the buffer size is at least (index + count) - 1. The pan parameter determines the left-right balance of the sound, where 0 is left only, 1000 is right only, and 500 is centered."

	self subclassResponsibility.!
reset
	"Reset my internal state for a replay."

	samplesUntilNextControl _ (self samplingRate // self controlRate).
!
samplesRemaining
	"Answer the number of samples remaining until the end of this sound. A sound with an indefinite ending time should answer some large integer such as 1000000."

	^ 1000000! !

!AbstractSound methodsFor: 'composition'!
+ aSound
	"Return the mix of the receiver and the argument sound."

	^ MixedSound new
		add: self;
		add: aSound
!
, aSound
	"Return the concatenation of the receiver and the argument sound."

	^ SequentialSound new
		add: self;
		add: aSound
!
delayedBy: seconds
	"Return a composite sound consisting of a rest for the given amount of time followed by the receiver."

	^ (RestSound dur: seconds), self! !

!AbstractSound methodsFor: 'sampling rates'!
controlRate
	"Answer the number of control changes per second."

	^ 50!
samplingRate
	"Answer the sampling rate in samples per second."

	^ SoundPlayer samplingRate! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

AbstractSound class
	instanceVariableNames: ''!

!AbstractSound class methodsFor: 'instance creation'!
dur: d
	"Return a rest of the given duration."

	^ self basicNew setDur: d!
namedNoteSequenceFrom: anArray
	"Build a note sequence (i.e., a SequentialSound) from the given array. Elements are either (pitchName, duration, loudness) triples or (#rest duration) pairs."

	| score |
	score _ SequentialSound new.
	anArray do: [ :el |
		el size = 3 ifTrue: [
			score add: (self pitch: (self pitchForName: (el at: 1)) dur: (el at: 2) loudness: (el at: 3)).
		] ifFalse: [
			score add: (RestSound dur: (el at: 2)).
		].
	].
	^ score!
new

	^ self basicNew initialize!
noteSequenceFrom: anArray
	"Build a note sequence (i.e., a SequentialSound) from the given array. Elements are either (pitch, duration, loudness) triples or (#rest duration) pairs."

	| score |
	score _ SequentialSound new.
	anArray do: [ :el |
		el size = 3 ifTrue: [
			score add: (self pitch: (el at: 1) dur: (el at: 2) loudness: (el at: 3)).
		] ifFalse: [
			score add: (RestSound dur: (el at: 2)).
		].
	].
	^ score!
pitch: p dur: d loudness: l
	"Return a new sound object to a note with the given parameters."

	^ self basicNew setPitch: p dur: d loudness: l!
pitchForName: aString
	"AbstractSound pitchForName: 'c2'"
	"#(c 'c#' d eb e f fs g 'g#' a bf b) collect: [ :s | AbstractSound pitchForName: s, '4']"

	| s modifier octave i j noteName p |
	s _ ReadStream on: aString.
	modifier _ $n.
	noteName _ s next.
	(s atEnd not and: [s peek isDigit]) ifFalse: [ modifier _ s next ].
	s atEnd
		ifTrue: [ octave _ 4 ]
		ifFalse: [ octave _ Integer readFrom: s ].
	octave < 0 ifTrue: [ self error: 'cannot use negative octave number' ].
	i _ 'cdefgab' indexOf: noteName.
	i = 0 ifTrue: [ self error: 'bad note name: ', noteName asString ].
	i _ #(2 4 6 7 9 11 13) at: i.
	j _ 's#fb' indexOf: modifier.
	j = 0 ifFalse: [ i _ i + (#(1 1 -1 -1) at: j) ].  "i is now in range: [1..14]"
	"Table generator: (1 to: 14) collect: [ :i | 16.3516 * (2.0 raisedTo: (i - 2) asFloat / 12.0)]"
	p _ #(15.4339 16.3516 17.3239 18.354 19.4454 20.6017 21.8268 23.1247 24.4997 25.9565 27.5 29.1352 30.8677 32.7032) at: i.
	octave timesRepeat: [ p _ 2.0 * p ].
	^ p
! !

!AbstractSound class methodsFor: 'examples'!
bachFugue
	"A fugue by J. S. Bach."
	"AbstractSound bachFugue play"

	"BoinkSound		bachFugueVoice1 play"
	"WaveTableSound	bachFugueVoice1 play"
	"PluckedSound		bachFugueVoice1 play"
	"FMSound			bachFugueVoice1 play"

	^ MixedSound new
		add: BoinkSound bachFugueVoice1 pan: 200;
		add: WaveTableSound bachFugueVoice2 pan: 800;
		add: FMSound bachFugueVoice3 pan: 400;
		add: FMSound bachFugueVoice4 pan: 600.
!
bachFugueVoice1
	"Voice one of a fugue by J. S. Bach."

	^ self noteSequenceFrom: #(
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(784  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(1175 0.30 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.60 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(1047 0.15 268)
		(988  0.15 268)
		(880  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.15 268)
		(523  0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(1047 0.30 268)
		(932  0.30 268)
		(880  0.30 268)
		(932  0.30 268)
		(1047 0.30 268)
		(740  0.30 268)
		(784  0.30 268)
		(880  0.30 268)
		(740  0.30 268)
		(784  0.60 268)
		(rest 0.15)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.45 268)
		(587  0.15 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(880  0.15 268)
		(932  0.45 268)
		(622  0.15 268)
		(698  0.15 268)
		(784  0.15 268)
		(831  0.15 268)
		(784  0.15 268)
		(698  0.15 268)
		(622  0.15 268)
		(587  0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.60 268)
		(rest 0.9)
		(1397 0.30 268)
		(1245 0.30 268)
		(1175 0.30 268)
		(rest 0.3)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(784  0.30 268)
		(698  0.15 268)
		(622  0.15 268)
		(698  0.30 268)
		(587  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(988  0.30 268)
		(1047 0.30 268)
		(1047 0.15 268)
		(988  0.15 268)
		(1047 0.30 268)
		(784  0.30 268)
		(831  0.60 268)
		(rest 0.3)
		(880  0.30 268)
		(932  0.30 268)
		(932  0.15 268)
		(880  0.15 268)
		(932  0.30 268)
		(698  0.30 268)
		(784  0.60 268)
		(rest 0.3)
		(784  0.30 268)
		(831  0.30 268)
		(831  0.30 268)
		(784  0.30 268)
		(698  0.30 268)
		(rest 0.3)
		(415  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(rest 0.3)
		(415  0.15 268)
		(392  0.15 268)
		(415  0.30 268)
		(349  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(415  0.30 268)
		(466  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(311  0.30 268)
		(349  0.30 268)
		(554  0.30 268)
		(523  0.30 268)
		(466  0.30 268)
		(523  0.30 268)
		(415  0.30 268)
		(392  0.30 268)
		(349  0.30 268)
		(392  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(523  0.30 268)
		(622  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(587  0.30 268)
		(784  0.15 268)
		(740  0.15 268)
		(784  0.30 268)
		(880  0.30 268)
		(523  0.15 268)
		(587  0.15 268)
		(622  0.60 268)
		(587  0.15 268)
		(523  0.15 268)
		(466  0.30 346)
		(rest 0.45)
		(587  0.15 346)
		(659  0.15 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.45 346)
		(659  0.15 346)
		(698  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.15 346)
		(1047 0.45 346)
		(740  0.15 346)
		(784  0.15 346)
		(880  0.15 346)
		(932  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(392  0.30 346)
		(415  0.30 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.30 346)
		(440  0.30 346)
		(466  0.30 346)
		(784  0.15 346)
		(698  0.15 346)
		(784  0.30 346)
		(494  0.30 346)
		(523  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(587  0.15 346)
		(523  0.15 346)
		(466  0.15 346)
		(440  0.15 346)
		(392  0.15 346)
		(349  0.30 346)
		(831  0.30 346)
		(784  0.30 346)
		(698  0.30 346)
		(622  0.30 346)
		(587  0.30 346)
		(622  0.30 346)
		(698  0.30 346)
		(494  0.30 346)
		(523  0.30 346)
		(587  0.30 346)
		(494  0.30 346)
		(523  0.60 346)
		(rest 0.3)
		(659  0.30 346)
		(698  0.30 346)
		(698  0.15 346)
		(659  0.15 346)
		(698  0.30 346)
		(523  0.30 346)
		(587  0.60 346)
		(rest 0.3)
		(587  0.30 346)
		(622  0.30 346)
		(622  0.15 346)
		(587  0.15 346)
		(622  0.30 346)
		(466  0.30 346)
		(523  1.20 346)
		(523  0.30 346)
		(587  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(622  0.15 346)
		(698  0.15 346)
		(587  0.15 346)
		(494  0.30 457)
		(rest 0.6)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.6)
		(622  0.30 457)
		(587  0.30 457)
		(rest 0.6)
		(698  0.60 457)
		(rest 0.6)
		(698  0.30 457)
		(622  0.30 457)
		(831  0.30 457)
		(784  0.30 457)
		(698  0.30 457)
		(622  0.30 457)
		(587  0.30 457)
		(622  0.30 457)
		(698  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(587  0.30 457)
		(494  0.30 457)
		(494  0.30 457)
		(523  0.30 457)
		(rest 0.3)
		(523  0.30 457)
		(698  0.15 457)
		(587  0.15 457)
		(622  0.15 457)
		(523  0.45 457)
		(494  0.30 457)
		(523  0.60 457)
		(rest 0.3)
		(659  0.30 268)
		(698  0.60 268)
		(rest 0.3)
		(698  0.30 268)
		(698  0.30 268)
		(622  0.15 268)
		(587  0.15 268)
		(622  0.30 268)
		(698  0.30 268)
		(587  0.40 268)
		(rest 0.4)
		(587  0.40 268)
		(rest 0.4)
		(523  1.60 268)).!
bachFugueVoice2
	"Voice two of a fugue by J. S. Bach."

	^ self noteSequenceFrom: #(
		(rest 4.8)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1047 0.30 346)
		(1245 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1175 0.30 346)
		(1568 0.15 346)
		(1480 0.15 346)
		(1568 0.30 346)
		(1760 0.30 346)
		(1047 0.15 346)
		(1175 0.15 346)
		(1245 0.60 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.30 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1245 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1397 0.15 346)
		(1245 0.15 346)
		(1397 0.30 346)
		(880  0.30 346)
		(932  0.30 346)
		(1568 0.15 346)
		(1397 0.15 346)
		(1568 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.15 346)
		(1245 0.15 346)
		(1397 0.90 346)
		(1245 0.15 346)
		(1175 0.15 346)
		(1047 0.15 346)
		(932  0.15 346)
		(831  0.15 346)
		(784  0.15 346)
		(698  0.30 346)
		(1661 0.30 346)
		(1568 0.30 346)
		(1397 0.30 346)
		(1245 0.30 346)
		(1175 0.30 346)
		(1245 0.30 346)
		(1397 0.30 346)
		(988  0.30 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(988  0.30 346)
		(1047 0.30 457)
		(1568 0.15 457)
		(1480 0.15 457)
		(1568 0.30 457)
		(1175 0.30 457)
		(1245 0.60 457)
		(rest 0.3)
		(1319 0.30 457)
		(1397 0.30 457)
		(1397 0.15 457)
		(1319 0.15 457)
		(1397 0.30 457)
		(1047 0.30 457)
		(1175 0.60 457)
		(rest 0.3)
		(1175 0.30 457)
		(1245 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(932  0.30 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.30 457)
		(1397 0.30 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.60 457)
		(932  0.15 457)
		(831  0.15 457)
		(784  0.15 457)
		(622  0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1865 0.15 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(1175 0.15 457)
		(1319 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1245 0.15 457)
		(1397 0.15 457)
		(1568 0.15 457)
		(1760 0.15 457)
		(1976 0.15 457)
		(2093 0.30 457)
		(1976 0.15 457)
		(1760 0.15 457)
		(1568 0.15 457)
		(1397 0.15 457)
		(1245 0.15 457)
		(1175 0.15 457)
		(1047 0.30 457)
		(1245 0.30 457)
		(1175 0.30 457)
		(1047 0.30 457)
		(932  0.30 457)
		(880  0.30 457)
		(932  0.30 457)
		(1047 0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(880  0.30 457)
		(740  0.30 457)
		(784  0.30 457)
		(1175 0.15 457)
		(1047 0.15 457)
		(1175 0.30 457)
		(rest 0.6)
		(1319 0.15 457)
		(1175 0.15 457)
		(1319 0.30 457)
		(rest 0.6)
		(1480 0.15 457)
		(1319 0.15 457)
		(1480 0.30 457)
		(rest 0.6)
		(784  0.15 457)
		(698  0.15 457)
		(784  0.30 457)
		(rest 0.6)
		(880  0.15 457)
		(784  0.15 457)
		(880  0.30 457)
		(rest 0.6)
		(988  0.15 457)
		(880  0.15 457)
		(988  0.30 457)
		(rest 0.6)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(784  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(1175 0.30 457)
		(698  0.15 457)
		(784  0.15 457)
		(831  0.60 457)
		(784  0.15 457)
		(698  0.15 457)
		(622  0.30 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.30 457)
		(784  0.30 457)
		(831  0.60 457)
		(rest 0.3)
		(880  0.30 457)
		(932  0.30 457)
		(932  0.15 457)
		(880  0.15 457)
		(932  0.30 457)
		(698  0.30 457)
		(784  0.60 457)
		(rest 0.3)
		(784  0.60 457)
		(831  0.15 457)
		(932  0.15 457)
		(1047 0.15 457)
		(988  0.15 457)
		(1047 0.15 457)
		(831  0.15 457)
		(698  1.20 457)
		(698  0.30 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(1175 0.30 591)
		(698  0.30 591)
		(622  0.30 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1245 0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1397 0.30 591)
		(831  0.30 591)
		(784  0.15 591)
		(1397 0.15 591)
		(1245 0.15 591)
		(1175 0.15 591)
		(1047 0.15 591)
		(988  0.15 591)
		(880  0.15 591)
		(784  0.15 591)
		(1047 0.30 591)
		(1397 0.30 591)
		(1245 0.30 591)
		(1175 0.30 591)
		(rest 0.3)
		(831  0.30 591)
		(784  0.30 591)
		(698  0.30 591)
		(784  0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(698  0.30 591)
		(587  0.30 591)
		(831  0.30 591)
		(784  0.30 591)
		(rest 0.3)
		(880  0.30 591)
		(988  0.30 591)
		(1047 0.30 591)
		(698  0.15 591)
		(622  0.15 591)
		(587  0.15 591)
		(523  0.15 591)
		(523  0.30 591)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(784  0.30 346)
		(831  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(784  0.30 346)
		(1047 0.15 346)
		(988  0.15 346)
		(1047 0.30 346)
		(1175 0.30 346)
		(698  0.20 346)
		(784  0.20 346)
		(831  0.80 346)
		(784  0.20 346)
		(698  0.20 346)
		(659  1.60 346)).
!
bachFugueVoice3
	"Voice three of a fugue by J. S. Bach."

	^ self noteSequenceFrom: #(
		(rest 14.4)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(392  0.30 457)
		(523  0.15 457)
		(494  0.15 457)
		(523  0.30 457)
		(587  0.30 457)
		(349  0.15 457)
		(392  0.15 457)
		(415  0.60 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(523  0.15 457)
		(494  0.15 457)
		(440  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(466  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.15 457)
		(294  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.15 457)
		(196  0.15 457)
		(175  0.15 457)
		(156  0.15 457)
		(415  0.15 457)
		(392  0.15 457)
		(349  0.15 457)
		(311  0.15 457)
		(277  0.15 457)
		(262  0.15 457)
		(233  0.15 457)
		(208  0.30 457)
		(523  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(349  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(349  0.30 457)
		(392  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(466  0.30 457)
		(415  0.30 457)
		(392  0.30 457)
		(415  0.30 457)
		(349  0.30 457)
		(311  0.30 457)
		(294  0.30 457)
		(311  0.30 457)
		(rest 1.2)
		(262  0.30 457)
		(233  0.30 457)
		(220  0.30 457)
		(rest 0.3)
		(311  0.30 457)
		(294  0.30 457)
		(262  0.30 457)
		(294  0.30 457)
		(262  0.15 457)
		(233  0.15 457)
		(262  0.30 457)
		(294  0.30 457)
		(196  0.30 591)
		(466  0.15 591)
		(440  0.15 591)
		(466  0.30 591)
		(294  0.30 591)
		(311  0.30 591)
		(523  0.15 591)
		(466  0.15 591)
		(523  0.30 591)
		(330  0.30 591)
		(349  0.30 591)
		(587  0.15 591)
		(523  0.15 591)
		(587  0.30 591)
		(370  0.30 591)
		(392  0.60 591)
		(rest 0.15)
		(196  0.15 591)
		(220  0.15 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.45 591)
		(220  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(349  0.45 591)
		(247  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.30 591)
		(rest 0.6)
		(330  0.30 591)
		(349  0.30 591)
		(175  0.30 591)
		(156  0.30 591)
		(147  0.30 591)
		(rest 0.3)
		(208  0.30 591)
		(196  0.30 591)
		(175  0.30 591)
		(196  0.30 591)
		(175  0.15 591)
		(156  0.15 591)
		(175  0.30 591)
		(196  0.30 591)
		(262  0.15 591)
		(294  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(466  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(415  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(233  0.15 591)
		(262  0.15 591)
		(233  0.15 591)
		(208  0.15 591)
		(196  0.15 591)
		(175  0.15 591)
		(156  0.15 591)
		(147  0.15 591)
		(392  0.15 591)
		(349  0.15 591)
		(311  0.15 591)
		(294  0.15 591)
		(262  0.15 591)
		(247  0.15 591)
		(220  0.15 591)
		(196  0.60 772)
		(196  0.60 772)
		(rest 0.15)
		(196  0.15 772)
		(220  0.15 772)
		(247  0.15 772)
		(262  0.15 772)
		(294  0.15 772)
		(311  0.15 772)
		(349  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(415  0.15 772)
		(392  0.15 772)
		(349  0.15 772)
		(311  0.15 772)
		(294  0.15 772)
		(262  0.15 772)
		(247  0.30 772)
		(262  0.15 772)
		(494  0.15 772)
		(262  0.30 772)
		(196  0.30 772)
		(208  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(196  0.30 772)
		(262  0.15 772)
		(247  0.15 772)
		(262  0.30 772)
		(294  0.30 772)
		(175  0.15 772)
		(196  0.15 772)
		(208  0.60 772)
		(196  0.15 772)
		(175  0.15 772)
		(156  0.60 772)
		(rest 0.3)
		(311  0.30 772)
		(294  0.30 772)
		(262  0.30 772)
		(392  0.30 772)
		(196  0.30 772)
		(262  3.60 268)
		(494  0.40 268)
		(rest 0.4)
		(494  0.40 268)
		(rest 0.4)
		(392  1.60 268)).
!
bachFugueVoice4
	"Voice four of a fugue by J. S. Bach."
	"FMSound bachFugueVoice4 play"

	^ self noteSequenceFrom: #(
		(rest 61.2)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(98   0.30 500)
		(104  0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(98   0.30 500)
		(131  0.15 500)
		(123  0.15 500)
		(131  0.30 500)
		(147  0.30 500)
		(87   0.15 500)
		(98   0.15 500)
		(104  0.60 500)
		(98   0.15 500)
		(87   0.15 500)
		(78   0.60 500)
		(rest 0.3)
		(156  0.30 500)
		(147  0.30 500)
		(131  0.30 500)
		(196  0.30 500)
		(98   0.30 500)
		(131  3.60 268)
		(131  3.20 205)).
!
chromaticScale
	"PluckedSound chromaticScale play"

	^ self namedNoteSequenceFrom: #(
		(c4 0.5 400)
		(cs4 0.5 400)		"s means sharp"
		(d4 0.5 400)
		(eb4 0.5 400)	"b means flat (it looks like a flat sign in music notation)"
		(e4 0.5 400)
		(f4 0.5 400)
		('f#4' 0.5 400)	"# also means sharp, but it must be quoted within an array literal"
		(g4 0.5 400)
		(af4 0.5 400)		"f also means flat"
		(a4 0.5 400)
		(bb4 0.5 400)
		(b4 0.5 400)
		(c5 2.0 400))!
lowMajorScale
	"PluckedSound lowMajorScale play"

	^ self namedNoteSequenceFrom: #(
		(c3 0.25 400)
		(d3 0.25 400)
		(e3 0.25 400)
		(f3 0.25 400)
		(g3 0.25 400)
		(a3 0.25 400)
		(b3 0.25 400)
		(c4 0.25 400)
		(d4 0.25 400)
		(c4 0.25 400)
		(b3 0.25 400)
		(a3 0.25 400)
		(g3 0.25 400)
		(f3 0.25 400)
		(e3 0.25 400)
		(d3 0.25 400)
		(c3 1.00 400))!
majorScale
	"BoinkSound majorScale play"

	^ self namedNoteSequenceFrom: #(
		(c5 0.25 400)
		(d5 0.25 400)
		(e5 0.25 400)
		(f5 0.25 400)
		(g5 0.25 400)
		(a5 0.25 400)
		(b5 0.25 400)
		(c6 0.25 400)
		(d6 0.25 400)
		(c6 0.25 400)
		(b5 0.25 400)
		(a5 0.25 400)
		(g5 0.25 400)
		(f5 0.25 400)
		(e5 0.25 400)
		(d5 0.25 400)
		(c5 1.00 400))!
scaleTest
	"AbstractSound scaleTest play"

	^ MixedSound new
		add: FMSound majorScale pan: 0;
		add: (PluckedSound lowMajorScale delayedBy: 0.5) pan: 1000.
!
testFMInteractively
	"Experiment with different settings of the FM modulation and multiplier settings interactively by moving the mouse. The top-left corner of the screen is 0 for both parameters. Stop when the mouse is pressed."
	"AbstractSound testFMInteractively"

	| s mousePt lastVal status |
	SoundPlayer startPlayerProcessBufferSize: 1100 rate: 22050 stereo: false.
	s _ FMSound pitch: 440.0 dur: 200.0 loudness: 200.
	s  decayRate: 1.0; modulationDecay: 1.0.

	SoundPlayer playSound: s.
	[Sensor anyButtonPressed] whileFalse: [
		mousePt _ Sensor cursorPoint.
		mousePt ~= lastVal ifTrue: [
			s modulation: mousePt x * 3 multiplier: mousePt y asFloat / 100.0.
			lastVal _ mousePt.
			status _
'mod: ', (mousePt x * 3) printString, '
mult: ', (mousePt y asFloat / 100.0) printString.
			status asParagraph displayOn: Display at: 10@10.
		].
	].
	SoundPlayer pauseSound: s.
! !Path subclass: #Arc
	instanceVariableNames: 'quadrant radius center '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
Arc comment:
'Arcs are an unusual implementation of splines
due to Ted Kaehler.  Imagine two lines that meet at a corner.
Now imagine two moving points; one moves from the corner to
the end on one line, the other moves from the end of the other
line in to the corner.  Now imagine a series of lines drawn 
between those moving points at each step along the way (they
form a sort of spider web pattern).  By connecting segments
of the intersecting lines, a smooth curve is achieved that is
tangent to both of the original lines.  Voila.'!

!Arc methodsFor: 'accessing'!
center
	"Answer the point at the center of the receiver."

	^center!
center: aPoint 
	"Set aPoint to be the receiver's center."

	center _ aPoint!
center: aPoint radius: anInteger 
	"The receiver is defined by a point at the center and a radius. The 
	quadrant is not reset."

	center _ aPoint.
	radius _ anInteger!
center: aPoint radius: anInteger quadrant: section 
	"Set the receiver's quadrant to be the argument, section. The size of the 
	receiver is defined by the center and its radius."

	center _ aPoint.
	radius _ anInteger.
	quadrant _ section!
quadrant
	"Answer the part of the circle represented by the receiver."
	^quadrant!
quadrant: section 
	"Set the part of the circle represented by the receiver to be the argument, 
	section."

	quadrant _ section!
radius
	"Answer the receiver's radius."

	^radius!
radius: anInteger 
	"Set the receiver's radius to be the argument, anInteger."

	radius _ anInteger! !

!Arc methodsFor: 'display box access'!
computeBoundingBox
	| aRectangle aPoint |
	aRectangle _ center - radius + form offset extent: form extent + (radius * 2) asPoint.
	aPoint _ center + form extent.
	quadrant = 1 ifTrue: [aRectangle left: center x; bottom: aPoint y].
	quadrant = 2 ifTrue: [aRectangle right: aPoint x; bottom: aPoint y].
	quadrant = 3 ifTrue: [aRectangle right: aPoint x; top: center y].
	quadrant = 4 ifTrue: [aRectangle left: center x; top: center y].
	^aRectangle! !

!Arc methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

	| nSegments line angle sin cos xn yn xn1 yn1 |
	nSegments _ 12.0.
	line _ Line new.
	line form: self form.
	angle _ 90.0 / nSegments.
	sin _ (angle * (2 * Float pi / 360.0)) sin.
	cos _ (angle * (2 * Float pi / 360.0)) cos.
	quadrant = 1
		ifTrue: 
			[xn _ radius asFloat.
			yn _ 0.0].
	quadrant = 2
		ifTrue: 
			[xn _ 0.0.
			yn _ 0.0 - radius asFloat].
	quadrant = 3
		ifTrue: 
			[xn _ 0.0 - radius asFloat.
			yn _ 0.0].
	quadrant = 4
		ifTrue: 
			[xn _ 0.0.
			yn _ radius asFloat].
	nSegments asInteger
		timesRepeat: 
			[xn1 _ xn * cos + (yn * sin).
			yn1 _ yn * cos - (xn * sin).
			line beginPoint: center + (xn asInteger @ yn asInteger).
			line endPoint: center + (xn1 asInteger @ yn1 asInteger).
			line
				displayOn: aDisplayMedium
				at: aPoint
				clippingBox: clipRect
				rule: anInteger
				fillColor: aForm.
			xn _ xn1.
			yn _ yn1]!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| newArc tempCenter |
	newArc _ Arc new.
	tempCenter _ aTransformation applyTo: self center.
	newArc center: tempCenter x asInteger @ tempCenter y asInteger.
	newArc quadrant: self quadrant.
	newArc radius: (self radius * aTransformation scale x) asInteger.
	newArc form: self form.
	newArc
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Arc class
	instanceVariableNames: ''!

!Arc class methodsFor: 'examples'!
example
	"Click the button somewhere on the screen. The designated point will
	be the center of an Arc with radius 50 in the 4th quadrant."

	| anArc aForm |
	aForm _ Form extent: 1 @ 30.	"make a long thin Form for display"
	aForm fillBlack.						"turn it black"
	anArc _ Arc new.
	anArc form: aForm.					"set the form for display"
	anArc radius: 50.0.
	anArc center: Sensor waitButton.
	anArc quadrant: 4.
	anArc displayOn: Display.
	Sensor waitButton

	"Arc example"! !ArrayedCollection variableSubclass: #Array
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
Array comment:
'I present an ArrayedCollection whose elements are objects.'!

!Array methodsFor: 'comparing'!
hash
	"Make sure that equal (=) arrays hash equally."

	self size = 0 ifTrue: [^17171].
	^(self at: 1) hash + (self at: self size) hash!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	self size = 0 ifTrue: [^self hash].
	^(self first hashMappedBy: map) + (self last hashMappedBy: map)! !

!Array methodsFor: 'converting'!
asArray
	"Answer with the receiver itself."

	^self!
elementsExchangeIdentityWith: otherArray
	<primitive: 128>
	self primitiveFailed!
evalStrings
	   "Allows you to construct literal arrays.
    #(true false nil '5@6' 'Set new' '''text string''') evalStrings
    gives an array with true, false, nil, a Point, a Set, and a String
    instead of just a bunch of Symbols"
    | it |

    ^ self collect: [:each |
        it _ each.
        each == #true ifTrue: [it _ true].
		      each == #false ifTrue: [it _ false].
        each == #nil ifTrue: [it _ nil].
        each class == String ifTrue: [
			it _ Compiler evaluate: each].
        each class == Array ifTrue: [it _ it evalStrings].
        it]! !

!Array methodsFor: 'printing'!
isLiteral

	self detect: [:element | element isLiteral not] ifNone: [^true].
	^false!
printOn: aStream

	| tooMany |
	tooMany _ self maxPrint.	
		"Need absolute limit, or infinite recursion will never 
		notice anything going wrong.  7/26/96 tk"
	aStream nextPut: $(.
	self do: 
		[:element | 
		aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self].
		element printOn: aStream.
		aStream space].
	aStream nextPut: $)!
storeOn: aStream 
	"Use the literal form if possible."

	self isLiteral
		ifTrue: 
			[aStream nextPut: $#; nextPut: $(.
			self do: 
				[:element | 
				element printOn: aStream.
				aStream space].
			aStream nextPut: $)]
		ifFalse: [super storeOn: aStream]! !

!Array methodsFor: 'private'!
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! !ArrayedCollection subclass: #Array2D
	instanceVariableNames: 'width contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!

!Array2D methodsFor: 'access'!
at: i at: j
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i!
at: i at: j add: value
    "add value to the element"
    | index |
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    index _ (j - 1) * width + i.
    ^ contents at: index put: (contents at: index) + value!
at: i at: j put: value
    "return the element"
    (i < 1) | (i > width) ifTrue: [
        ^ self error: 'first index out of bounds'].
    "second index bounds check is automatic, since contents
        array will get a bounds error."

    ^ contents at: (j - 1) * width + i put: value!
atAllPut: value
    "Initialize"
    contents atAllPut: value!
atCol: i
    "Fetch a whole column.  6/20/96 tk"

	| ans |
	ans _ contents class new: self height.
    1 to: self height do: [:ind |
		ans at: ind put: (self at: i at: ind)].
	^ ans!
atCol: i put: list
    "Put in a whole column.
     hold first index constant"

    list size = self height ifFalse: [self error: 'wrong size']
    list doWithIndex: [:value :j |
        self at: i at: j put: value].!
atRow: j
    "Fetch a whole row.  6/20/96 tk"

    ^ contents copyFrom: (j - 1) * width + 1 to: (j) * width!
atRow: j put: list
    "Put in a whole row.
     hold second index constant"

    list size = self width ifFalse: [self error: 'wrong size']
    list doWithIndex: [:value :i |
        self at: i at: j put: value].!
do: aBlock
	"Iterate with X varying most quickly.  6/20/96 tk"
	^ contents do: aBlock!
extent
	^ width @ self height!
extent: extent fromArray: anArray
	"Load this 2-D array up from a 1-D array.  X varies most quickly.  6/20/96 tk"

	extent x * extent y = anArray size ifFalse: [
		^ self error: 'dimensions don''t match'].
	width _ extent x.
	contents _ anArray.!
height
    "second dimension"
    "no need to save it"
    ^ contents size // width!
width
    "first dimension"
    ^ width!
width: x height: y type: class
    "Set the number of elements in the first and
    second dimensions.  class can be Array or String or ByteArray."

    contents == nil ifFalse: [self error: 'No runtime size change yet'].
        "later move all the elements to the new sized array"
    width _ x.
    contents _ class new: width*y.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Array2D class
	instanceVariableNames: ''!

!Array2D class methodsFor: 'as yet unclassified'!
new
	"Override ArrayedCollection.  6/20/96 tk"
	^ self basicNew!
new: size
	"Use (self new width: x height: y type: Array)   6/20/96 tk"
	^ self shouldNotImplement! !SequenceableCollection subclass: #ArrayedCollection
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Abstract'!
ArrayedCollection comment:
'I am an abstract collection of elements with a fixed range of integers (from 1 to n>=1) as external keys.'!

!ArrayedCollection methodsFor: 'accessing'!
size
	"Primitive. Answer the number of indexable fields in the receiver. This
	value is the same as the largest legal subscript. Primitive is specified
	here to override SequenceableCollection size. Essential. See Object
	documentation whatIsAPrimitive. "

	<primitive: 62>
	^self basicSize! !

!ArrayedCollection methodsFor: 'adding'!
add: newObject

	self shouldNotImplement! !

!ArrayedCollection methodsFor: 'printing'!
storeOn: aStream

	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new: '.
	aStream store: self size.
	aStream nextPut: $).
	(self storeElementsFrom: 1 to: self size on: aStream)
		ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!ArrayedCollection methodsFor: 'private'!
defaultElement

	^nil!
fill: numElements fromStack: aContext 
	"Fill me with numElements elements, popped in reverse order from
	 the stack of aContext.  Do not call directly: this is called indirectly by {1. 2. 3}
	 constructs."

	aContext pop: numElements toIndexable: self!
storeElementsFrom: firstIndex to: lastIndex on: aStream

	| noneYet defaultElement arrayElement |
	noneYet _ true.
	defaultElement _ self defaultElement.
	firstIndex to: lastIndex do: 
		[:index | 
		arrayElement _ self at: index.
		arrayElement = defaultElement
			ifFalse: 
				[noneYet
					ifTrue: [noneYet _ false]
					ifFalse: [aStream nextPut: $;].
				aStream nextPutAll: ' at: '.
				aStream store: index.
				aStream nextPutAll: ' put: '.
				aStream store: arrayElement]].
	^noneYet! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ArrayedCollection class
	instanceVariableNames: ''!

!ArrayedCollection class methodsFor: 'instance creation'!
fromBraceStack: itsSize 
	"Answer an instance of me with itsSize elements, popped in reverse order from
	 the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
	 constructs."

	^ (self new: itsSize) fill: itsSize fromStack: thisContext sender!
new
	"Answer a new instance of me, with size = 0."

	^self new: 0!
new: size withAll: value 
	"Answer an instance of me, with number of elements equal to size, each 
	of which refers to the argument, value."

	^(self new: size) atAllPut: value!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."
	| newArray |
	newArray _ self new: aCollection size.
	1 to: aCollection size do: [:i | newArray at: i put: (aCollection at: i)].
	^ newArray

"	Array newFrom: {1. 2. 3}
	{1. 2. 3} as: Array
	{1. 2. 3} as: ByteArray
	{$c. $h. $r} as: String
	{$c. $h. $r} as: Text
"!
with: anObject 
	"Answer a new instance of me, containing only anObject."

	| newCollection |
	newCollection _ self new: 1.
	newCollection at: 1 put: anObject.
	^newCollection!
with: firstObject with: secondObject 
	"Answer a new instance of me, containing firstObject and secondObject."

	| newCollection |
	newCollection _ self new: 2.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	^newCollection!
with: firstObject with: secondObject with: thirdObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 3.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	^newCollection!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer a new instance of me, containing only the three arguments as
	elements."

	| newCollection |
	newCollection _ self new: 4.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	^newCollection!
with: firstObject with: secondObject with: thirdObject with: fourthObject with: fifthObject
	"Answer a new instance of me, containing only the five arguments as
	elements."

	| newCollection |
	newCollection _ self new: 5.
	newCollection at: 1 put: firstObject.
	newCollection at: 2 put: secondObject.
	newCollection at: 3 put: thirdObject.
	newCollection at: 4 put: fourthObject.
	newCollection at: 5 put: fifthObject.
	^newCollection! !ParseNode subclass: #AssignmentNode
	instanceVariableNames: 'variable value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
AssignmentNode comment: 'I represent a (var_expr) construct.'!

!AssignmentNode methodsFor: 'initialize-release'!
toDoIncrement: var
	var = variable ifFalse: [^ nil].
	(value isMemberOf: MessageNode) 
		ifTrue: [^ value toDoIncrement: var]
		ifFalse: [^ nil]!
value
	^ value!
variable: aVariable value: expression

	variable _ aVariable.
	value _ expression!
variable: aVariable value: expression from: encoder

	(aVariable isMemberOf: MessageNode)
		ifTrue: [^aVariable store: expression from: encoder].
	variable _ aVariable.
	value _ expression! !

!AssignmentNode methodsFor: 'code generation'!
emitForEffect: stack on: aStream

	value emitForValue: stack on: aStream.
	variable emitStorePop: stack on: aStream!
emitForValue: stack on: aStream

	value emitForValue: stack on: aStream.
	variable emitStore: stack on: aStream!
sizeForEffect: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStorePop: encoder)!
sizeForValue: encoder

	^(value sizeForValue: encoder)
		+ (variable sizeForStore: encoder)! !

!AssignmentNode methodsFor: 'printing'!
printOn: aStream indent: level

	variable printOn: aStream indent: level.
	aStream nextPutAll: ' _ '.
	value printOn: aStream indent: level + 2!
printOn: aStream indent: level precedence: p

	p < 4 ifTrue: [aStream nextPutAll: '('].
	self printOn: aStream indent: level.
	p < 4 ifTrue: [aStream nextPutAll: ')']! !

!AssignmentNode methodsFor: 'equation translation'!
collectVariables
	^variable collectVariables, value collectVariables!
copyReplacingVariables: varDict
	| t1 t2 | 
	t1 _ variable copyReplacingVariables: varDict.
	t2 _ value copyReplacingVariables: varDict.
	^self class new variable: t1 value: t2!
specificMatch: aTree using: matchDict 
	^(variable match: aTree variable using: matchDict)
		and: [value match: aTree value using: matchDict]!
variable
	^variable! !

!AssignmentNode methodsFor: 'C translation'! !LookupKey subclass: #Association
	instanceVariableNames: 'value '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
Association comment:
'I represent a pair of associated objects--a key and a value. My instances can serve as entries in a dictionary.'!

!Association methodsFor: 'accessing'!
key: aKey value: anObject 
	"Store the arguments as the variables of the receiver."

	key _ aKey.
	value _ anObject!
value
	"Answer the value of the receiver."

	^value!
value: anObject 
	"Store the argument, anObject, as the value of the receiver."

	value _ anObject! !

!Association methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: '->'.
	value printOn: aStream!
storeOn: aStream
	"Store in the format (key->value)"
	aStream nextPut: $(.
	key storeOn: aStream.
	aStream nextPutAll: '->'.
	value storeOn: aStream.
	aStream nextPut: $)! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Association class
	instanceVariableNames: ''!

!Association class methodsFor: 'instance creation'!
key: newKey value: newValue
	"Answer an instance of me with the arguments as the key and value of 
	the association."

	^(super key: newKey) value: newValue! !Collection subclass: #Bag
	instanceVariableNames: 'contents '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
Bag comment:
'I represent an unordered collection of possibly duplicate elements.
	
I store these elements in a dictionary, tallying up occurrences of equal objects. Because I store an occurrence only once, my clients should beware that objects they store will not necessarily be retrieved such that == is true. If the client cares, a subclass of me should be created.'!

!Bag methodsFor: 'accessing'!
at: index

	self errorNotKeyed!
at: index put: anObject

	self errorNotKeyed!
size

	| tally |
	tally _ 0.
	contents do: [:each | tally _ tally + each].
	^tally!
sortedCounts
	"Answer with a collection of counts with elements, sorted by decreasing
	count."

	| counts |
	counts _ SortedCollection sortBlock: [:x :y | x >= y].
	contents associationsDo:
		[:assn |
		counts add: (Association key: assn value value: assn key)].
	^counts!
sortedElements
	"Answer with a collection of elements with counts, sorted by element."

	| elements |
	elements _ SortedCollection new.
	contents associationsDo: [:assn | elements add: assn].
	^elements! !

!Bag methodsFor: 'testing'!
includes: anObject 
	"Refer to the comment in Collection|includes:."

	^contents includesKey: anObject!
occurrencesOf: anObject 
	"Refer to the comment in Collection|occurrencesOf:."

	(self includes: anObject)
		ifTrue: [^contents at: anObject]
		ifFalse: [^0]! !

!Bag methodsFor: 'adding'!
add: newObject 
	"Refer to the comment in Collection|add:."

	^self add: newObject withOccurrences: 1!
add: newObject withOccurrences: anInteger 
	"Add the element newObject to the receiver. Do so as though the element 
	were added anInteger number of times. Answer newObject."

	(self includes: newObject)
		ifTrue: [contents at: newObject put: anInteger + (contents at: newObject)]
		ifFalse: [contents at: newObject put: anInteger].
	^newObject! !

!Bag methodsFor: 'removing'!
remove: oldObject ifAbsent: exceptionBlock 
	"Refer to the comment in Collection|remove:ifAbsent:."

	| count |
	(self includes: oldObject)
		ifTrue: [(count _ contents at: oldObject) = 1
				ifTrue: [contents removeKey: oldObject]
				ifFalse: [contents at: oldObject put: count - 1]]
		ifFalse: [^exceptionBlock value].
	^oldObject! !

!Bag methodsFor: 'enumerating'!
do: aBlock 
	"Refer to the comment in Collection|do:."

	contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! !

!Bag methodsFor: 'private'!
setDictionary

	contents _ Dictionary new! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bag class
	instanceVariableNames: ''!

!Bag class methodsFor: 'instance creation'!
new

	^super new setDictionary!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newCollection |
	newCollection _ self new.
	newCollection addAll: aCollection.
	^newCollection

"	Bag newFrom: {1. 2. 3}
	{1. 2. 3} as: Bag
"! !Object subclass: #Behavior
	instanceVariableNames: 'superclass methodDict format subclasses '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
Behavior comment:
'My instances describe the behavior of other objects. I provide the minimum state necessary for compiling methods, and creating and running instances. Most objects are created as instances of the more fully supported subclass, Class, but I am a good starting point for providing instance-specific behavior (as in Metaclass).'!

!Behavior methodsFor: 'initialize-release'!
obsolete
	"Invalidate and recycle local messages. Remove the receiver from its 
	superclass' subclass list."

	methodDict _ MethodDictionary new.
	superclass removeSubclass: self! !

!Behavior methodsFor: 'accessing'!
compilerClass
	"Answer a compiler class appropriate for source methods of this class."

	^Compiler!
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. 1/17/96 sw
	9/18/96 sw: made the wording more delicate"

	| count aMenu answer caption allCalls |
	(count _ (allCalls _ Smalltalk allCallsOn: aSelector) size) > 0
		ifTrue:
			[aMenu _ PopUpMenu labels: 'Remove it
Remove, then browse senders
Don''t remove, but show me those senders
Forget it -- do nothing -- sorry I asked'.

			caption _ 'This message has ', count printString, ' sender'.
			count > 1 ifTrue:
				[caption _ caption copyWith: $s].
			answer _ aMenu startUpWithCaption: caption.
			answer == 3 ifTrue:
				[Smalltalk browseMessageList: allCalls
					name: 'Senders of ', aSelector
					autoSelect: aSelector].
			answer == 0 ifTrue: [answer _ 3].  "If user didn't answer, treat it as cancel"
			^ answer min: 3]
		ifFalse:
			[^ 1]
	!
decompilerClass
	"Answer a decompiler class appropriate for compiled methods of this class."

	^Decompiler!
evaluatorClass
	"Answer an evaluator class appropriate for evaluating expressions in the 
	context of this class."

	^Compiler!
format
	"Answer an Integer that encodes the kinds and numbers of variables of 
	instances of the receiver."

	^format!
parserClass
	"Answer a parser class to use for parsing method headers."

	^self compilerClass parserClass!
sourceCodeTemplate
	"Answer an expression to be edited and evaluated in order to define 
	methods in this class."

	^'message selector and argument names
	"comment stating purpose of message"

	| temporary variable names |
	statements'!
subclassDefinerClass
	"Answer an evaluator class appropriate for evaluating definitions of new 
	subclasses of this class."

	^Compiler! !

!Behavior methodsFor: 'testing'!
instSize
	"Answer the number of named instance variables
	(as opposed to indexed variables) of the receiver."

	^ ((format bitShift: -1) bitAnd: 16r3F) - 1!
instSpec
	^ (format bitShift: -7) bitAnd: 16rF!
isBits
	"Answer whether the receiver contains just bits (not pointers)."

	^ self instSpec >= 6!
isBytes
	"Answer whether the receiver has 8-bit instance variables."

	^ self instSpec >= 8!
isFixed
	"Answer whether the receiver does not have a variable (indexable) part."

	^self isVariable not!
isPointers
	"Answer whether the receiver contains just pointers (not bits)."

	^self isBits not!
isVariable
	"Answer whether the receiver has indexable variables."

	^ self instSpec >= 2!
isWords
	"Answer whether the receiver has 16-bit instance variables."

	^self isBytes not! !

!Behavior methodsFor: 'copying'!
copy
	"Answer a copy of the receiver without a list of subclasses."

	| myCopy savedSubclasses |
	savedSubclasses _ subclasses.
	subclasses _ nil. 		
	myCopy _ self shallowCopy.
	subclasses _ savedSubclasses.
	^myCopy methodDictionary: methodDict copy! !

!Behavior methodsFor: 'printing'!
literalScannedAs: scannedLiteral notifying: requestor
	"Postprocesses a literal scanned by Scanner scanToken (esp. xLitQuote).
	If scannedLiteral is not an association, answer it.
	Else, if it is of the form:
		nil->#NameOfMetaclass
	answer nil->theMetaclass, if any has that name, else report an error.
	Else, if it is of the form:
		#NameOfGlobalVariable->anythiEng
	answer the global, class, or pool association with that nameE, if any, else
	add it to Undeclared a answer the new Association."

	| key value |
	(scannedLiteral isMemberOf: Association)
		ifFalse: [^ scannedLiteral].
	key _ scannedLiteral key.
	value _ scannedLiteral value.
	key isNil 
		ifTrue: "###<metaclass soleInstance name>"
			[self scopeHas: value ifTrue:
				[:assoc |
				 (assoc value isKindOf: Behavior)
					ifTrue: [^ nil->assoc value class]].
			 requestor notify: 'No such metaclass'.
			 ^false].
	(key isMemberOf: Symbol)
		ifTrue: "##<global var name>"
			[(self scopeHas: key ifTrue: [:assoc | ^assoc])
				ifFalse:
					[Undeclared at: key put: nil.
					 ^ Undeclared associationAt: key]].
	requestor notify: '## must be followed by a non-local variable name'.
	^false

"	Form literalScannedAs: 14 notifying: nil 14
	Form literalScannedAs: #OneBitForm notiEfying: nil  OneBitForm
	Form literalScannedAs: ##OneBitForm notifying: nil  OneBitForm->a Form
	Form literalScannedAs: ##Form notifying: nil   Form->Form
	Form literalScannedAs: ###Form notifying: nil   nilE->Form class
"!
printHierarchy
	"Answer a description containing the names and instance variable names 
	of all of the subclasses and superclasses of the receiver."

	| aStream index |
	index _ 0.
	aStream _ WriteStream on: (String new: 16).
	self allSuperclasses reverseDo: 
		[:aClass | 
		aStream crtab: index.
		index _ index + 1.
		aStream nextPutAll: aClass name.
		aStream space.
		aStream print: aClass instVarNames].
	aStream cr.
	self printSubclassesOn: aStream level: index.
	^aStream contents!
printOn: aStream 
	"Refer to the comment in Object|printOn:." 

	aStream nextPutAll: 'a descendent of '.
	superclass printOn: aStream!
storeLiteral: aCodeLiteral on: aStream
	"Store aCodeLiteral on aStream, changing an Association to ##GlobalName
	 or ###MetaclassSoleInstanceName format if appropriate"
	| key value |
	(aCodeLiteral isMemberOf: Association)
		ifFalse:
			[aCodeLiteral storeOn: aStream.
			 ^self].
	key _ aCodeLiteral key.
	(key isNil and: [(value _ aCodeLiteral value) isMemberOf: Metaclass])
		ifTrue:
			[aStream nextPutAll: '###'; nextPutAll: value soleInstance name.
			 ^self].
	((key isMemberOf: Symbol) and: [self scopeHas: key ifTrue: [:ignore]])
		ifTrue:
			[aStream nextPutAll: '##'; nextPutAll: key.
			 ^self].
	aCodeLiteral storeOn: aStream! !

!Behavior methodsFor: 'creating class hierarchy'!
addSubclass: aSubclass 
	"Make the argument, aSubclass, be one of the subclasses of the receiver. 
	Create an error notification if the argument's superclass is not the 
	receiver."
	
	aSubclass superclass ~~ self 
		ifTrue: [self error: aSubclass name , ' is not my subclass']
		ifFalse: [subclasses == nil
					ifTrue:	[subclasses _ Set with: aSubclass]
					ifFalse:	[subclasses add: aSubclass]]!
removeSubclass: aSubclass 
	"If the argument, aSubclass, is one of the receiver's subclasses, remove it."

	subclasses == nil ifFalse:
		[subclasses remove: aSubclass ifAbsent: [].
		subclasses isEmpty ifTrue: [subclasses _ nil]]!
superclass: aClass 
	"Change the receiver's superclass to be aClass."

	(aClass isKindOf: Behavior)
		ifTrue: [superclass _ aClass]
		ifFalse: [self error: 'superclass must be a class-describing object']! !

!Behavior methodsFor: 'creating method dictionary'!
addSelector: selector withMethod: compiledMethod 
	"Add the message selector with the corresponding compiled method to the 
	receiver's method dictionary."

	methodDict at: selector put: compiledMethod.
	self flushCache!
compile: code 
	"Compile the argument, code, as source code in the context of the 
	receiver. Create an error notification if the code can not be compiled. 
	The argument is either a string or an object that converts to a string or a 
	PositionableStream on an object that converts to a string."

	^self compile: code notifying: nil!
compile: code notifying: requestor 
	"Compile the argument, code, as source code in the context of the 
	receiver and insEtall the result in the receiver's method dictionary. The 
	second argument, requestor, is to be notified if an error occurs. The 
	argument code is either a striEng or an object that converts to a string or 
	a PEositionableStrean an object that converts to a string. This method 
	also saves the source code."

	| method selector |
	method _ self
		compile: code
		notifying: requestor
		trailer: #(0 0 0 )
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :methodNode | selector _ sel].
	method putSource: code asString inFile: 2.
	^selector!
compile: code notifying: requestor trailer: bytes 
	"Compile the argument, code, as source code in the context of the 
	receiver. Use the default faiEl code [^nil]. Does not save source code. Th 
	second argument, requestor, is to be notified if an error occurs. The 
	argument code is either a string or an object that converts to a string or 
	a PositionableStream on an object that converts to a string. The third 
	argument, bytes, is a trailer, that is, an array of three bytes that should 
	be added to the end of the compiled method. These point to the location 
	of the source code (on a file)."

	^ self compile: code notifying: requestor trailer: bytes
		ifFail: [^ nil]
		elseSetSelectorAndNode: [:s :n]!
compileAll
	^ self compileAllFrom: self!
compileAllFrom: oldClass
	"Compile all the methods in the receiver's method dictionary.
	This validates sourceCode and variable references and forces
	all methods to use the current bytecode set"

	self selectorsDo: [:sel | self recompile: sel from: oldClass]!
decompile: selector 
	"Find the compiled code associated with the argument, selector, as a 
	message selector in the receiver's method dictionary and decompile it. 
	Answer the resulting source code as a string. Create an error notification 
	if the selector is not in the receiver's method dictionary."

	^self decompilerClass new decompile: selector in: self!
defaultSelectorForMethod: aMethod 
	"Given a method, invent and answer an appropriate message selector (a 
	Symbol), that is, one that will parse with the correct number of 
	arguments."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	aStream nextPutAll: 'DoIt'.
	1 to: aMethod numArgs do: [:i | aStream nextPutAll: 'with:'].
	^aStream contents asSymbol!
methodDictionary: aDictionary 
	"Store the argument, aDictionary, as the method dictionary of the 
	receiver."

	methodDict _ aDictionary!
recompile: selector from: oldClass
	"Compile the method associated with selector in the receiver's method dictionary."

	| method trailer methodNode |
	method _ self compiledMethodAt: selector.
	trailer _ (method size - 2 to: method size) collect: [:i | method at: i].
	methodNode _ self compilerClass new
				compile: (oldClass sourceCodeAt: selector)
				in: self
				notifying: nil
				ifFail: [].
	methodNode == nil  "Try again after proceed from SyntaxError"
		ifTrue: [^self recompile: selector from: oldClass].
	selector == methodNode selector ifFalse: [self error: 'selector changed!!'].
	self addSelector: selector withMethod: (methodNode generate: trailer).
!
recompileChanges
	"Compile all the methods that are in the changes file.
	This validates sourceCode and variable references and forces
	methods to use the current bytecode set"

	self selectorsDo:
		[:sel | (self compiledMethodAt: sel) fileIndex > 1 ifTrue:
			[self recompile: sel from: self]]!
removeSelector: selector 
	"Assuming that the argument, selector (a Symbol), is a message selector 
	in the receiver's method dictionary, remove it. If the selector is not in 
	the method dictionary, create an error notification."

	methodDict removeKey: selector.
	self flushCache! !

!Behavior methodsFor: 'instance creation'!
basicNew
	"Primitive. Answer an instance of the receiver (which is a class) with no 
	indexable variables. Fail if the class is indexable. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 70>
	self isVariable ifTrue: [ ^ self basicNew: 0 ].
	"space must be low"
	Smalltalk signalLowSpace.
	^ self basicNew  "retry if user proceeds"
!
basicNew: anInteger 
	"Primitive. Answer an instance of the receiver (which is a class) with the 
	number of indexable variables specified by the argument, anInteger. Fail 
	if the class is not indexable or if the argument is not a positive Integer. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 71>
	(anInteger isInteger and: [anInteger >= 0]) ifTrue: [
		"arg okay; space must be low"
		Smalltalk signalLowSpace.
		^ self basicNew: anInteger  "retry if user proceeds"
	].
	self primitiveFailed!
new
	"Primitive. Answer an instance of the receiver (which is a class) with no 
	indexable variables. Fail if the class is indexable. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 70>
	self isVariable ifTrue: [ ^ self new: 0 ].
	"space must be low"
	Smalltalk signalLowSpace.
	^ self new  "retry if user proceeds"
!
new: anInteger 
	"Primitive. Answer an instance of the receiver (which is a class) with the 
	number of indexable variables specified by the argument, anInteger. Fail 
	if the class is not indexable or if the argument is not a positive Integer. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 71>
	(anInteger isInteger and: [anInteger >= 0]) ifTrue: [
		"arg okay; space must be low"
		Smalltalk signalLowSpace.
		^ self new: anInteger  "retry if user proceeds"
	].
	self primitiveFailed! !

!Behavior methodsFor: 'accessing class hierarchy'!
allSubclasses
	"Answer a Set of the receiver's and the receiver's descendent's subclasses."

	| aSet |
	aSet _ Set new.
	aSet addAll: self subclasses.
	self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
	^aSet!
allSuperclasses
	"Answer an OrderedCollection of the receiver's and the receiver's 
	ancestor's superclasses. The first element is the receiver's immediate 
	superclass, followed by its superclass; the last element is Object."

	| temp |
	superclass == nil
		ifTrue: [^OrderedCollection new]
		ifFalse: [temp _ superclass allSuperclasses.
				temp addFirst: superclass.
				^temp]!
subclasses
	"Answer a Set containing the receiver's subclasses."

	subclasses == nil
		ifTrue: [^Set new]
		ifFalse: [^subclasses copy]!
superclass
	"Answer the receiver's superclass, a Class."

	^superclass!
withAllSubclasses
	"Answer a Set of the receiver, the receiver's descendent's, and the 
	receiver's descendent's subclasses."

	| aSet |
	aSet _ Set with: self.
	aSet addAll: self subclasses.
	self subclasses do: [:eachSubclass | aSet addAll: eachSubclass allSubclasses].
	^aSet!
withAllSuperclasses
	"Answer an OrderedCollection of the receiver and the receiver's 
	superclasses. The first element is the receiver, 
	followed by its superclass; the last element is Object."

	| temp |
	temp _ self allSuperclasses.
	temp addFirst: self.
	^ temp! !

!Behavior methodsFor: 'accessing method dictionary'!
allSelectors
	"Answer a Set of all the message selectors that instances of the receiver 
	can understand."

	| temp |
	superclass == nil
		ifTrue: [^self selectors]
		ifFalse: [temp _ superclass allSelectors.
				temp addAll: self selectors.
				^temp]

	"Point allSelectors"!
changeRecordsAt: selector
	"Return a list of ChangeRecords for all versions of the method at selector.
	Source code can be retrieved by sending string to any one"
	"(Pen changeRecordsAt: #go:) collect: [:cRec | cRec string]"
	^ (ChangeList new
			scanVersionsOf: (self compiledMethodAt: selector)
			class: self meta: self isMeta
			category: (self whichCategoryIncludesSelector: selector)
			selector: selector)
		changeList!
compiledMethodAt: selector 
	"Answer the compiled method associated with the argument, selector (a 
	Symbol), a message selector in the receiver's method dictionary. If the 
	selector is not in the dictionary, create an error notification."

	^methodDict at: selector!
compressedSourceCodeAt: selector
	"(Paragraph compressedSourceCodeAt: #displayLines:affectedRectangle:) size 721 1921
	Paragraph selectors inject: 0 into: [:tot :sel | tot + (Paragraph compressedSourceCodeAt: sel) size] 13606 31450"
	| rawText parse |
	rawText _ self sourceCodeAt: selector.
	parse _ self compilerClass new parse: rawText in: self notifying: nil.
	^ rawText compressWithTable:
		((selector keywords ,
		parse tempNames ,
		self instVarNames ,
		#(self super ifTrue: ifFalse:) ,
		((0 to: 7) collect:
			[:i | String streamContents:
				[:s | s cr. i timesRepeat: [s tab]]]) ,
		(self compiledMethodAt: selector) literalStrings)
			asSortedCollection: [:a :b | a size > b size])!
copySourceCodeAt: selector to: aFileStream
	| code method dict |
	method _ methodDict at: selector.
	(Sensor leftShiftDown or: [(method copySourceTo: aFileStream) == false])
		ifTrue: [aFileStream nextChunkPut: (self decompilerClass new
					decompile: selector
					in: self
					method: method) decompileString]
!
firstCommentAt:  selector
	"Answer a string representing the first comment in the method associated with selector.  Return an empty string if the relevant source file is not available, or if the method's source code does not contain a comment.  Not smart enough to bypass quotes in string constants, but ""clever"" enough to map doubled quotes into a single quote.  5/1/96 sw"
	"Behavior firstCommentAt: #firstCommentAt:"

	| sourceString commentStart  pos nextQuotePos |

	sourceString _ self sourceCodeAt: selector.
	sourceString size == 0 ifTrue: [^ ''].
	commentStart _ sourceString findString: '"' startingAt: 1.
	commentStart == 0 ifTrue: [^ ''].
	pos _ commentStart + 1.
	[(nextQuotePos _ sourceString findString: '"' startingAt: pos) == (sourceString findString: '""' startingAt: pos)]
		whileTrue:
			[pos _ nextQuotePos + 2].
			
	^ (sourceString copyFrom: commentStart + 1 to: nextQuotePos - 1) copyReplaceAll: '""' with: '"'!
selectorAtMethod: method setClass: classResultBlock 
	"Answer both the message selector associated with the compiled method 
	and the class in which that selector is defined."

	| sel |
	sel _ methodDict keyAtValue: method
				ifAbsent: 
					[superclass == nil
						ifTrue: 
							[classResultBlock value: self.
							^self defaultSelectorForMethod: method].
					sel _ superclass selectorAtMethod: method setClass: classResultBlock.
					"Set class to be self, rather than that returned from 
					superclass. "
					sel == (self defaultSelectorForMethod: method) ifTrue: [classResultBlock value: self].
					^sel].
	classResultBlock value: self.
	^sel!
selectors
	"Answer a Set of all the message selectors specified in the receiver's 
	method dictionary."

	^methodDict keys  

	"Point selectors."!
selectorsDo: selectorBlock
	"Evaluate selectorBlock for all the message selectors in my method dictionary."

	^methodDict keysDo: selectorBlock!
sourceCodeAt: selector
	| code method dict |
	method _ methodDict at: selector.
	Sensor leftShiftDown
		ifTrue: [code _ (self decompilerClass new
						decompile: selector
						in: self
						method: method) decompileString]
		ifFalse: 
			[code _ method getSource.
			code == nil
				ifTrue: 
					[code _ (self decompilerClass new
									decompile: selector
									in: self
									method: method) decompileString]].
	^code!
sourceMethodAt: selector 
	"Answer the paragraph corresponding to the source code for the 
	argument."

	^(self sourceCodeAt: selector) asText makeSelectorBoldIn: self! !

!Behavior methodsFor: 'accessing instances and variables'!
allClassVarNames
	"Answer a Set of the names of the receiver's and the receiver's ancestor's 
	class variables."

	^superclass allClassVarNames!
allInstances 
	"Answer a Set of all current instances of the receiver."

	| aCollection |
	aCollection _ OrderedCollection new.
	self allInstancesDo:
		[:x | x == aCollection ifFalse: [aCollection add: x]].
	^aCollection!
allInstVarNames
	"Answer an Array of the names of the receiver's instance variables. The 
	Array ordering is the order in which the variables are stored and 
	accessed by the interpreter."

	| vars |
	superclass == nil
		ifTrue: [vars _ self instVarNames copy]	"Guarantee a copy is answered."
		ifFalse: [vars _ superclass allInstVarNames , self instVarNames].
	^vars!
allSharedPools
	"Answer a Set of the names of the pools (Dictionaries) that the receiver 
	and the receiver's ancestors share."

	^superclass allSharedPools!
allSubInstances 
	"Answer a list of all current instances of the receiver and all of its subclasses.  1/26/96 sw."

	| aCollection |
	aCollection _ self allInstances.
	self allSubInstancesDo:
		[:x | x == aCollection ifFalse: [aCollection add: x]].
	^ aCollection!
classVarNames
	"Answer a Set of the receiver's class variable names."

	^Set new!
inspectAllInstances 
	"Inpsect all instances of the receiver.  1/26/96 sw"

	| all allSize prefix |
	all _ self allInstances.
	(allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no 
instances of ', self name].
	prefix _ allSize == 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name)!
inspectSubInstances 
	"Inspect all instances of the receiver and all its subclasses.  CAUTION - don't do this for something as generic as Object!!  1/26/96 sw"

	| all allSize prefix |
	all _ self allSubInstances.
	(allSize _ all size) == 0 ifTrue: [^ self notify: 'There are no 
instances of ', self name, '
or any of its subclasses'].
	prefix _ allSize == 1
		ifTrue: 	['The lone instance']
		ifFalse:	['The ', allSize printString, ' instances'].
	
	all asArray inspectWithLabel: (prefix, ' of ', self name, ' & its subclasses')!
instanceCount
	"Answer the number of instances of the receiver that are currently in 
	use."

	| count |
	count _ 0.
	self allInstancesDo: [:x | count _ count + 1].
	^count!
instVarNames
	"Answer an Array of the instance variable names. Behaviors must make 
	up fake local instance variable names because Behaviors have instance 
	variables for the purpose of compiling methods, but these are not named 
	instance variables."

	| mySize superSize |
	mySize _ self instSize.
	superSize _ 
		superclass == nil
			ifTrue: [0]
			ifFalse: [superclass instSize].
	mySize = superSize ifTrue: [^#()].	
	^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]!
sharedPools
	"Answer a Set of the names of the pools (Dictionaries) that the receiver 
	shares.
	9/12/96 tk  sharedPools have an order now"

	^ OrderedCollection new!
someInstance
	"Primitive. Answer the first instance in the enumeration of all instances 
	of the receiver. Fails if there are none. Essential. See Object 
	documentation whatIsAPrimitive."

	<primitive: 77>
	^nil!
subclassInstVarNames
	"Answer a Set of the names of the receiver's subclasses' instance 
	variables."
	| vars |
	vars _ Set new.
	self allSubclasses do: [:aSubclass | vars addAll: aSubclass instVarNames].
	^vars! !

!Behavior methodsFor: 'testing class hierarchy'!
inheritsFrom: aClass 
	"Answer whether the argument, aClass, is on the receiver's superclass 
	chain."

	| aSuperclass |
	aSuperclass _ superclass.
	[aSuperclass == nil]
		whileFalse: 
			[aSuperclass == aClass ifTrue: [^true].
			aSuperclass _ aSuperclass superclass].
	^false!
kindOfSubclass 
	"Answer a String that is the keyword that describes the receiver's kind of 
	subclass, either a regular subclass, a variableSubclass, a 
	variableByteSubclass, or a variableWordSubclass."

	self isVariable
		ifTrue: [self isBits
					ifTrue: [self isBytes
								ifTrue: [^' variableByteSubclass: ']
								ifFalse: [^' variableWordSubclass: ']]
					ifFalse: [^' variableSubclass: ']]
		ifFalse: [^' subclass: ']! !

!Behavior methodsFor: 'testing method dictionary'!
allUnsentMessages
	"Answer an array of all the messages defined by the receiver that are not sent anywhere in the system.  5/8/96 sw"

	^ Smalltalk allUnSentMessagesIn: self selectors!
canUnderstand: selector 
	"Answer whether the receiver can respond to the message whose selector 
	is the argument. The selector can be in the method dictionary of the 
	receiver's class or any of its superclasses."

	(self includesSelector: selector) ifTrue: [^true].
	superclass == nil ifTrue: [^false].
	^superclass canUnderstand: selector!
hasMethods
	"Answer whether the receiver has any methods in its method dictionary."

	^methodDict size > 0!
includesSelector: aSymbol 
	"Answer whether the message whose selector is the argument is in the 
	method dictionary of the receiver's class."

	^methodDict includesKey: aSymbol!
scopeHas: name ifTrue: assocBlock 
	"If the argument name is a variable known to the receiver, then evaluate 
	the second argument, assocBlock."

	^superclass scopeHas: name ifTrue: assocBlock!
whichClassIncludesSelector: aSymbol 
	"Answer the class on the receiver's superclass chain where the argument, 
	aSymbol (a message selector), will be found. Answer nil if none found."

	(methodDict includesKey: aSymbol) ifTrue: [^self].
	superclass == nil ifTrue: [^nil].
	^superclass whichClassIncludesSelector: aSymbol

	"Rectangle whichClassIncludesSelector: #inspect."!
whichSelectorsAccess: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."

	| instVarIndex |
	instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
	^methodDict keys select: 
		[:sel | 
		((methodDict at: sel)
			readsField: instVarIndex)
			or: [(methodDict at: sel) writesField: instVarIndex]]

	"Point whichSelectorsAccess: 'x'."!
whichSelectorsReferTo: literal 
	"Answer a Set of selectors whose methods access the argument as a literal."

	| special |
	special _ Smalltalk hasSpecialSelector: literal ifTrueSetByte: [:byte ].
	^self whichSelectorsReferTo: literal special: special byte: byte

	"Rectangle whichSelectorsReferTo: #+."!
whichSelectorsReferTo: literal special: specialFlag byte: specialByte
	"Answer a set of selectors whose methods access the argument as a literal."
	| who method methodArray |
	who _ Set new.
	methodDict associationsDo:
		[:assn |
		method _ assn value.
		((method pointsTo: literal "faster than hasLiteral:") or:
				[specialFlag and: [method scanFor: specialByte]])
			ifTrue:
			[((literal isKindOf: Association) not
				or: [method sendsToSuper not
					or: [(method literals copyFrom: 1
						to: method numLiterals-1)
							includes: literal]])
				ifTrue: [who add: assn key]]].
	^who!
whichSelectorsStoreInto: instVarName 
	"Answer a Set of selectors whose methods access the argument, 
	instVarName, as a named instance variable."
	| instVarIndex |
	instVarIndex _ self allInstVarNames indexOf: instVarName ifAbsent: [^Set new].
	^ methodDict keys select: 
		[:sel | (methodDict at: sel) writesField: instVarIndex]

	"Point whichSelectorsStoreInto: 'x'."! !

!Behavior methodsFor: 'enumerating'!
allInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver."
	| inst next |
	self ==  UndefinedObject ifTrue: [^ aBlock value: nil].
	inst _ self someInstance.
	[inst == nil]
		whileFalse:
		[aBlock value: inst.
		inst _ inst nextInstance]!
allSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's subclasses."

	self subclassesDo: 
		[:cl | 
		aBlock value: cl.
		cl allSubclassesDo: aBlock]!
allSubInstancesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the current instances of the 
	receiver's subclasses."

	self allSubclassesDo: [:sub | sub allInstancesDo: aBlock]!
allSuperclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's superclasses."

	superclass == nil
		ifFalse: [aBlock value: superclass.
				superclass allSuperclassesDo: aBlock]!
selectSubclasses: aBlock 
	"Evaluate the argument, aBlock, with each of the receiver's (next level) 
	subclasses as its argument. Collect into a Set only those subclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	subclasses of each of these successful subclasses and collect into the set 
	those for which aBlock evaluates true. Answer the resulting set."

	| aSet |
	aSet _ Set new.
	self allSubclasses do: 
		[:aSubclass | 
		(aBlock value: aSubclass) ifTrue: [aSet add: aSubclass]].
	^aSet!
selectSuperclasses: aBlock 
	"Evaluate the argument, aBlock, with the receiver's superclasses as the 
	argument. Collect into an OrderedCollection only those superclasses for 
	which aBlock evaluates to true. In addition, evaluate aBlock for the 
	superclasses of each of these successful superclasses and collect into the 
	OrderedCollection ones for which aBlock evaluates to true. Answer the 
	resulting OrderedCollection."

	| aSet |
	aSet _ Set new.
	self allSuperclasses do: 
		[:aSuperclass | 
		(aBlock value: aSuperclass) ifTrue: [aSet add: aSuperclass]].
	^aSet!
subclassesDo: aBlock 
	"Evaluate the argument, aBlock, for each of the receiver's immediate subclasses."
	subclasses == nil ifFalse:
		[subclasses do: [:cl | aBlock value: cl]]!
withAllSubclassesDo: aBlock 
	"Evaluate the argument, aBlock, for the receiver and each of its 
	subclasses."

	aBlock value: self.
	self allSubclassesDo: aBlock! !

!Behavior methodsFor: 'user interface'!
allCallsOn: aSymbol
	"Answer a SortedCollection of all the methods that call on aSymbol."

	| aSortedCollection special |
	aSortedCollection _ SortedCollection new.
	special _ Smalltalk hasSpecialSelector: aSymbol ifTrueSetByte: [:byte ].
	self withAllSubclassesDo:
		[:class | (class whichSelectorsReferTo: aSymbol special: special byte: byte) do:
			[:sel | sel ~~ #DoIt ifTrue: [aSortedCollection add: class name , ' ' , sel]]].
	^aSortedCollection!
browseAllAccessesTo: instVarName 	"Collection browseAllAccessesTo: 'contents'."
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass that refer to the instance variable name."
	| coll |
	coll _ OrderedCollection new.
	Cursor wait 
		showWhile: 
			[self withAllSubclasses do:
				[:class | 
				(class whichSelectorsAccess: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
			self allSuperclasses do:
				[:class | 
				(class whichSelectorsAccess: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
	^ Smalltalk browseMessageList: coll name: 'Accesses to ' , instVarName autoSelect: instVarName!
browseAllCallsOn: aSymbol 
	"Create and schedule a Message Set browser for all the methods that call 
	on aSymbol."
	| key label |
	(aSymbol isKindOf: LookupKey)
			ifTrue: [label _ 'Users of ' , (key _ aSymbol key)]
			ifFalse: [label _ 'Senders of ' , (key _ aSymbol)].
	^ Smalltalk browseMessageList: (self allCallsOn: aSymbol) asSortedCollection
		name: label autoSelect: key

	"Number browseAllCallsOn: #/."!
browseAllStoresInto: instVarName 	"Collection browseAllStoresInto: 'contents'."
	"Create and schedule a Message Set browser for all the receiver's methods 
	or any methods of a subclass that refer to the instance variable name."
	| coll |
	coll _ OrderedCollection new.
	Cursor wait 
		showWhile: 
			[self withAllSubclasses do:
				[:class | 
				(class whichSelectorsStoreInto: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]].
			self allSuperclasses do:
				[:class | 
				(class whichSelectorsStoreInto: instVarName) do: 
					[:sel | sel ~~ #DoIt ifTrue: [coll add: class name , ' ' , sel]]]].
	^ Smalltalk browseMessageList: coll name: 'Stores into ' , instVarName autoSelect: instVarName!
crossReference
	"Answer an Array of arrays of size 2 whose first element is a message selector in the receiver's method dictionary and whose second element is a set of all message selectors in the method dictionary whose methods send a message with that selector. Subclasses are not included."

	^self selectors asSortedCollection asArray collect: [:x | 		Array 
			with: (String with: Character cr), x 
			with: (self whichSelectorsReferTo: x)]

	"Point crossReference."!
unreferencedInstanceVariables
	"Return a list of the instance variables defined in the receiver which are not referenced in the receiver or any of its subclasses.  2/26/96 sw"

	| any |

	^ self instVarNames copy reject:
		[:ivn | any _ false.
		self withAllSubclasses do:
			[:class |  (class whichSelectorsAccess: ivn) do: 
					[:sel | sel ~~ #DoIt ifTrue: [any _ true]]].
		any]

"Ob unreferencedInstanceVariables"! !

!Behavior methodsFor: 'fileIn/Out'!
printMethodChunk: selector on: aFileStream moveSource: moveSource toFile: fileIndex
	"Print the source code for the method associated with the argument 
	selector onto the fileStream. aFileStream, and, for backup, if the 
	argument moveSource (a Boolean) is true, also set the file index within 
	the method to be the argument fileIndex."

	| position |
	aFileStream cr; cr.
	moveSource ifTrue: [position _ aFileStream position].
	self copySourceCodeAt: selector to: aFileStream.
	moveSource 
		ifTrue: [(self compiledMethodAt: selector)
					setSourcePosition: position inFile: fileIndex]! !

!Behavior methodsFor: 'private'!
becomeCompact
	| cct index |
	cct _ Smalltalk compactClassesArray.
	(self indexIfCompact > 0 or: [cct includes: self])
		ifTrue: [^ self halt: self name , 'is already compact'].
	index _ cct indexOf: nil
		ifAbsent: [^ self halt: 'compact class table is full'].
	"Install this class in the compact class table"
	cct at: index put: self.
	"Update instspec so future instances will be compact"
	format _ format + (index bitShift: 11).
	"Make up new instances and become old ones into them"
	self updateInstancesFrom: self.
	"Purge any old instances"
	Smalltalk garbageCollect.!
becomeUncompact
	| cct index |
	cct _ Smalltalk compactClassesArray.
	(index _ self indexIfCompact) = 0
		ifTrue: [^ self].
	(cct includes: self)
		ifFalse: [^ self halt  "inconsistent state"].
	"Update instspec so future instances will not be compact"
	format _ format - (index bitShift: 11).
	"Make up new instances and become old ones into them"
	self updateInstancesFrom: self.
	"Make sure there are no compact ones left around"
	Smalltalk garbageCollect.
	"Remove this class from the compact class table"
	cct at: index put: nil.
!
flushCache
	"Tell the interpreter to remove the contents of its method lookup cache, if it has 
	one.  Essential.  See Object documentation whatIsAPrimitive."

	<primitive: 89>
	self primitiveFailed!
format: nInstVars variable: isVar words: isWords pointers: isPointers 
	"Set the format for the receiver (a Class)."
	| cClass instSpec |
	"<5 bits=cClass><4 bits=instSpec><6 bits=instSize> all shifted left 1"
	cClass _ 0.  "for now"
	instSpec _ isPointers
		ifTrue: [isVar
				ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]]
				ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]]
		ifFalse: [isWords ifTrue: [6] ifFalse: [8]].
	format _ cClass.
	format _ (format bitShift: 4) + instSpec.
	format _ (format bitShift: 6) + nInstVars+1.
	format _ (format bitShift: 1)!
indexIfCompact
	"If these 5 bits are non-zero, then instances of this class
	will be compact.  It is crucial that there be an entry in
	Smalltalk compactClassesArray for any class so optimized.
	See the msgs becomeCompact and becomeUncompact."
	^ (format bitShift: -11) bitAnd: 16r1F
"
Smalltalk compactClassesArray doWithIndex: 
	[:c :i | c == nil ifFalse:
		[c indexIfCompact = i ifFalse: [self halt]]]
"!
printSubclassesOn: aStream level: level 
	"As part of the algorithm for printing a description of the receiver, print the
	subclass on the file stream, aStream, indenting level times."

	| subclassNames subclass |
	aStream crtab: level.
	aStream nextPutAll: self name.
	aStream space; print: self instVarNames.
	self == Class
		ifTrue: 
			[aStream crtab: level + 1; nextPutAll: '[ ... all the Metaclasses ... ]'.
			^self].
	subclassNames _ self subclasses collect: [:subC | subC name].
	"Print subclasses in alphabetical order"
	subclassNames asSortedCollection do:
		[:name |
		subclass _ self subclasses detect: [:subC | subC name = name].
		subclass printSubclassesOn: aStream level: level + 1]!
removeSelectorSimply: selector 
	"Remove the message selector from the receiver's method dictionary.
	Internal access from compiler."

	methodDict removeKey: selector ifAbsent: [^self].
	self flushCache!
sourceTextAt: selector 
	^(self sourceCodeAt: selector) asText! !Object subclass: #BitBlt
	instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Support'!
BitBlt comment:
'I represent a block transfer (BLT) of pixels into a rectangle (destX, destY, width, height) of the destinationForm.  The source of pixels may be a similar rectangle (at sourceX, sourceY) in the sourceForm, or a constant color, currently called halftoneForm.  If both are specified, their pixel values are combined with a logical AND function prior to transfer.  In any case, the pixels from the source are combined with those of the destination by as specified by the combinationRule.

The combination rule whose value is 0 through 15 programs the transfer to produce 1 or 0 according to its 4-bit representation as follows:
	8:	if source is 0 and destination is 0
	4:	if source is 0 and destination is 1
	2:	if source is 1 and destination is 0
	1:	if source is 1 and destination is 1.
At each pixel the corresponding bits of the source and destination pixel values determine one of these conditions;  if the combination rule has a 1 in the corresponding bit position, then the new destination value will be 1, otherwise it will be zero.
	Combination rule 16 is "paint bits".  It uses the 1-bit deep sourceForm to cut a hole in the destination.  Then it ORs in the sourceForm using the fillColor.
	Combination rule 17 is "erase bits".  The source Form must be 1 bit deep.  It is used to cut a hole (put in zeros) in the destination Form.
	Forms may be of different depths, see comment in class Form.

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.
	Colors can be remapped at the same depth.  Sometimes a Form is in terms of colors that are not the standard colors for this depth, for example in a GIF file.  Convert the Form to a MaskedForm and send colorMap: the list of colors that the picture is in terms of.  MaskedForm will use the colorMap when copying to the display or another Form. (Note also that a Form can be copied to itself, and transformed in the process, if a non-nil colorMap is supplied.)'!

!BitBlt methodsFor: 'accessing'!
clipHeight: anInteger 
	"Set the receiver's clipping area height to be the argument, anInteger."

	clipHeight _ anInteger!
clipRect
	"Answer the receiver's clipping area rectangle."

	^clipX @ clipY extent: clipWidth @ clipHeight!
clipRect: aRectangle 
	"Set the receiver's clipping area rectangle to be the argument, aRectangle."

	clipX _ aRectangle left.
	clipY _ aRectangle top.
	clipWidth _ aRectangle width.
	clipHeight _ aRectangle height!
clipWidth: anInteger 
	"Set the receiver's clipping area width to be the argument, anInteger."

	clipWidth _ anInteger!
clipX: anInteger 
	"Set the receiver's clipping area top left x coordinate to be the argument, 
	anInteger."

	clipX _ anInteger!
clipY: anInteger 
	"Set the receiver's clipping area top left y coordinate to be the argument, 
	anInteger."

	clipY _ anInteger!
colorMap: map
	"See last part of BitBlt comment. 6/18/96 tk"
	colorMap _ map!
combinationRule: anInteger 
	"Set the receiver's combination rule to be the argument, anInteger, a 
	number in the range 0-15."

	combinationRule _ anInteger!
destForm
	^ destForm!
destOrigin: aPoint 
	"Set the receiver's destination top left coordinates to be those of the 
	argument, aPoint."

	destX _ aPoint x.
	destY _ aPoint y!
destRect: aRectangle 
	"Set the receiver's destination form top left coordinates to be the origin of 
	the argument, aRectangle, and set the width and height of the receiver's 
	destination form to be the width and height of aRectangle."

	destX _ aRectangle left.
	destY _ aRectangle top.
	width _ aRectangle width.
	height _ aRectangle height!
destX: anInteger 
	"Set the top left x coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destX _ anInteger!
destY: anInteger 
	"Set the top left y coordinate of the receiver's destination form to be the 
	argument, anInteger."

	destY _ anInteger!
fillColor: aColorOrPattern 
	"The destForm will be filled with this color or pattern of colors.  May be an old Color, a new type Color, a Bitmap (see BitBlt comment), a Pattern, or a Form.  6/18/96 tk"

	aColorOrPattern == nil ifTrue: [halftoneForm _ nil. ^ self].
	destForm == nil ifTrue: [self error: 'Must set destForm first'].
	halftoneForm _ aColorOrPattern bitPatternForDepth: destForm depth!
height: anInteger 
	"Set the receiver's destination form height to be the argument, anInteger."

	height _ anInteger!
sourceForm: aForm 
	"Set the receiver's source form to be the argument, aForm."

	sourceForm _ aForm!
sourceOrigin: aPoint 
	"Set the receiver's source form coordinates to be those of the argument, 
	aPoint."

	sourceX _ aPoint x.
	sourceY _ aPoint y!
sourceRect: aRectangle 
	"Set the receiver's source form top left x and y, width and height to be 
	the top left coordinate and extent of the argument, aRectangle."

	sourceX _ aRectangle left.
	sourceY _ aRectangle top.
	width _ aRectangle width.
	height _ aRectangle height!
sourceX: anInteger 
	"Set the receiver's source form top left x to be the argument, anInteger."

	sourceX _ anInteger!
sourceY: anInteger 
	"Set the receiver's source form top left y to be the argument, anInteger."

	sourceY _ anInteger!
width: anInteger 
	"Set the receiver's destination form width to be the argument, anInteger."

	width _ anInteger! !

!BitBlt methodsFor: 'copying'!
copy: destRectangle from: sourcePt in: srcForm
	| destOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits!
copy: destRectangle from: sourcePt in: srcForm fillColor: hf rule: rule
	"Specify a Color to fill, not a Form. 6/18/96 tk"  
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.	"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	^ self copyBits!
copy: destRectangle from: sourcePt in: srcForm halftoneForm: hf rule: rule 
	| destOrigin |
	sourceForm _ srcForm.
	self fillColor: hf.		"sets halftoneForm"
	combinationRule _ rule.
	destOrigin _ destRectangle origin.
	destX _ destOrigin x.
	destY _ destOrigin y.
	sourceX _ sourcePt x.
	sourceY _ sourcePt y.
	width _ destRectangle width.
	height _ destRectangle height.
	self copyBits!
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 
	or Form) or if the combination rule is not between 0 and 15 inclusive. 
	Set the variables and try again (BitBlt|copyBitsAgain, also a Primitive). 
	Essential. See Object documentation whatIsAPrimitive."
	<primitive: 96>
	combinationRule = Form paint ifTrue: [^ self paintBits].
	combinationRule = Form erase1bitShape ifTrue: [^ self eraseBits].
	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!
copyForm: srcForm to: destPt rule: rule
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits!
copyForm: srcForm to: destPt rule: rule color: color
	sourceForm _ srcForm.
	halftoneForm _ color.
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits!
copyForm: srcForm to: destPt rule: rule fillColor: color
	sourceForm _ srcForm.
	self fillColor: color.	"sets halftoneForm"
	combinationRule _ rule.
	destX _ destPt x + sourceForm offset x.
	destY _ destPt y + sourceForm offset y.
	sourceX _ 0.
	sourceY _ 0.
	width _ sourceForm width.
	height _ sourceForm height.
	self copyBits!
copyFrom: sourceRectangle in: srcForm to: destPt
	| sourceOrigin |
	sourceForm _ srcForm.
	halftoneForm _ nil.
	combinationRule _ 3.  "store"
	destX _ destPt x.
	destY _ destPt y.
	sourceOrigin _ sourceRectangle origin.
	sourceX _ sourceOrigin x.
	sourceY _ sourceOrigin y.
	width _ sourceRectangle width.
	height _ sourceRectangle height.
	self copyBits!
fill: destRect fillColor: grayForm rule: rule
	"Fill with a Color, not a Form. 6/18/96 tk"
	sourceForm _ nil.
	self fillColor: grayForm.		"sets halftoneForm"
	combinationRule _ rule.
	destX _ destRect left.
	destY _ destRect top.
	sourceX _ 0.
	sourceY _ 0.
	width _ destRect width.
	height _ destRect height.
	self copyBits!
pixelAt: aPoint
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPeekerFromForm:.  Returns the pixel at aPoint."
	sourceX _ aPoint x.
	sourceY _ aPoint y.
	destForm bits at: 1 put: 0.  "Just to be sure"
	self copyBits.
	^ destForm bits at: 1!
pixelAt: aPoint put: pixelValue
	"Assumes this BitBlt has been set up specially (see the init message,
	BitBlt bitPokerToForm:.  Overwrites the pixel at aPoint."
	destX _ aPoint x.
	destY _ aPoint y.
	sourceForm bits at: 1 put: pixelValue.
	self copyBits
"
[Sensor anyButtonPressed] whileFalse:
	[Display valueAt: Sensor cursorPoint put: 55]
"! !

!BitBlt methodsFor: 'line drawing'!
drawFrom: startPoint to: stopPoint 
	"Draw a line whose end points are startPoint and stopPoint.
	The line is formed by repeatedly calling copyBits at every
	point along the line."
	| offset point1 point2 |
	"Always draw down, or at least left-to-right"
	((startPoint y = stopPoint y and: [startPoint x < stopPoint x])
		or: [startPoint y < stopPoint y])
		ifTrue: [point1 _ startPoint. point2 _ stopPoint]
		ifFalse: [point1 _ stopPoint. point2 _ startPoint].
	sourceForm == nil ifTrue:
		[destX _ (point1 x - (width//2)) rounded.
		destY _ (point1 y - (height//2)) rounded]
		ifFalse:
		[width _ sourceForm width.
		height _ sourceForm height.
		offset _ sourceForm offset.
		destX _ (point1 x + offset x) rounded.
		destY _ (point1 y + offset y) rounded].
	self drawLoopX: (point2 x - point1 x) rounded 
				  Y: (point2 y - point1 y) rounded!
drawLoopX: xDelta Y: yDelta 
	"Primitive. Implements the Bresenham plotting algorithm (IBM Systems
	Journal, Vol. 4 No. 1, 1965). It chooses a principal direction, and
	maintains a potential, P. When P's sign changes, it is time to move in the 
	minor direction as well. Optional. See Object documentation
	whatIsAPrimitive."

	| dx dy px py P |
	<primitive: 104>
	dx _ xDelta sign.
	dy _ yDelta sign.
	px _ yDelta abs.
	py _ xDelta abs.
	self copyBits.
	py > px
		ifTrue: 
			["more horizontal"
			P _ py // 2.
			1 to: py do: 
				[:i |
				destX _ destX + dx.
				(P _ P - px) < 0 ifTrue: 
						[destY _ destY + dy.
						P _ P + py].
				self copyBits]]
		ifFalse: 
			["more vertical"
			P _ px // 2.
			1 to: px do:
				[:i |
				destY _ destY + dy.
				(P _ P - py) < 0 ifTrue: 
						[destX _ destX + dx.
						P _ P + px].
				self copyBits]]! !

!BitBlt methodsFor: 'private'!
copyBitsAgain
	"Primitive. See BitBlt|copyBits, also a Primitive. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 96>
	self primitiveFailed!
eraseBits
	"Perform the erase operation, which puts 0's in the destination
	wherever the source (which is assumed to be just 1 bit deep)
	has a 1.  This requires the colorMap to be set in order to AND
	all 1's into the destFrom pixels regardless of their size."
	| oldMask oldMap |
	oldMask _ halftoneForm.
	halftoneForm _ nil.
	oldMap _ colorMap.
	self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
	combinationRule _ Form erase.
	self copyBits. 		"Erase the dest wherever the source is 1"
	halftoneForm _ oldMask.	"already converted to a Bitmap"
	colorMap _ oldMap!
paintBits
	"Perform the paint operation, which requires two calls to BitBlt."
	| color oldMap saveRule |
	sourceForm depth = 1 ifFalse: 
		[^ self halt: 'paint operation is only defined for 1-bit deep sourceForms'].
	saveRule _ combinationRule.
	color _ halftoneForm.  halftoneForm _ nil.
	oldMap _ colorMap.
	"Map 1's to ALL ones, not just one"
	self colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
	combinationRule _ Form erase.
	self copyBits. 		"Erase the dest wherever the source is 1"
	halftoneForm _ color.
	combinationRule _ Form under.
	self copyBits.	"then OR, with whatever color, into the hole"
	colorMap _ oldMap.
	combinationRule _ saveRule

"(Form dotOfSize: 32)
	displayOn: Display
	at: Sensor cursorPoint
	clippingBox: Display boundingBox
	rule: Form paint
	mask: Form lightGray"!
setDestForm: df
	| bb |
	bb _ df boundingBox.
	destForm _ df.
	clipX _ bb left.
	clipY _ bb top.
	clipWidth _ bb width.
	clipHeight _ bb height!
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 isMemberOf: TwoToneForm)
		ifTrue: [colorMap _ sourceForm colorMapForDepth: destForm depth]
		ifFalse: [(destForm depth > 8 and: [sourceForm depth = 1])
					ifTrue: [colorMap _ Bitmap with: 16rFFFFFFFF with: 0]]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitBlt class
	instanceVariableNames: ''!

!BitBlt class methodsFor: 'instance creation'!
bitPeekerFromForm: sourceForm
	"Answer an instance to be used for valueAt: aPoint.
	The destination for a 1x1 copyBits will be the low order of (bits at: 1)"
	| pixPerWord |
	pixPerWord _ 32//sourceForm depth.
	^ self destForm: (Form extent: pixPerWord@1 depth: sourceForm depth)
	 	sourceForm: sourceForm halftoneForm: nil combinationRule: Form over
		destOrigin: (pixPerWord-1)@0 sourceOrigin: 0@0
		extent: 1@1 clipRect: (0@0 extent: pixPerWord@1)
!
bitPokerToForm: destForm
	"Answer an instance to be used for valueAt: aPoint put: pixValue.
	The source for a 1x1 copyBits will be the low order of (bits at: 1)"
	| pixPerWord |
	pixPerWord _ 32//destForm depth.
	^ self destForm: destForm
	 	sourceForm: (Form extent: pixPerWord@1 depth: destForm depth)
		halftoneForm: nil combinationRule: Form over
		destOrigin: 0@0 sourceOrigin: (pixPerWord-1)@0
		extent: 1@1 clipRect: (0@0 extent: destForm extent)
!
destForm: df sourceForm: sf fillColor: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect!
destForm: df sourceForm: sf halftoneForm: hf combinationRule: cr destOrigin: destOrigin sourceOrigin: sourceOrigin extent: extent clipRect: clipRect 
	"Answer an instance of me with values set according to the arguments."

	^ self new
		setDestForm: df
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: sourceOrigin
		extent: extent
		clipRect: clipRect!
toForm: aForm
	^ self new setDestForm: aForm! !

!BitBlt class methodsFor: 'examples'!
alphaBlendDemo: sz  "Display restoreAfter: [BitBlt alphaBlendDemo: 30]"
	"Displays 10 different alphas, and then paints with a gradient brush"
	| f |  "Get out of painting with option-click"
	1 to: 10 do: [:i | Display fill: (50*i@10 extent: 50@50)
						rule: Form blend
						fillColor: (Color red alpha: i/10)].
	f _ Form extent: sz asPoint depth: 32.
	1 to: 5 do: 
		[:i | f fillShape: (Form dotOfSize: sz*(6-i)//5)
				fillColor: (Color red alpha: (i/5 raisedTo: 2))
				at: f extent // 2].
	[Sensor yellowButtonPressed] whileFalse:
		[Sensor redButtonPressed ifTrue:
			[(BitBlt toForm: Display) copyForm: f to: Sensor cursorPoint rule: Form blend]]!
exampleOne
	"This tests BitBlt by displaying the result of all sixteen combination rules that BitBlt is capable of using. (Please see the comment in BitBlt for the meaning of the combination rules)."
	| path |
	path _ Path new.
	0 to: 3 do: [:i | 0 to: 3 do: [:j | path add: j * 100 @ (i * 75)]].
	Display fillWhite.
	path _ path translateBy: 60 @ 40.
	1 to: 16 do: [:index | BitBlt
			exampleAt: (path at: index)
			rule: index - 1
			fillColor: Color gray]

	"BitBlt exampleOne"!
exampleTwo
	"This is to test painting with a gray tone. It also tests that the seaming with gray patterns is correct in the microcode. Lets you paint for a while and then automatically stops."
	| f aBitBlt |
	"create a small black Form source as a brush. "
	f _ Form extent: 20 @ 20.
	f fillBlack.
	"create a BitBlt which will OR gray into the display. "
	aBitBlt _ BitBlt
		destForm: Display
		sourceForm: f
		fillColor: Color gray
		combinationRule: Form under
		destOrigin: Sensor cursorPoint
		sourceOrigin: 0 @ 0
		extent: f extent
		clipRect: Display computeBoundingBox.
	"paint the gray Form on the screen for a while. "
	[Sensor anyButtonPressed] whileFalse: 
		[aBitBlt destOrigin: Sensor cursorPoint.
		aBitBlt copyBits]

	"BitBlt exampleTwo"! !

!BitBlt class methodsFor: 'private'!
exampleAt: originPoint rule: rule fillColor: mask 
	"This builds a source and destination form and copies the source to the
	destination using the specifed rule and mask. It is called from the method
	named exampleOne."

	| s d border aBitBlt | 
	border_Form extent: 32@32.
	border fillBlack.
	border fill: (1@1 extent: 30@30) fillColor: Form white.
	s _ Form extent: 32@32.
	s fillWhite.
	s fillBlack: (7@7 corner: 25@25).
	d _ Form extent: 32@32.
	d fillWhite.
	d fillBlack: (0@0 corner: 32@16).

	s displayOn: Display at: originPoint.
	border displayOn: Display at: originPoint rule: Form under.
	d displayOn: Display at: originPoint + (s width @0).
	border displayOn: Display at: originPoint + (s width @0) rule: Form under.

	d displayOn: Display at: originPoint + (s extent // (2 @ 1)).
	aBitBlt _ BitBlt
		destForm: Display
		sourceForm: s
		fillColor: mask
		combinationRule: rule
		destOrigin: originPoint + (s extent // (2 @ 1))
		sourceOrigin: 0 @ 0
		extent: s extent
		clipRect: Display computeBoundingBox.
	aBitBlt copyBits.
	border 
		displayOn: Display at: originPoint + (s extent // (2 @ 1))
		rule: Form under.
   
	"BitBlt exampleAt: 100@100 rule: Form over fillColor: Display gray"! !MouseMenuController subclass: #BitEditor
	instanceVariableNames: 'scale squareForm color transparent '
	classVariableNames: 'YellowButtonMessages YellowButtonMenu ColorButtons '
	poolDictionaries: ''
	category: 'Graphics-Editors'!
BitEditor comment:
'I am a bit-magnifying tool for editing small Forms directly on the display screen. I continue to be active until the user points outside of my viewing area.'!

!BitEditor methodsFor: 'initialize-release'!
initialize

	super initialize.
	self initializeYellowButtonMenu!
release

	super release.
	squareForm release.
	squareForm _ nil! !

!BitEditor methodsFor: 'view access'!
view: aView

	super view: aView.
	scale _ aView transformation scale.	
	scale _ scale x rounded @ scale y rounded.
	squareForm _ Form extent: scale depth: aView model depth.
	squareForm fillBlack! !

!BitEditor methodsFor: 'basic control sequence'!
controlInitialize

	super controlInitialize.
	Cursor crossHair show!
controlTerminate

	Cursor normal show! !

!BitEditor methodsFor: 'control defaults'!
isControlActive

	^super isControlActive & sensor blueButtonPressed not 
		& sensor keyboardPressed not!
redButtonActivity
	| absoluteScreenPoint formPoint displayPoint |
	[sensor redButtonPressed]
	  whileTrue: 
		[absoluteScreenPoint _ sensor cursorPoint.	
		formPoint _ (view inverseDisplayTransform: absoluteScreenPoint - (scale//2)) rounded.
		displayPoint _ view displayTransform: formPoint.
		squareForm 
			displayOn: Display
			at: displayPoint 
			clippingBox: view insetDisplayBox 
			rule: Form over
			fillColor: nil.
		view changeValueAt: formPoint put: color]! !

!BitEditor methodsFor: 'menu messages'!
accept
	"The edited information should now be accepted by the view."

	view accept!
cancel
	"The edited informatin should be forgotten by the view."

	view cancel!
fileOut
	model writeOnFileNamed:
		(FillInTheBlank request: 'Enter file name'
				initialAnswer: 'Filename.icon').
!
setColor: aColor
	"Set the color that the next edited dots of the model to be the argument, 
	aSymbol. aSymbol can be any color changing message understood by a 
	Form, such as white or black."

	color _ aColor pixelValueForDepth: model depth.
	squareForm fillColor: aColor.
!
setTransparentColor
	squareForm fillColor: Color gray.
	color _ model transparentPixelValue!
test
	view workingForm follow: [Sensor cursorPoint] while: [Sensor noButtonPressed].
	Sensor waitNoButton! !

!BitEditor methodsFor: 'private'!
initializeYellowButtonMenu

	self yellowButtonMenu: YellowButtonMenu
		yellowButtonMessages: YellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BitEditor class
	instanceVariableNames: ''!

!BitEditor class methodsFor: 'class initialization'!
initialize
	"The Bit Editor is the only controller to override the use of the blue
	button with a different pop-up menu. Initialize this menu."

	YellowButtonMenu _ PopUpMenu labels:
'cancel
accept
file out
test' lines: #(2 3).
	YellowButtonMessages _ #(cancel accept fileOut test)	

	"BitEditor initialize"! !

!BitEditor class methodsFor: 'instance creation'!
openOnForm: aForm 
	"Create and schedule a BitEditor on the form aForm at its top left corner. 
	Show the small and magnified view of aForm."

	| scaleFactor |
	scaleFactor _ 8 @ 8.
	^self openOnForm: aForm
		at: (self locateMagnifiedView: aForm scale: scaleFactor) topLeft
		scale: scaleFactor!
openOnForm: aForm at: magnifiedLocation 
	"Create and schedule a BitEditor on the form aForm at magnifiedLocation. 
	Show the small and magnified view of aForm."

	^self openOnForm: aForm
		at: magnifiedLocation
		scale: 8 @ 8!
openOnForm: aForm at: magnifiedLocation scale: scaleFactor 
	"Create and schedule a BitEditor on the form aForm. Show the small and 
	magnified view of aForm."

	| aScheduledView |
	aScheduledView _ self
				bitEdit: aForm
				at: magnifiedLocation
				scale: scaleFactor
				remoteView: nil.
	aScheduledView controller openDisplayAt:
		aScheduledView displayBox topLeft + (aScheduledView displayBox extent / 2)!
openScreenViewOnForm: aForm at: formLocation magnifiedAt: magnifiedLocation scale: scaleFactor
	"Create and schedule a BitEditor on the form aForm. Show the magnified
	view of aForm in a scheduled window."
	| smallFormView bitEditor savedForm r |
	smallFormView _ FormView new model: aForm.
	smallFormView align: smallFormView viewport topLeft with: formLocation.
	bitEditor _ self bitEdit: aForm at: magnifiedLocation scale: scaleFactor remoteView: smallFormView.
	bitEditor controller blueButtonMenu: nil blueButtonMessages: nil.
	savedForm _ Form fromDisplay: (r _ bitEditor displayBox expandBy: (0@23 corner: 0@0)).
	bitEditor controller startUp.
	savedForm displayOn: Display at: r topLeft.
	bitEditor release.
	smallFormView release.

	"BitEditor magnifyOnScreen."! !

!BitEditor class methodsFor: 'examples'!
magnifyOnScreen
	"Bit editing of an area of the display screen. User designates a 
	rectangular area that is magnified by 8 to allow individual screens dots to
	be modified. red button is used to set a bit to black and yellow button is
	used to set a bit to white. Editor is not scheduled in a view. Original
	screen location is updated immediately. This is the same as FormEditor
	magnify."
	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8 @ 8.
	smallRect _ Rectangle fromUser.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.
	tempRect _ self locateMagnifiedView: smallForm scale: scaleFactor.
	"show magnified form size until mouse is depressed"
	self
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor

	"BitEditor magnifyOnScreen."!
magnifyWithSmall
"	Also try:
	BitEditor openOnForm:
		(Form extent: 32@32 depth: Display depth)
	BitEditor openOnForm:
		((MaskedForm extent: 32@32 depth: Display depth)
		withTransparentPixelValue: -1)
"
	"Open a BitEditor viewing an area on the screen which the user chooses"
	| area form |
	area _ Rectangle fromUser.
	area isNil ifTrue: [^ self].
	form _ Form fromDisplay: area.
	self openOnForm: form

	"BitEditor magnifyWithSmall."! !

!BitEditor class methodsFor: 'private'!
bitEdit: aForm at: magnifiedFormLocation scale: scaleFactor remoteView: remoteView
	"Create a BitEditor on aForm. That is, aForm is a small image that will 
	change as a result of the BitEditor changing a second and magnified 
	view of me. magnifiedFormLocation is where the magnified form is to be 
	located on the screen. scaleFactor is the amount of magnification. This 
	method implements a scheduled view containing both a small and 
	magnified view of aForm. Upon accept, aForm is updated."

	| aFormView scaledFormView bitEditor topView extent menuView lowerRightExtent |
	scaledFormView _ FormHolderView new model: aForm.
	scaledFormView scaleBy: scaleFactor.
	bitEditor _ self new.
	scaledFormView controller: bitEditor.
	bitEditor setColor: Color black.
	topView _ ColorSystemView new.
	remoteView == nil ifTrue: [topView label: 'Bit Editor'].
	topView borderWidth: 2.

	topView addSubView: scaledFormView.
	remoteView == nil
		ifTrue:  "If no remote view, then provide a local view of the form"
			[aFormView _ FormView new model: scaledFormView workingForm.
			aFormView controller: NoController new.
			(aForm isMemberOf: MaskedForm) ifTrue:
				[scaledFormView insideColor: Color gray.
				aFormView insideColor: Color white].
			aForm height < 50
				ifTrue: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 2]
				ifFalse: [aFormView borderWidthLeft: 0 right: 2 top: 2 bottom: 0].
			topView addSubView: aFormView below: scaledFormView]
		 ifFalse:  "Otherwise, the remote one should view the same form"
			[remoteView model: scaledFormView workingForm].
	lowerRightExtent _ remoteView == nil
			ifTrue:
				[(scaledFormView viewport width - aFormView viewport width) @
					(aFormView viewport height max: 50)]
			ifFalse:
				[scaledFormView viewport width @ 50].
	menuView _ self buildColorMenu: lowerRightExtent
		colorCount: ((aForm isMemberOf: MaskedForm) ifTrue: [2] ifFalse: [1]).
	menuView model: bitEditor.
	menuView borderWidthLeft: 0 right: 0 top: 2 bottom: 0.
	topView
		addSubView: menuView
		align: menuView viewport topRight
		with: scaledFormView viewport bottomRight.
	extent _ scaledFormView viewport extent + (0 @ lowerRightExtent y)
			+ (4 @ 4).  "+4 for borders"
	topView minimumSize: extent.
	topView maximumSize: extent.
	topView translateBy: magnifiedFormLocation.
	^topView!
buildColorMenu: extent colorCount: nColors
	"See BitEditor magnifyWithSmall."

	| menuView index form aSwitchView connector
	button formExtent highlightForm color leftOffset |
	connector _ Object new.
	menuView _ FormMenuView new.
	menuView window: (0@0 corner: extent).
	formExtent _ 30@30 min: extent//(nColors*2+1@2).  "compute this better"
	leftOffset _ extent x-(nColors*2-1*formExtent x)//2.
	highlightForm _ Form extent: formExtent.
	highlightForm borderWidth: 4.
	1 to: nColors do:
		[:index | 
		color _ (nColors=1
			ifTrue: [#(black)]
			ifFalse: [#(black gray)]) at: index.
		form _ Form extent: formExtent.
		form fill: form boundingBox fillColor: (Color perform: color).
		form borderWidth: 5.
		form border: form boundingBox width: 4 fillColor: form white.
		button _ Button new.
		index = 1 ifTrue:
			[button onAction: [menuView model setColor: Color fromUser]]
			ifFalse:
			[button onAction: [menuView model setTransparentColor]].

		aSwitchView _ SwitchView new model: button.
		aSwitchView key: ((nColors=3 ifTrue: ['xvn'] ifFalse: ['xn']) at: index).
		aSwitchView label: form.
		aSwitchView window: (0@0 extent: form extent).
		aSwitchView translateBy: (index-1*2*form width+leftOffset) @ (form height//2).
		aSwitchView highlightForm: highlightForm.
	
		aSwitchView borderWidth: 1.
		aSwitchView controller selector: #turnOn.
		menuView addSubView: aSwitchView].
	^menuView!
locateMagnifiedView: aForm scale: scaleFactor
	"Answer a rectangle at the location where the scaled view of the form,
	aForm, should be displayed."

	| tempExtent tempRect |
	tempExtent _ aForm extent * scaleFactor + (0@50).
	tempRect _ (Sensor cursorPoint" grid: scaleFactor") extent: tempExtent.
	"show magnified form size until mouse is depressed"
	[Sensor redButtonPressed]
		whileFalse: 
			[Display reverse: tempRect.
			Display reverse: tempRect.
			tempRect _ (Sensor cursorPoint grid: scaleFactor)
						extent: tempExtent].
	^tempRect! !

BitEditor initialize!
ArrayedCollection variableWordSubclass: #Bitmap
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Support'!
Bitmap comment:
'My instances provide contiguous storage of bits, primarily to hold the graphical data of Forms. Forms and their subclasses provide the additional structural information as to how the bits should be interpreted in two dimensions.'!

!Bitmap methodsFor: 'initialize-release'!
fromByteStream: aStream 
	"Initialize the array of bits by reading integers from the argument, 
	aStream."
	aStream nextInto: self! !

!Bitmap methodsFor: 'filing'!
readCompressedFrom: aStream 
	"Initialize the array of bits by reading integers from the argument, 
	aStream."
	| pixSize |
	pixSize _ aStream next.  "1, 2, or 4 bytes"
	!
writeCompressedOn: aStream 
	"Store the array of bits onto the argument, aStream."

	aStream nextPutAll: self!
writeOn: aStream 
	"Store the array of bits onto the argument, aStream."

	aStream nextInt32Put: self size.
	aStream nextPutAll: self! !

!Bitmap methodsFor: 'printing'!
printOn: aStream

	aStream nextPutAll: 'a Bitmap of length '.
	self size printOn: aStream! !

!Bitmap methodsFor: 'accessing'!
bitPatternForDepth: depth
	"The raw call on BitBlt needs a Bitmap to represent this color.  I already am Bitmap like.  I am already adjusted for a specific depth.  Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self!
byteAt: byteAddress
	"Extract a byte from a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:.  See Form pixelAt:  7/1/96 tk"
	| lowBits |
	lowBits _ byteAddress - 1 bitAnd: 3.
	^((self at: byteAddress - 1 - lowBits // 4 + 1)
		bitShift: (lowBits - 3) * 8)
		bitAnd: 16rFF!
byteAt: byteAddress put: byte
	"Insert a byte into a Bitmap.  Note that this is a byte address and it is one-order.  For repeated use, create an instance of BitBlt and use pixelAt:put:.  See Form pixelAt:put:  7/1/96 tk"

	| longWord shift lowBits longAddr |
	lowBits _ byteAddress - 1 bitAnd: 3.
	longWord _ self at: (longAddr _ (byteAddress - 1 - lowBits) // 4 + 1).
	shift _ (3 - lowBits) * 8.
	longWord _ longWord - (longWord bitAnd: (16rFF bitShift: shift)) 
		+ (byte bitShift: shift).
	self at: longAddr put: longWord.
	^ byte!
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! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Bitmap class
	instanceVariableNames: ''!

!Bitmap class methodsFor: 'instance creation'!
newFromStream: s
	| len |
	len _ s nextInt32.
	len < 0
		ifTrue: [^ (self new: len negated) readCompressedFrom: s]
		ifFalse: [^ s nextInto: (self new: len)]! !ContextPart variableSubclass: #BlockContext
	instanceVariableNames: 'nargs startpc home '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
BlockContext comment:
'My instances function similarly to instances of MethodContext, but they hold the dynamic state for execution of a block in Smalltalk. They access all temporary variables and the method sender via their home pointer, so that those values are effectively shared. Their indexable part is used to store their independent value stack during execution.
	
My instance must hold onto its home in order to work. This can cause circularities if the home is also pointing (via a temp, perhaps) to the instance. In the rare event that this happens (as in SortedCollection sortBlock:) the message fixTemps will replace home with a copy of home, thus defeating the sharing of temps but, nonetheless, eliminating the circularity.'!

!BlockContext methodsFor: 'initialize-release'!
home: aContextPart startpc: position nargs: anInteger 
	"This is the initialization message. The receiver has been initialized with 
	the correct size only."

	home _ aContextPart.
	startpc _ position.
	nargs _ anInteger! !

!BlockContext methodsFor: 'accessing'!
fixTemps
	"Fix the values of the temporary variables used in the block that are 
	ordinarily shared with the method in which the block is defined."

	home _ home copy.
	home swapSender: nil!
hasMethodReturn
	"Answer whether the receiver has a return ('^') in its code."

	| method scanner end |
	method _ self method.
	"Determine end of block from long jump preceding it"
	end _ (method at: startpc-2)\\16-4*256 + (method at: startpc-1) + startpc - 1.
	scanner _ InstructionStream new method: method pc: startpc.
	scanner scanFor: [:byte | (byte between: 120 and: 124) or: [scanner pc > end]].
	^scanner pc <= end!
home
	"Answer the context in which the receiver was defined."

	^home!
method
	"Answer the compiled method in which the receiver was defined."

	^home method!
numArgs

	^nargs!
receiver 
	"Refer to the comment in ContextPart|receiver."

	^home receiver!
tempAt: index 
	"Refer to the comment in ContextPart|tempAt:."

	^home at: index!
tempAt: index put: value 
	"Refer to the comment in ContextPart|tempAt:put:."

	^home at: index put: value! !

!BlockContext methodsFor: 'evaluating'!
ifError: aBlock
    | errorBlock lastHandler val activeControllerProcess  |
	activeControllerProcess _ ScheduledControllers activeControllerProcess.
	lastHandler _ activeControllerProcess errorHandler.
    errorBlock _
        [:aString :aReceiver |  activeControllerProcess errorHandler: lastHandler.
        ^ aBlock value: aString].
    activeControllerProcess errorHandler: errorBlock.
    val _ self value.
    activeControllerProcess errorHandler: lastHandler.
    ^ val!
value
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects any arguments or if the block is already being executed. 
	Optional. No Lookup. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: #()!
value: arg 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than one argument or if the block is already being 
	executed. Optional. No Lookup. See Object documentation 
	whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg)!
value: arg1 ifError: aBlock
    | errorBlock lastHandler val activeControllerProcess  |
	activeControllerProcess _ ScheduledControllers activeControllerProcess.
	lastHandler _ activeControllerProcess errorHandler.
    errorBlock _
        [:aString :aReceiver |  activeControllerProcess errorHandler: lastHandler.
        ^ aBlock value: aString value: aReceiver].
    activeControllerProcess errorHandler: errorBlock.
    val _ self value: arg1.
    activeControllerProcess errorHandler: lastHandler.
    ^ val!
value: arg1 value: arg2 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than two arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: (Array with: arg1 with: arg2)!
value: arg1 value: arg2 value: arg3 
	"Primitive. Evaluate the block represented by the receiver. Fail if the 
	block expects other than three arguments or if the block is already being 
	executed. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 81>
	^self valueWithArguments: 
		(Array
			with: arg1
			with: arg2
			with: arg3)!
valueWithArguments: anArray 
	"Primitive. Evaluate the block represented by the receiver. The argument 
	is an Array whose elements are the arguments for the block. Fail if the 
	length of the Array is not the same as the the number of arguments that 
	the block was expecting. Fail if the block is already being executed. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 82>
	self valueError! !

!BlockContext methodsFor: 'controlling'!
ifFail: aOneArgBlock
	"Usage:
		answer _ [code to try] ifFail: [:aFailure | code to run instead].
	 'answer' will become the value of 'code to try', unless that code invokes
	 	(Failure name: #aName) propagate
	 or
	 	(Failure name: #aName value: anErrCode) propagate
	 in which case 'answer' will become the value of 'code to run instead'.

	 The first time 'propagate' is sent to a failure, three attributes of that failure
	 are determined:
		The 'instigator' of the failure is that Context executing 'ifFail:' whose
			receiver is the block whose evaluation called 'propagate'.
		The 'generator' of the failure is the instigator's receiver-block
			(the one whose evaluation called 'propagate').
		The 'handler' of the failure is the instigator's argument-block
			(the one that will be run because the generator failed).

	 Special things you can do in a handler are explained below.

	 You can access the 'name' and 'value' fields of aFailure.

	 You can create a new failure; it will run the handler of the next outer 'ifFail:'.

	 You can propagate a failure to the next outer 'ifFail:' with:
		aFailure propagate
	 You can alter the name or value of a failure before propagating it, e.g.:
		(aFailure name: #anotherName) propagate
	 but the instigator and generator remain unchanged.

	 A failure keeps a stack of its propagators (invocations of propagate).
	 You can print out this stack in a debugger pane with a 'printIt' of:
		aFailure methods
	 to get a collection of (class selector) two-element-arrays, or with a 'printIt' of:
		aFailure receivers
	 to get a collection of the objects running those methods.

	 You can invoke:
		aFailure reply: aReply
	 It will cause the top propagator to be popped from the stack and to
	 return aReply to its caller.  If the stack is empty, it is an error.
	 Thus, a typical call on 'propagate', other than the initial call, is:
		aFailure reply: aFailure propagate
	 and a typical initial call is:
		reply _ (Failure name: #aName) propagate
	 To prevent a failure from receiving a reply, send it 'noReply'.  Example:
		(Failure name: #aName) noReply propagate
	 To find out whether a failure can receive a reply, send it 'canReply'.

	 Note that 'reply:' pops the Context stack, while 'propagate' does not do so.
	 Returning from or falling off the end of a handler also pops the context stack.

	 You can invoke:
		aFailure retry
	 It will re-evaluate the generator of the failure and answer its value; if it
	 fails again, it will behave like a failure generated by the caller of 'retry',
	 and thus will not run the original handler of aFailure.  A typical call is:
		[aFailure reply: aFailure retry] ifFail: [:anotherFailure | moreCode].
	 To prevent a failure from being retried, send it 'noRetry'.  Example:
		answer _ (aFailure name: #newName) noRetry propagate
	 To find out whether a failure can be retried, send it 'canRetry'."


	aOneArgBlock numArgs = 1 ifFalse:
		[self notify: 'ifFail: argument must be a one-argument block'].
	^self value!
whileFalse
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is false."
 
	^ [self value] whileFalse: []!
whileFalse: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is false."

	^ [self value] whileFalse: [aBlock value]!
whileTrue
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the receiver, as long as its value is true."
 
	^ [self value] whileTrue: []!
whileTrue: aBlock 
	"Ordinarily compiled in-line, and therefore not overridable.
	This is in case the message is sent to other than a literal block.
	Evaluate the argument, aBlock, as long as the value of the receiver is true."

	^ [self value] whileTrue: [aBlock value]! !

!BlockContext methodsFor: 'scheduling'!
fork
	"Create and schedule a Process running the code in the receiver."

	self newProcess resume!
forkAt: priority 
	"Create and schedule a Process running the code in the receiver. The 
	priority of the process is the argument, priority."

	| forkedProcess |
	forkedProcess _ self newProcess.
	forkedProcess priority: priority.
	forkedProcess resume!
newProcess
	"Answer a Process running the code in the receiver. The process is not 
	scheduled."

	^Process
		forContext: 
			[self value.
			Processor terminateActive]
		priority: Processor activePriority!
newProcessWith: anArray 
	"Answer a Process running the code in the receiver. The receiver's block 
	arguments are bound to the contents of the argument, anArray. The 
	process is not scheduled."

	^Process
		forContext: 
			[self valueWithArguments: anArray.
			Processor terminateActive]
		priority: Processor activePriority! !

!BlockContext methodsFor: 'instruction decoding'!
blockReturnTop
	"Simulate the interpreter's action when a ReturnTopOfStack bytecode is 
	encountered in the receiver."

	| save dest |
	save _ home.	"Needed because return code will nil it"
	dest _ self return: self pop to: self sender.
	home _ save.
	sender _ nil.
	^dest! !

!BlockContext methodsFor: 'printing'!
printOn: aStream

	home == nil ifTrue: [^aStream nextPutAll: 'a BlockContext with home=nil'].
	aStream nextPutAll: '[] in '.
	super printOn: aStream! !

!BlockContext methodsFor: 'private'!
cannotReturn: arg
	"Kills off processes that didn't terminate properly"
	"Display reverse; reverse."  "<-- So we can catch the suspend bug"
	Processor terminateActive!
startpc
	"for use by the System Tracer only"

	^startpc!
valueError

	self error: 'Incompatible number of args, or already active'! !

!BlockContext methodsFor: 'system simulation'!
pushArgs: args from: sendr 
	"Simulates action of the value primitive."

	args size ~= nargs ifTrue: [^self error: 'incorrect number of args'].
	stackp _ 0.
	args do: [:arg | self push: arg].
	sender _ sendr.
	pc _ startpc! !ParseNode subclass: #BlockNode
	instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
BlockNode comment:
'I represent a bracketed block with 0 or more arguments and 1 or more statements. If I am initialized with no statements, I create one. I have a flag to tell whether my last statement returns a value from the enclosing method. My last three fields remember data needed for code generation. I can emit for value in the usual way, in which case I create a literal method (actually a context remotely copied) to be evaluated by sending it value: at run time. Or I can emit code to be evaluated in line; this only happens at the top level of a method and in conditionals and while-loops, none of which have arguments.'!

!BlockNode methodsFor: 'initialize-release'!
arguments: argNodes statements: statementsCollection returns: returnBool from: encoder
	"Compile."

	arguments _ argNodes.
	statements _ statementsCollection size > 0
				ifTrue: [statementsCollection]
				ifFalse: [argNodes size > 0
						ifTrue: [statementsCollection copyWith: arguments last]
						ifFalse: [Array with: NodeNil]].
	returns _ returnBool!
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 copyFrom: 1 to: statementsCollection size - 1]
				ifFalse: [statementsCollection size = 0
						ifTrue: [Array with: NodeNil]
						ifFalse: [statementsCollection]].
	arguments _ Array new: 0.
	returnLast ifTrue: [self returnLast]! !

!BlockNode methodsFor: 'accessing'!
arguments: argNodes 
	"Decompile."

	arguments _ argNodes!
firstArgument
	^ arguments first!
numberOfArguments

	^arguments size!
returnLast

	self returns
		ifFalse: 
			[returns _ true.
			statements at: statements size put: statements last asReturnNode]!
returnSelfIfNoOther

	self returns
		ifFalse: 
			[statements last == NodeSelf ifFalse: [statements add: NodeSelf].
			self returnLast]! !

!BlockNode methodsFor: 'testing'!
canBeSpecialArgument
	"Can I be an argument of (e.g.) ifTrue:?"

	^arguments size = 0!
isComplex

	^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]!
isJust: node

	returns ifTrue: [^false].
	^statements size = 1 and: [statements first == node]!
isJustCaseError

	^ statements size = 1 and:
		[statements first
			isMessage: #caseError
			receiver: [:r | r==NodeSelf]
			arguments: nil]!
isQuick
	^ statements size = 1
		and: [statements first isVariableReference
				or: [statements first isSpecialConstant]]!
returns

	^returns or: [statements last isReturningIf]! !

!BlockNode methodsFor: 'code generation'!
code

	^statements first code!
emitExceptLast: stack on: aStream
	| nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ self].  "Only one statement"
	1 to: nextToLast - 1 do:
		[:i | (statements at: i) emitForEffect: stack on: aStream].
	(returns  "Don't pop before a return"
			and: [(statements at: nextToLast) prefersValue])
		ifTrue: [(statements at: nextToLast) emitForValue: stack on: aStream]
		ifFalse: [(statements at: nextToLast) emitForEffect: stack on: aStream]!
emitForEvaluatedEffect: stack on: aStream

	self returns
		ifTrue: 
			[self emitForEvaluatedValue: stack on: aStream.
			stack pop: 1]
		ifFalse: 
			[self emitExceptLast: stack on: aStream.
			statements last emitForEffect: stack on: aStream]!
emitForEvaluatedValue: stack on: aStream
	self emitExceptLast: stack on: aStream.
	statements last emitForValue: stack on: aStream.
	(returns and: [statements size > 1
			and: [(statements at: statements size-1) prefersValue]])
		ifTrue: [stack pop: 1]  "compensate for elided pop prior to return"!
emitForValue: stack on: aStream
	| arg |
	aStream nextPut: LdThisContext.
	stack push: 1.
	nArgsNode emitForValue: stack on: aStream.
	remoteCopyNode
		emit: stack
		args: 1
		on: aStream.
	"Force a two byte jump."
	self emitLong: size code: JmpLong on: aStream.
	stack push: arguments size.
	arguments reverseDo: [:arg | arg emitStorePop: stack on: aStream].
	self emitForEvaluatedValue: stack on: aStream.
	self returns ifFalse: [aStream nextPut: EndRemote].
	stack pop: 1!
sizeExceptLast: encoder
	| codeSize nextToLast |
	nextToLast _ statements size - 1.
	nextToLast < 1 ifTrue: [^ 0]. "Only one statement"
	codeSize _ 0.
	1 to: nextToLast - 1 do: 
		[:i | codeSize _ codeSize + ((statements at: i) sizeForEffect: encoder)].
	^ (returns  "Don't pop before a return"
			and: [(statements at: nextToLast) prefersValue])
		ifTrue: [codeSize + ((statements at: nextToLast) sizeForValue: encoder)]
		ifFalse: [codeSize + ((statements at: nextToLast) sizeForEffect: encoder)]!
sizeForEvaluatedEffect: encoder

	self returns ifTrue: [^self sizeForEvaluatedValue: encoder].
	^(self sizeExceptLast: encoder)
		+ (statements last sizeForEffect: encoder)!
sizeForEvaluatedValue: encoder

	^(self sizeExceptLast: encoder)
		+ (statements last sizeForValue: encoder)!
sizeForValue: encoder
	nArgsNode _ encoder encodeLiteral: arguments size.
	remoteCopyNode _ encoder encodeSelector: #blockCopy:.
	size _ (self sizeForEvaluatedValue: encoder)
				+ (self returns ifTrue: [0] ifFalse: [1]). "endBlock"
	arguments _ arguments collect:  "Chance to prepare debugger remote temps"
				[:arg | arg asStorableNode: encoder].
	arguments do: [:arg | size _ size + (arg sizeForStorePop: encoder)].
	^1 + (nArgsNode sizeForValue: encoder) 
		+ (remoteCopyNode size: encoder args: 1 super: false) + 2 + size! !

!BlockNode methodsFor: 'printing'!
printArgumentsOn: aStream indent: level

	arguments size = 0
		ifFalse: 
			[arguments do: 
				[:arg | 
				aStream nextPut: $:.
				aStream nextPutAll: arg key.
				aStream space].
			aStream nextPutAll: '| '.
			"If >0 args and >1 statement, put all statements on separate lines"
			statements size > 1 ifTrue: [aStream crtab: level]]!
printOn: aStream indent: level

	statements size <= 1 ifFalse: [aStream crtab: level].
	aStream nextPut: $[.
	self printArgumentsOn: aStream indent: level.
	self printStatementsOn: aStream indent: level.
	aStream nextPut: $]!
printStatementsOn: aStream indent: level

	| len shown thisStatement |
	comment == nil
		ifFalse: 
			[self printCommentOn: aStream indent: level.
			aStream crtab: level].
	len _ shown _ statements size.
	(level = 1 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 == NodeSelf
			ifFalse: 
				[thisStatement printOn: aStream indent: level.
				i < shown ifTrue: [aStream nextPut: $.; crtab: level].
				thisStatement comment size > 0
					ifTrue: 
						[i = shown ifTrue: [aStream crtab: level].
						thisStatement printCommentOn: aStream indent: level.
						i < shown ifTrue: [aStream crtab: level]]]]! !

!BlockNode methodsFor: 'equation translation'!
collectVariables
	^statements inject: Array new into: [:array :statement | array, statement collectVariables]!
copyReplacingVariables: varDict 
	| t1 |
	t1 _ statements collect: [:s | s copyReplacingVariables: varDict].
	^(self copy) statements: t1; yourself!
specificMatch: aTree using: matchDict 
	statements with: aTree statements do: [:s1 :s2 |
			(s1 match: s2 using: matchDict) ifFalse: [^false]].
	^true!
statements
	^statements!
statements: val
	statements _ val! !

!BlockNode methodsFor: 'C translation'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BlockNode class
	instanceVariableNames: ''!

!BlockNode class methodsFor: 'instance creation'!
withJust: aNode
	"Used to create a simple block, eg: withJust: NodeNil"
	^ self new statements: (Array with: aNode) returns: false! !WaveTableSound subclass: #BoinkSound
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound'!

!BoinkSound methodsFor: 'initialization'!
setPitch: p dur: d loudness: l
	"This is just a WaveTableSound that decays by default."
	"(BoinkSound pitch: 880.0 dur: 2.0 loudness: 1000) play"

	super setPitch: p dur: d loudness: l.
	decayRate _ 0.92.
! !Object subclass: #Boolean
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
Boolean comment:
'I represent logical values, providing boolean operations and conditional control structures.'!

!Boolean methodsFor: 'logical operations'!
& aBoolean 
	"Evaluating conjunction. Evaluate the argument. Then answer true if 
	both the receiver and the argument are true."

	self subclassResponsibility!
eqv: aBoolean 
	"Answer true if the receiver is equivalent to aBoolean."

	^self == aBoolean!
not
	"Negation. Answer true if the receiver is false, answer false if the 
	receiver is true."

	self subclassResponsibility!
xor: aBoolean 
	"Exclusive OR. Answer true if the receiver is not equivalent to aBoolean."

	^(self == aBoolean) not!
| aBoolean 
	"Evaluating disjunction (OR). Evaluate the argument. Then answer true 
	if either the receiver or the argument is true."

	self subclassResponsibility! !

!Boolean methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction. If the receiver is true, answer the value of 
	the argument, alternativeBlock; otherwise answer false without 
	evaluating the argument."

	self subclassResponsibility!
ifFalse: alternativeBlock 
	"If the receiver is true (i.e., the condition is true), then the value is the 
	true alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Same as ifTrue:ifFalse:."

	self subclassResponsibility!
ifTrue: alternativeBlock 
	"If the receiver is false (i.e., the condition is false), then the value is the 
	false alternative, which is nil. Otherwise answer the result of evaluating 
	the argument, alternativeBlock. Create an error notification if the 
	receiver is nonBoolean. Execution does not actually reach here because 
	the expression is compiled in-line."

	self subclassResponsibility!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock
	"If the receiver is true (i.e., the condition is true), then answer the value 
	of the argument trueAlternativeBlock. If the receiver is false, answer the 
	result of evaluating the argument falseAlternativeBlock. If the receiver 
	is a nonBoolean then create an error notification. Execution does not 
	actually reach here because the expression is compiled in-line."

	self subclassResponsibility!
or: alternativeBlock 
	"Nonevaluating disjunction. If the receiver is false, answer the value of 
	the argument, alternativeBlock; otherwise answer true without 
	evaluating the argument."

	self subclassResponsibility! !

!Boolean methodsFor: 'copying'!
deepCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."!
forRom
	"A 'primitive type' for ToolBox traps"!
shallowCopy 
	"Receiver has two concrete subclasses, True and False.
	Only one instance of each should be made, so return self."! !

!Boolean methodsFor: 'printing'!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	self printOn: aStream! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Boolean class
	instanceVariableNames: ''!

!Boolean class methodsFor: 'instance creation'!
new
	self error: 'You may not create any more Booleans - this is two-valued logic'! !Object subclass: #BraceConstructor
	instanceVariableNames: 'elements initIndex subBraceSize constructor decompiler '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!BraceConstructor methodsFor: 'constructing'!
codeBrace: numElements fromBytes: aDecompiler withConstructor: aConstructor
	"Decompile.  Consume at least a Pop and usually several stores into variables
	 or braces.  See BraceNode<formBrace for details."

	decompiler _ aDecompiler.
	constructor _ aConstructor.
	elements _ Array new: (initIndex _ numElements).
	[decompiler interpretNextInstructionFor: self.
	 initIndex = 0]
		whileFalse: [].
	^constructor codeBrace: elements! !

!BraceConstructor methodsFor: 'instruction decoding'!
doPop
	"Decompile."!
popIntoLiteralVariable: association
	"Decompile."

	elements at: initIndex put: (constructor codeAnyLitInd: association).
	initIndex _ initIndex - 1!
popIntoReceiverVariable: offset
	"Decompile."

	elements at: initIndex put: (constructor codeInst: offset).
	initIndex _ initIndex - 1!
popIntoTemporaryVariable: offset
	"Decompile."

	elements at: initIndex put: (decompiler tempAt: offset).
	initIndex _ initIndex - 1!
pushConstant: value

	subBraceSize _ value!
send: selector super: superFlag numArgs: numArgs

	selector == #toBraceStack:
		ifFalse: [self error: 'Malformed brace-variable code'].
	elements at: initIndex put:
		(BraceConstructor new
			codeBrace: subBraceSize
			fromBytes: decompiler
			withConstructor: constructor).
	initIndex _ initIndex - 1! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceConstructor class
	instanceVariableNames: ''!

!BraceConstructor class methodsFor: 'examples'!
example
	"Test the {a. b. c} syntax.  For more examples, see SequenceableCollection-casing
	 and Dictionary-casing."

	| a b c d e x y |
	x _ {1. {2. 3}. 4}.
	{a. {b. c}. d. e} _ x, {5}, {}.
	y _ {a} _ {0}.
	{} _ {}.
	^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !ParseNode subclass: #BraceNode
	instanceVariableNames: 'elements sourceLocations collClassNode nElementsNode fromBraceStackNode toBraceStackNode withNode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!

!BraceNode methodsFor: 'initialize-release'!
collClass: aParseNode

	collClassNode _ aParseNode!
elements: collection
	"Decompile."

	elements _ collection!
elements: collection sourceLocations: locations
	"Compile."

	elements _ collection.
	sourceLocations _ locations! !

!BraceNode methodsFor: 'testing'!
assignmentCheck: encoder at: location

	| loc |
	elements do:
		[:element |
		(loc _ element assignmentCheck: encoder at: location) >= 0 ifTrue: [^loc]].
	^-1!
blockAssociationCheck: encoder
	"If all elements are MessageNodes of the form [block]->[block], and there is at
	 least one element, answer true.
	 Otherwise, notify encoder of an error."

	elements size = 0
		ifTrue: [^encoder notify: 'At least one case required'].
	elements with: sourceLocations do:
			[:x :loc |
			(x 	isMessage: #->
				receiver:
					[:rcvr |
					(rcvr isKindOf: BlockNode) and: [rcvr numberOfArguments = 0]]
				arguments:
					[:arg |
					(arg isKindOf: BlockNode) and: [arg numberOfArguments = 0]])
			  ifFalse:
				[^encoder notify: 'Association between 0-argument blocks required' at: loc]].
	^true!
numElements

	^ elements size! !

!BraceNode methodsFor: 'code generation'!
emitForValue: stack on: aStream
	"elem1, ..., elemN, collectionClass, N, fromBraceStack:"

	| element |
	elements do: [:element | element emitForValue: stack on: aStream].
	collClassNode emitForValue: stack on: aStream.
	nElementsNode emitForValue: stack on: aStream.
	fromBraceStackNode emit: stack args: 1 on: aStream.
	stack pop: elements size!
emitStore: stack on: aStream

	aStream nextPut: Dup. stack push: 1.
	self emitStorePop: stack on: aStream!
emitStorePop: stack on: aStream
	"N, toBraceStack:, pop, pop elemN, ..., pop elem1"

	nElementsNode emitForValue: stack on: aStream.
	toBraceStackNode emit: stack args: 1 on: aStream.
	stack push: elements size.
	aStream nextPut: Pop. stack pop: 1.
	elements reverseDo: [:element | element emitStorePop: stack on: aStream]!
sizeForStore: encoder

	^1 + (self sizeForStorePop: encoder)!
sizeForStorePop: encoder
	"N, toBraceStack:, pop, pop elemN, ..., pop elem1"

	nElementsNode _ encoder encodeLiteral: elements size.
	toBraceStackNode _ encoder encodeSelector: #toBraceStack:.
	^elements inject:
		(nElementsNode sizeForValue: encoder) +
		(toBraceStackNode size: encoder args: 1 super: false) + 1 into:
			[:subTotal :element |
		 	subTotal + (element sizeForStorePop: encoder)]!
sizeForValue: encoder
	"elem1, ..., elemN, collectionClass, N, fromBraceStack:"

	nElementsNode _ encoder encodeLiteral: elements size.
	collClassNode isNil ifTrue:
		[collClassNode _ encoder encodeVariable: #Array].
	fromBraceStackNode _ encoder encodeSelector: #fromBraceStack:.
	^elements inject:
		(nElementsNode sizeForValue: encoder) +
		(collClassNode sizeForValue: encoder) +
		(fromBraceStackNode size: encoder args: 1 super: false)
	 into:
		[:subTotal :element |
		 subTotal + (element sizeForValue: encoder)]! !

!BraceNode methodsFor: 'enumerating'!
casesForwardDo: aBlock
	"For each case in forward order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	1 to: (numCases _ elements size) do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]!
casesReverseDo: aBlock
	"For each case in reverse order, evaluate aBlock with three arguments:
	 the key block, the value block, and whether it is the last case."

	| numCases case |
	(numCases _ elements size) to: 1 by: -1 do:
		[:i |
		case _ elements at: i.
		aBlock value: case receiver value: case arguments first value: i=numCases]!
do: aBlock
	"For each element in order, evaluate aBlock with two arguments: the element,
	 and whether it is the last element."

	| numElements |
	1 to: (numElements _ elements size) do:
		[:i | aBlock value: (elements at: i) value: i=numElements]!
reverseDo: aBlock
	"For each element in reverse order, evaluate aBlock with two arguments: the element,
	 and whether it is the last element."

	| numElements |
	(numElements _ elements size) to: 1 by: -1 do:
		[:i | aBlock value: (elements at: i) value: i=numElements]! !

!BraceNode methodsFor: 'printing'!
printOn: aStream indent: level

	| shown |
	aStream nextPut: ${.
	shown _ elements size.
	1 to: shown do: 
		[:i | 
		(elements at: i) printOn: aStream indent: level.
		i < shown ifTrue: [aStream nextPut: $.; space]].
	aStream nextPut: $}! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BraceNode class
	instanceVariableNames: ''!

!BraceNode class methodsFor: 'examples'!
example
	"Test the {a. b. c} syntax."

	| a b c d e x y |
	x _ {1. {2. 3}. 4}.
	{a. {b. c}. d. e} _ x, {5}, {}.
	y _ {a} _ {0}.
	{} _ {}.
	^{e. d. c. b. a + 1. y first} as: Set

"BraceNode example"
"Smalltalk garbageCollect.
 Time millisecondsToRun: [20 timesRepeat: [BraceNode example]] 1097 2452"! !StringHolder subclass: #Browser
	instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated '
	classVariableNames: 'PostOpenSuggestion '
	poolDictionaries: ''
	category: 'Interface-Browser'!
Browser comment:
'I represent a query path into the class descriptions, the software of the system.'!

!Browser methodsFor: 'initialize-release'!
browserWindowActivated
	"Called when a window whose model is the receiver is reactivated, giving the receiver an opportunity to take steps if it wishes.  The default is to do nothing.  8/5/96 sw"!
defaultBackgroundColor
	^ #lightGreen!
systemOrganizer: aSystemOrganizer 
	"Initialize the receiver as a perspective on the system organizer, 
	aSystemOrganizer. Typically there is only one--the system variable 
	SystemOrganization."

	super initialize.
	contents _ nil.
	systemOrganizer _ aSystemOrganizer.
	systemCategoryListIndex _ 0.
	classListIndex _ 0.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	metaClassIndicated _ false.
	self setClassOrganizer.
	editSelection _ #none! !

!Browser methodsFor: 'accessing'!
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."

	editSelection == #none ifTrue: [^''].
	editSelection == #editSystemCategories 
		ifTrue: [^systemOrganizer printString].
	editSelection == #newClass 
		ifTrue: [^Class template: self selectedSystemCategoryName].
	editSelection == #editClass 
		ifTrue: [^self selectedClassOrMetaClass definition].
	editSelection == #editComment 
		ifTrue: [^self selectedClassOrMetaClass commentTemplate].
	editSelection == #hierarchy 
		ifTrue: [^self selectedClassOrMetaClass printHierarchy].
	editSelection == #editMessageCategories 
		ifTrue: [^self classOrMetaClassOrganizer printString].
	editSelection == #newMessage ifTrue: [^self selectedClassOrMetaClass sourceCodeTemplate].
	editSelection == #editMessage ifTrue: [^self selectedMessage].
	self error: 'Browser internal error: unknown edit selection.'!
contents: input notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. The information can be a variety of things, depending on the 
	list selections (such as templates for class or message definition, methods) 
	or the user menu commands (such as definition, comment, hierarchy). 
	Answer the result of updating the source."
	| aString aText |
	aString _ input asString.
	aText _ input asText.

	editSelection == #editSystemCategories 
		ifTrue: [^self changeSystemCategories: aString].
	editSelection == #editClass | (editSelection == #newClass) 
		ifTrue: [^self defineClass: aString notifying: aController].
	editSelection == #editComment 
		ifTrue: [^self defineComment: aString notifying: aController].
	editSelection == #hierarchy ifTrue: [^true].
	editSelection == #editMessageCategories 
		ifTrue: [^self changeMessageCategories: aString].
	editSelection == #editMessage | (editSelection == #newMessage) 
		ifTrue: [^self defineMessage: aText notifying: aController].
	editSelection == #none ifTrue: [^true].
	self error: 'unacceptable accept'!
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: SystemCategoryListView] ifNone: [^ false].
	^ true!
doItReceiver
	"This class's classPool has been jimmied to be the classPool of the class being browsed.  A doIt in the code pane will let the user see the value of the class variables."
	^ FakeClassPool new!
editSelection
	^editSelection!
request: prompt initialAnswer: initialAnswer
	| answer |
	FillInTheBlank
		request: prompt
		displayAt: Sensor cursorPoint
		centered: true
		action: [:a | answer _ a] 
		initialAnswer: initialAnswer.
	^ answer
!
spawn: aString 
	"Create and schedule a new browser as though the command browse were 
	issued with respect to one of the browser's lists. The initial textual 
	contents is aString, which is the (modified) textual contents of the 
	receiver."

	messageListIndex ~= 0 
		ifTrue: [^self buildMessageBrowserEditString: aString].
	messageCategoryListIndex ~= 0 
		ifTrue: [^self buildMessageCategoryBrowserEditString: aString].
	classListIndex ~= 0 ifTrue: [^self buildClassBrowserEditString: aString].
	systemCategoryListIndex ~= 0 
		ifTrue: [^self buildSystemCategoryBrowserEditString: aString].
	^BrowserView openBrowserEditString: aString! !

!Browser methodsFor: 'system category list'!
selectedSystemCategoryName
	"Answer the name of the selected system category or nil."

	systemCategoryListIndex = 0 ifTrue: [^nil].
	^self systemCategoryList at: systemCategoryListIndex!
systemCategoryList
	"Answer the class categories modelled by the receiver."

	^systemOrganizer categories!
systemCategoryListIndex
	"Answer the index of the selected class category."

	^systemCategoryListIndex!
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!
toggleSystemCategoryListIndex: anInteger 
	"If anInteger is the current system category index, deselect it. Else make 
	it the current system category selection."

	self systemCategoryListIndex: 
		(systemCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

!Browser methodsFor: 'system category functions'!
addSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	oldIndex _ systemCategoryListIndex.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: 'Category-Name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	systemOrganizer
		addCategory: newName
		before: (systemCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedSystemCategoryName]).
	self changed: #systemCategoriesChanged.
	self systemCategoryListIndex:
		(oldIndex = 0
			ifTrue: [systemOrganizer categories size]
			ifFalse: [oldIndex])!
buildSystemCategoryBrowser
	"Create and schedule a new system category browser."

	self buildSystemCategoryBrowserEditString: nil!
buildSystemCategoryBrowserEditString: aString 
	"Create and schedule a new system category browser with initial textual 
	contents set to aString."

	| newBrowser |
	systemCategoryListIndex > 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			BrowserView openSystemCategoryBrowser: newBrowser editString: aString]!
changeSystemCategories: aString 
	"Update the class categories by parsing the argument aString."

	systemOrganizer changeFromString: aString.
	self systemCategoryListIndex: 0.
	self changed: #systemCategoriesChanged.
	^true!
editSystemCategories
	"Retrieve the description of the class categories of the system organizer."

	self okToChange ifFalse: [^ self].
	self systemCategoryListIndex: 0.
	editSelection _ #editSystemCategories.
	self changed: #editSystemCategories!
fileOutSystemCategories
	"Print a description of each class in the selected category onto a file 
	whose name is the category name followed by .st."

	systemCategoryListIndex ~= 0
		ifTrue: [systemOrganizer fileOutCategory: self selectedSystemCategoryName]!
removeSystemCategory
	"If a class category is selected, create a Confirmer so the user can 
	verify that the currently selected class category and all of its classes
 	should be removed from the system. If so, remove it."

	| classCategoryName |
	systemCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(self classList size = 0
		or: [self confirm: 'Are you sure you want to
remove this system category 
and all its classes?'])
		ifTrue: 
		[systemOrganizer removeSystemCategory: self selectedSystemCategoryName.
		self systemCategoryListIndex: 0.
		self changed: #systemCategoriesChanged]!
renameSystemCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	(oldIndex _ systemCategoryListIndex) = 0
		ifTrue: [^ self].  "no selection"
	self okToChange ifFalse: [^ self].
	oldName _ self selectedSystemCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	oldName = newName ifTrue: [^ self].
	systemOrganizer
		renameCategory: oldName
		toBe: newName.
	self changed: #systemCategoriesChanged.
	self systemCategoryListIndex: oldIndex!
updateSystemCategories
	"The class categories were changed in another browser. The receiver must 
	reorganize its lists based on these changes."

	self okToChange ifFalse: [^ self].
	self systemCategoryListIndex: 0.
	self changed: #systemCategoriesChanged! !

!Browser methodsFor: 'class list'!
classList
	"Answer an array of the class names of the selected category. Answer an 
	empty array if no selection exists."

	systemCategoryListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^systemOrganizer listAtCategoryNumber: systemCategoryListIndex]!
classListIndex
	"Answer the index of the current class selection."

	^classListIndex!
classListIndex: anInteger 
	"Set anInteger to be the index of the current class selection."
	classListIndex _ anInteger.
	self setClassOrganizer.
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	editSelection _ anInteger = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass].
	contents _ nil.
	self changed: #classSelectionChanged!
selectedClass
	"Answer the class that is currently selected. Answer nil if no selection 
	exists."

	self selectedClassName == nil ifTrue: [^nil].
	^Smalltalk at: self selectedClassName!
selectedClassName
	"Answer the name of the current class. Answer nil if no selection exists."

	classListIndex = 0 ifTrue: [^nil].
	^self classList at: classListIndex!
toggleClassListIndex: anInteger 
	"If anInteger is the current class index, deselect it. Else make it the 
	current class selection."

	self classListIndex: 
		(classListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

!Browser methodsFor: 'class functions'!
browseClassRefs

	classListIndex=0 ifTrue: [^ self].
	Smalltalk browseAllCallsOn: (Smalltalk associationAt: self selectedClass name)
!
browseClassVariables
	"Browse the class varialbes of the selected class.  2/5/96 sw"

	classListIndex = 0 ifTrue: [^ self].
	self selectedClass browseClassVariables!
browseClassVarRefs
	"1/17/96 sw: devolve responsibility to the class, so that the code that does the real work can be shared"

	classListIndex=0 ifTrue: [^ self].
	self selectedClass browseClassVarRefs!
browseInstVarDefs 

	classListIndex = 0 ifTrue: [^ self].
	self selectedClassOrMetaClass browseInstVarDefs!
browseInstVarRefs 
	"1/26/96 sw: real work moved to class, so it can be shared"

	classListIndex = 0 ifTrue: [^ self].
	self selectedClassOrMetaClass browseInstVarRefs!
buildClassBrowser
	"Create and schedule a new class category browser for the current class 
	selection, if one exists."

	self buildClassBrowserEditString: nil!
buildClassBrowserEditString: aString 
	"Create and schedule a new class browser for the current selection, if one 
	exists, with initial textual contents set to aString."

	| newBrowser myClass |
	classListIndex ~= 0 ifTrue: 
		[newBrowser _ Browser new.
		newBrowser systemCategoryListIndex: systemCategoryListIndex.
		newBrowser classListIndex: classListIndex.
		newBrowser metaClassIndicated: metaClassIndicated.

		myClass _ self selectedClassOrMetaClass.
		myClass notNil ifTrue: [
			Browser postOpenSuggestion: 
				(Array with: myClass with: self selectedMessageName)].

		BrowserView openClassBrowser: newBrowser editString: aString label: 'Class Browser: ', myClass name]!
defineClass: aString notifying: aController 
	"The receiver's textual content is a request to define a new class. The 
	source code is aString. If any errors occur in compilation, notify 
	aController."

	| oldClass class |
	oldClass _ self selectedClassOrMetaClass.
	oldClass isNil ifTrue: [oldClass _ Object].
	class _ oldClass subclassDefinerClass
				evaluate: aString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: 
			[self changed: #classListChanged.
			self classListIndex: 
				(self classList indexOf: 
					((class isKindOf: Metaclass)
						ifTrue: [class soleInstance name]
						ifFalse: [class name])).
			self unlock; editClass.
			^true]
		ifFalse: [^false]!
defineComment: aString notifying: aController 
	"The receiver's textual content is a request to define a new comment for 
	the selected class. The comment is defined by the message expression, 
	aString. If any errors occur in evaluation, notify aController."

	| oldClass class |
	oldClass _ self selectedClassOrMetaClass.
	oldClass isNil ifTrue: [oldClass _ Object].
	class _ oldClass evaluatorClass
				evaluate: aString
				notifying: aController
				logged: true.
	(class isKindOf: Behavior)
		ifTrue: 
			[self unlock; editComment. ^true]
		ifFalse: [^false]!
editClass
	"Retrieve the description of the class definition."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editClass.
	self changed: #editClass!
editComment
	"Retrieve the description of the class comment."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #editComment.
	self changed: #editClass!
explainSpecial: string 
	"Answer a string explaining the code pane selection if it is displaying 
	one of the special edit functions."

	| classes whole lits reply |
	(editSelection == #editClass or: [editSelection == #newClass])
		ifTrue: 
			["Selector parts in class definition"
			string last == $: ifFalse: [^nil].
			lits _ Array with:
				#subclass:instanceVariableNames:classVariableNames:poolDictionaries:category:.
			(whole _ lits detect: [:each | (each keywords
					detect: [:frag | frag = string] ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifTrue: [reply _ '"' , string , ' is one part of the message selector ' , whole , '.']
				ifFalse: [^nil].
			classes _ Smalltalk allClassesImplementing: whole.
			classes _ 'these classes ' , classes printString.
			^reply , '  It is defined in ' , classes , '."
Smalltalk browseAllImplementorsOf: #' , whole].

	editSelection == #hierarchy
		ifTrue: 
			["Instance variables in subclasses"
			classes _ self selectedClassOrMetaClass allSubclasses.
			classes _ classes detect: [:each | (each instVarNames
						detect: [:name | name = string] ifNone: []) ~~ nil]
					ifNone: [^nil].
			classes _ classes printString.
			^'"is an instance variable in class ' , classes , '."
' , classes , ' browseAllAccessesTo: ''' , string , '''.'].
	editSelection == #editSystemCategories ifTrue: [^nil].
	editSelection == #editMessageCategories ifTrue: [^nil].
	^nil!
fileOutClass
	"Print a description of the selected class onto a file whose name is the 
	category name followed by .st."

	classListIndex ~= 0 ifTrue: [self selectedClass fileOut]!
hierarchy
	"Retrieve a description of the superclass chain and subclasses of the 
	selected class."

	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	self messageCategoryListIndex: 0.
	editSelection _ #hierarchy.
	self changed: #editComment!
removeClass
	"The selected class should be removed from the system. Use a Confirmer 
	to make certain the user intends this irrevocable command to be carried 
	out."
	| message class className |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	class _ self selectedClass.
	className _ class name.
	message _ 'Are you certain that you
want to delete the class ', className, '?'.
	(self confirm: message) ifTrue: 
			[class subclasses size > 0
				ifTrue: [self notify: 'class has subclasses: ' , message].
			class removeFromSystem.
			self classListIndex: 0.
			self changed: #classListChanged]!
renameClass
	| oldName newName obs |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	oldName _ self selectedClass name.
	newName _ (self request: 'Please type new class name'
						initialAnswer: oldName) asSymbol.
	newName = oldName ifTrue: [^ self].
	(Smalltalk includesKey: newName)
		ifTrue: [^ self error: newName , ' already exists'].
	self selectedClass rename: newName.
	self changed: #classListChanged.
	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'!
messageCategoryList
	"Answer the selected category of messages."

	classListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^self classOrMetaClassOrganizer categories]!
messageCategoryListIndex
	"Answer the index of the selected message category."

	^messageCategoryListIndex!
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!
selectedMessageCategoryName
	"Answer the name of the selected message category, if any. Answer nil 
	otherwise."

	messageCategoryListIndex = 0 ifTrue: [^nil].
	^self messageCategoryList at: messageCategoryListIndex!
toggleMessageCategoryListIndex: anInteger 
	"If the currently selected message category index is anInteger, deselect 
	the category. Otherwise select the category whose index is anInteger."

	self messageCategoryListIndex: 
		(messageCategoryListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

!Browser methodsFor: 'message category functions'!
addCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex newName |
	self okToChange ifFalse: [^ self].
	classListIndex = 0 ifTrue: [^ self].
	oldIndex _ messageCategoryListIndex.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: 'category name'.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	self classOrMetaClassOrganizer
		addCategory: newName
		before: (messageCategoryListIndex = 0
				ifTrue: [nil]
				ifFalse: [self selectedMessageCategoryName]).
	self changed: #classSelectionChanged.
	self messageCategoryListIndex:
		(oldIndex = 0
			ifTrue: [self selectedClass organization categories size]
			ifFalse: [oldIndex])!
buildMessageCategoryBrowser
	"Create and schedule a message category browser for the currently 
	selected message category."

	self buildMessageCategoryBrowserEditString: nil!
buildMessageCategoryBrowserEditString: aString 
	"Create and schedule a message category browser for the currently 
	selected	 message category. The initial text view contains the characters 
	in aString."

	| newBrowser |
	messageCategoryListIndex ~= 0
		ifTrue: 
			[newBrowser _ Browser new.
			newBrowser systemCategoryListIndex: systemCategoryListIndex.
			newBrowser classListIndex: classListIndex.
			newBrowser metaClassIndicated: metaClassIndicated.
			newBrowser messageCategoryListIndex: messageCategoryListIndex.
			BrowserView openMessageCategoryBrowser: newBrowser editString: aString]!
changeMessageCategories: aString 
	"The characters in aString represent an edited version of the the message 
	categories for the selected class. Update this information in the system 
	and inform any dependents that the categories have been changed. This 
	message is invoked because the user had issued the categories command 
	and edited the message categories. Then the user issued the accept 
	command."

	self classOrMetaClassOrganizer changeFromString: aString.
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self unlock.
	self editClass.
	self classListIndex: classListIndex.
	^ true!
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]!
fileOutMessageCategories
	"Print a description of the selected message category of the selected class 
	onto an external file."

	messageCategoryListIndex ~= 0
		ifTrue: 
			[self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName]!
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."

	| warning messageCategoryName |
	messageCategoryListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	messageCategoryName _ self selectedMessageCategoryName.
	(self messageList size = 0
		or: [self confirm: 'Are you sure you want to
remove this method category 
and all its methods?'])
		ifTrue: 
			[self selectedClassOrMetaClass removeCategory: messageCategoryName.
			self messageCategoryListIndex: 0.
			self changed: #classSelectionChanged]!
renameCategory
	"Prompt for a new category name and add it before the
	current selection, or at the end if no current selection"
	| oldIndex oldName newName |
	classListIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	(oldIndex _ messageCategoryListIndex) = 0 ifTrue: [^ self].
	oldName _ self selectedMessageCategoryName.
	newName _ self
		request: 'Please type new category name'
		initialAnswer: oldName.
	newName isEmpty
		ifTrue: [^ self]
		ifFalse: [newName _ newName asSymbol].
	newName = oldName ifTrue: [^ self].
	self classOrMetaClassOrganizer
		renameCategory: oldName
		toBe: newName.
	Smalltalk changes reorganizeClass: self selectedClassOrMetaClass.
	self classListIndex: classListIndex.
	self messageCategoryListIndex: oldIndex! !

!Browser methodsFor: 'message list'!
messageList
	"Answer an Array of the message selectors of the currently selected 
	message category. Otherwise, answer a new empty Array."

	messageCategoryListIndex = 0
		ifTrue: [^Array new]
		ifFalse: [^self classOrMetaClassOrganizer 
					listAtCategoryNumber: messageCategoryListIndex]!
messageListIndex
	"Answer the index of the selected message selector into the currently 
	selected message category."

	^messageListIndex!
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: #messageSelectionChanged!
selectedMessage
	"Answer a copy of the source code for the selected message selector."

	contents == nil 
		ifTrue: [contents _ 
					self selectedClassOrMetaClass 
						sourceCodeAt: self selectedMessageName].
	^contents copy!
selectedMessageName
	"Answer the message selector of the currently selected message, if any. 
	Answer nil otherwise."

	messageListIndex = 0 ifTrue: [^nil].
	^self messageList at: messageListIndex!
toggleMessageListIndex: anInteger 
	"If the currently selected message index is anInteger, deselect the message 
	selector. Otherwise select the message selector whose index is anInteger."

	self messageListIndex: 
		(messageListIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])! !

!Browser methodsFor: 'message functions'!
browseAllMessages
	"Create and schedule a message set browser on all implementors of all
	the messages sent by the current method.  Created 1991 by tck;
	mofified 1/26/96 sw: put appropriate title on the window"

	| aClass aName |
	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOfList:
				((aClass _ self selectedClassOrMetaClass) compiledMethodAt: (aName _ self selectedMessageName))
					messages asSortedCollection title:
		'All messages sent in ', aClass name, '.', aName]!
browseImplementors
	"Create and schedule a message set browser on all implementors of the 
	currently selected message selector. Do nothing if no message is selected."

	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]!
browseMessages
	"Show a menu of all messages sent by the currently selected message. 
	Create and schedule a message set browser of all implementors of the 
	message chosen. Do nothing if no message is chosen."

	messageListIndex = 0 ifTrue: [^self].
	Smalltalk showMenuThenBrowse:
		(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			messages asSortedCollection!
browseSenders
	"Create and schedule a message set browser on all methods in which the 
	currently selected message selector is sent. Do nothing if no message is 
	selected."

	messageListIndex ~= 0 
		ifTrue: [Smalltalk browseAllCallsOn: self selectedMessageName]!
browseSendersOfMessages
	"Show a menu of all messages sent by the currently selected message. 
	Create and schedule a message set browser of all implementors of the 
	message chosen. Do nothing if no message is chosen."

	messageListIndex = 0 ifTrue: [^self].
	Smalltalk showMenuThenBrowseSendersOf:
		(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			messages asSortedCollection!
browseVersions
	"Create and schedule a message set browser on all versions of the 
	currently selected message selector."
	| class selector |
	messageListIndex ~= 0 ifTrue:
		[class _ self selectedClassOrMetaClass.
		selector _ self selectedMessageName.
		ChangeList
			browseVersionsOf: (class compiledMethodAt: selector)
			class: self selectedClass
			meta: self metaClassIndicated
			category: self selectedMessageCategoryName
			selector: selector]!
buildMessageBrowser
	"Create and schedule a message browser on the currently selected 
	message. Do nothing if no message is selected. The initial text view 
	contains nothing."

	self buildMessageBrowserEditString: nil!
buildMessageBrowserEditString: aString 
	"Create and schedule a message browser for the receiver in which the 
	argument, aString, contains characters to be edited in the text view."

	messageListIndex = 0 ifTrue: [^ self].
	^ BrowserView
		openMessageBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName
		editString: aString!
defineMessage: aString notifying: aController 
	"Compile the expressions in aString. Notify aController if a syntax error 
	occurs. Install the compiled method in the selected class classified under 
	the currently selected message category name. Answer true if 
	compilation succeeds, false otherwise."

	| selectedMessageName selector category oldMessageList notice |
	selectedMessageName _ self selectedMessageName.
	oldMessageList _ self messageList.
	contents _ nil.
	selector _ 
		self selectedClassOrMetaClass
				compile: aString
				classified: (category _ self selectedMessageCategoryName)
				notifying: aController.
	notice _ self selectedClassOrMetaClass checkForPerform: selector in: aController.
	selector == nil ifTrue: [^false].
	contents _ aString copy.
	selector ~~ selectedMessageName
		ifTrue: 
			[category = ClassOrganizer nullCategory
				ifTrue: [self changed: #classSelectionChanged.
						self messageCategoryListIndex: 1].
			self setClassOrganizer.  "In case organization not cached"
			(oldMessageList includes: selector)
				ifFalse: [self changed: #messageListChanged].
			self messageListIndex: (self messageList indexOf: selector)].
	notice size = 0 ifFalse: ["insert the notice"
			aController notify: notice
				at: contents size + 1
				in: nil.
			self lock  "code is dirty"].
	^true!
fileOutMessage
	"Print a description of the selected message on the serial printer.
	4/11/96 tk - header, trailer"
	| fileStream |
	messageListIndex = 0 ifTrue: [^ self].
	fileStream _ FileStream newFileNamed: (self selectedClassOrMetaClass name , '-' , (self selectedMessageName copyReplaceAll: ':' with: '')) , '.st'.
	fileStream header; timeStamp.
	self selectedClassOrMetaClass printCategoryChunk: self selectedMessageCategoryName
		on: fileStream.
	self selectedClassOrMetaClass printMethodChunk: self selectedMessageName
		on: fileStream
		moveSource: false
		toFile: 0.
	fileStream nextChunkPut: ' '.
	fileStream trailer; close!
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.
	1/15/96 sw: started to modify as per Dan's request"

	| message 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 setClassOrganizer.  "In case organization not cached"
	self changed: #messageListChanged.

	confirmation == 2 ifTrue:
		[Smalltalk sendersOf: messageName]! !

!Browser methodsFor: 'metaclass'!
classMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	metaclass."

	^metaClassIndicated!
classOrMetaClassOrganizer
	"Answer the class organizer for the metaclass or class, depending on 
	which (instance or class) is indicated."

	metaClassIndicated
		ifTrue: [^metaClassOrganizer]
		ifFalse: [^classOrganizer]!
indicateClassMessages
	"Indicate that the message selection should come from the metaclass 
	messages."

	self metaClassIndicated: true!
indicateInstanceMessages
	"Indicate that the message selection should come from the class (instance) 
	messages."

	self metaClassIndicated: false!
instanceMessagesIndicated
	"Answer whether the messages to be presented should come from the 
	class."

	^metaClassIndicated not!
metaClassIndicated
	"Answer the boolean flag that indicates which of the method dictionaries, 
	class or metaclass."

	^metaClassIndicated!
metaClassIndicated: trueOrFalse 
	"Indicate whether browsing instance or class messages."
	metaClassIndicated _ trueOrFalse.
	self setClassOrganizer.
	systemCategoryListIndex > 0 ifTrue:
		[editSelection _ classListIndex = 0
			ifTrue: [metaClassIndicated
				ifTrue: [#none]
				ifFalse: [#newClass]]
			ifFalse: [#editClass]].
	messageCategoryListIndex _ 0.
	messageListIndex _ 0.
	contents _ nil.
	self changed: #classSelectionChanged!
selectedClassOrMetaClass
	"Answer the selected class or metaclass."

	metaClassIndicated
		ifTrue: [^self selectedClass class]
		ifFalse: [^self selectedClass]!
selectedClassOrMetaClassName
	"Answer the selected class name or metaclass name."

	^self selectedClassOrMetaClass name!
setClassOrganizer
	"Install whatever organization is appropriate"
	classOrganizer _ nil.
	metaClassOrganizer _ nil.
	classListIndex = 0 ifTrue: [^ self].
	metaClassIndicated
		ifTrue: [metaClassOrganizer _ self selectedClass class organization]
		ifFalse: [classOrganizer _ self selectedClass organization]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Browser class
	instanceVariableNames: ''!

!Browser class methodsFor: 'instance creation'!
new

	^super new systemOrganizer: SystemOrganization!
newOnCategory: aCategory
	"Browse the system category of the given name.  7/13/96 sw"

	"Browser newOnCategory: 'Interface-Browser'"

	| newBrowser catList |
	newBrowser _ Browser new.
	catList _ newBrowser systemCategoryList.
	newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']).
	BrowserView openSystemCategoryBrowser: newBrowser label: aCategory editString: nil!
newOnClass: aClass 
	"Open a new class browser on this class."

	| index each newBrowser |
	newBrowser _ Browser new.
	newBrowser systemCategoryListIndex:
		(index _ SystemOrganization numberOfCategoryOfElement: aClass name).
	newBrowser classListIndex: ((SystemOrganization listAtCategoryNumber: index)
			findFirst: [:each | each == aClass name]).
	newBrowser metaClassIndicated: false.
	BrowserView openClassBrowser: newBrowser editString: nil label: 'Class Browser:', aClass name!
postOpenSuggestion
	"Holds class and sel to select after opening"
	^ PostOpenSuggestion!
postOpenSuggestion: anArray
	"Holds class and sel to select after opening"
	PostOpenSuggestion _ anArray! !StringHolderController subclass: #BrowserCodeController
	instanceVariableNames: ''
	classVariableNames: 'NewLine '
	poolDictionaries: ''
	category: 'Interface-Browser'!
BrowserCodeController comment:
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). I provide control for editing methods in a browser. New commands are:
	explain	insert an explanation of the current selection just after it
	format	pretty-print of the code, do not issue an automatic accept
	spawn	create and schedule a message browser for the, possibly edited but not accepted, code.'!

!BrowserCodeController methodsFor: 'menu messages'!
accept

	model isUnlocked ifTrue: [^view flash].
	self controlTerminate.
	(model contents: paragraph text notifying: self) ifTrue: [super accept].
	self controlInitialize!
cancel
	model isUnlocked ifTrue: [^ view flash].
	super cancel!
doIt
	"Allow class variables and pool variables of current class to be accessed in the doIt"
	| result |
	model selectedClass == nil ifTrue: [^ super doIt].
	FakeClassPool classPool: model selectedClass classPool.
	FakeClassPool sharedPools: model selectedClass sharedPools.
	result _ super doIt.
	FakeClassPool classPool: nil.
	FakeClassPool sharedPools: nil.
	^ result!
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 symbol sorry reply |
	Cursor execute
		showWhile: 
			[sorry _ '"Sorry, I can''t explain that.  Please select a single token, construct, or special character.'.
			sorry _ sorry , (model isUnlocked
							ifTrue: ['"']
							ifFalse: ['  Also, please cancel or accept."']).
			(string _ self selection asString) isEmpty
				ifTrue: [reply _ '']
				ifFalse: 
					[string _ self explainScan: string.
					"Remove space, tab, cr"
					"Temps and Instance vars need only test strings that are 
					all  
					letters"
					(string detect: [:char | (char isLetter or: [char isDigit]) not]
						ifNone: [])
						~~ nil
						ifFalse: 
							[tiVars _ self explainTemp: string.
							tiVars == nil ifTrue: [tiVars _ self explainInst: string]].
					(tiVars == nil and: [model class == Browser])
						ifTrue: [tiVars _ model explainSpecial: string].
					tiVars == nil
						ifTrue: [tiVars _ '']
						ifFalse: [tiVars _ tiVars , NewLine].
					"Context, Class, Pool, and Global vars, and Selectors need 
					only test symbols"
					(Symbol hasInterned: string ifTrue: [:symbol | symbol])
						ifTrue: 
							[cgVars _ self explainCtxt: symbol.
							cgVars == nil
								ifTrue: 
									[cgVars _ self explainClass: symbol.
									cgVars == nil ifTrue: [cgVars _ self explainGlobal: symbol]].
							"See if it is a Selector (sent here or not)"
							selectors _ self explainMySel: symbol.
							selectors == nil
								ifTrue: 
									[selectors _ self explainPartSel: string.
									selectors == nil ifTrue: [selectors _ self explainAnySel: symbol]]]
						ifFalse: [selectors _ self explainPartSel: string].
					cgVars == nil
						ifTrue: [cgVars _ '']
						ifFalse: [cgVars _ cgVars , NewLine].
					selectors == nil
						ifTrue: [selectors _ '']
						ifFalse: [selectors _ selectors , NewLine].
					string size = 1
						ifTrue: ["single special characters"
							delimitors _ self explainChar: string]
						ifFalse: ["matched delimitors"
							delimitors _ self explainDelimitor: string].
					numbers _ self explainNumber: string.
					numbers == nil ifTrue: [numbers _ ''].
					delimitors == nil ifTrue: [delimitors _ ''].
					reply _ tiVars , cgVars , selectors , delimitors , numbers].
			reply size = 0 ifTrue: [reply _ sorry].
			self afterSelectionInsertAndSelect: reply]!
format
	"Reformat the contents of the receiver's view, formatted, if the view is unlocked. "

	| selectedClass aCompiler newText locked |
	locked _ model isLocked.
	Sensor leftShiftDown
		ifTrue: [self miniFormat]
		ifFalse: 
			[model messageListIndex = 0 | locked ifTrue: [^view flash].
			selectedClass _ model selectedClassOrMetaClass.
			Cursor execute showWhile: 
				[aCompiler _ selectedClass compilerClass new.
				self deselect; selectInvisiblyFrom: 1 to: paragraph text size.
				newText _ aCompiler
					format: model contents
					in: selectedClass
					notifying: self.
				newText == nil ifFalse: 
					[self replaceSelectionWith:
						(newText asText makeSelectorBoldIn: selectedClass).
					self selectAt: 1]]].
	locked ifFalse: [self unlockModel]!
inspectIt
	"Allow class variables and pool variables of current class to be accessed in the inspectIt.  6/13/96 sw"

	| result |

	model selectedClass == nil ifTrue: [^ super inspectIt].
	FakeClassPool classPool: model selectedClass classPool.
	FakeClassPool sharedPools: model selectedClass sharedPools.
	self controlTerminate.

	result _ self evaluateSelection.
	FakeClassPool classPool: nil.
	FakeClassPool sharedPools: nil.

	((result isKindOf: FakeClassPool) or:
		[result == #failedDoit])
			ifFalse: [result inspect]
			ifTrue: [view flash].
	self controlInitialize.

	^ result!
spawn
	"Create and schedule a message browser for the code of the model's 
	selected message. Retain any edits that have not yet been accepted."

	| code |
	code _ paragraph text string.
	self cancel.
	self controlTerminate.
	model spawn: code.
	self controlInitialize!
spawnIt: characterStream 
	"Triggered by Cmd-o; spawn a new code window, if it makes sense.  Reimplemented by BrowserCodeController  2/1/96 sw.  Fixed, 2/5/96 sw, so that it really works."

	self controlTerminate.
	sensor keyboard.	
	self spawn.
	self controlInitialize.
	^ true! !

!BrowserCodeController methodsFor: 'private'!
explainAnySel: symbol 
	"Is this any message selector?"

	| list reply |
	list _ Smalltalk allClassesImplementing: symbol.
	list size = 0 ifTrue: [^nil].
	list size < 12
		ifTrue: [reply _ ' is a message selector which is defined in these classes ' , list printString]
		ifFalse: [reply _ ' is a message selector which is defined in many classes'].
	^'"' , symbol , reply , '."', NewLine, 'Smalltalk browseAllImplementorsOf: #' , symbol!
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 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."'].
	(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).', NewLine, NewLine, '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!
explainClass: symbol 
	"Is symbol a class variable or a pool variable?"

	| class name pool reply classes |
	class _ model selectedClass.
	class == nil ifTrue: [^nil].	  "no class is selected"
	(class isKindOf: Metaclass) ifTrue: [class _ class soleInstance].
	classes _ (Array with: class) , class allSuperclasses.

	"class variables"
	reply _ classes detect: [:each | (each classVarNames
			detect: [:name | symbol = name] ifNone: [])
			~~ nil] ifNone: [].
	reply == nil ifFalse: [^'"is a class variable; defined in class ' , reply printString, '"', NewLine,
		'Smalltalk browseAllCallsOn: (', reply printString, ' classPool associationAt: #', symbol, ').'].

	"pool variables"
	classes do: [:each | (each sharedPools
			detect: [:pool | (pool includesKey: symbol) and: [reply _ pool. true]]
			ifNone: []) ~~ nil].
	reply == nil ifTrue: [(Undeclared includesKey: symbol) ifTrue: [reply _ Undeclared]].
	reply == nil
		ifFalse: 
			[classes _ WriteStream on: Array new.
			Smalltalk allBehaviorsDo: [:each |
					(each sharedPools detect: [:pool | pool == reply] ifNone: [])
					~~ nil ifTrue: [classes nextPut: each]].
			"Perhaps not print whole list of classes if too long. (unlikely)"
			^'"is a pool variable from the pool ' , (Smalltalk keyAtValue: reply),
			', which is used by the following classes ' , classes contents printString , '"', NewLine,
			'Smalltalk browseAllCallsOn: (', (Smalltalk keyAtValue: reply) printString,
			' associationAt: #', symbol, ').'].
	^nil!
explainCtxt: symbol 
	"Is symbol a context variable?"

	| reply classes text |
	symbol = #nil ifTrue: [reply _ '"is a constant.  It is the only instance of class UndefinedObject.  nil is the initial value of all variables."'].
	symbol = #true ifTrue: [reply _ '"is a constant.  It is the only instance of class True and is the receiver of many control messages."'].
	symbol = #false ifTrue: [reply _ '"is a constant.  It is the only instance of class False and is the receiver of many control messages."'].
	model messageListIndex = 0 ifTrue: [^nil].	  "no message selected"
	symbol = #self
		ifTrue: 
			[classes _ model selectedClassOrMetaClass withAllSubclasses.
			classes size > 12
				ifTrue: [text _ model selectedClassOrMetaClass printString , ' or a subclass']
				ifFalse: 
					[classes _ classes printString.
					text _ 'one of these classes' , (classes copyFrom: 4 to: classes size)].
			reply _ '"is the receiver of this message; an instance of ' , text , '"'].
	symbol = #super ifTrue: [reply _ '"is just like self.  Messages to super are looked up in the superclass (' , model selectedClassOrMetaClass superclass printString , ')"'].
	symbol = #thisContext ifTrue: [reply _ '"is a context variable.  It''s value is always the MethodContext which is executing this method."'].
	^reply!
explainDelimitor: string
	"Is string enclosed in delimitors?"

	| str |
	(string at: 1) isLetter ifTrue: [^nil].  "only special chars"
	(string first = string last) ifTrue:
			[^ self explainChar: (String with: string first)]
		ifFalse:
			[(string first = $( and: [string last = $)]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $[ and: [string last = $]]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $< and: [string last = $>]) ifTrue:
				[^ self explainChar: (String with: string first)].
			(string first = $# and: [string last = $)]) ifTrue:
				[^'"An instance of class Array.  The Numbers, Characters, or Symbols between the parenthesis are the elements of the Array."'].
			string first = $# ifTrue:
				[^'"An instance of class Symbol."'].
			(string first = $$ and: [string size = 2]) ifTrue:
				[^'"An instance of class Character.  This one is the character ', (String with: string last), '."'].
			(string first = $:) ifTrue:
				[str _ (string copyFrom: 2 to: string size).
				(self explainTemp: str) ~~ nil ifTrue:
					[^'"An argument to this block will be bound to the temporary variable ',
						str, '."']]].
	^ nil!
explainGlobal: symbol 
	"Is symbol a global variable?"

	| each pool reply classes |
	reply _ Smalltalk at: symbol ifAbsent: [^nil].
	(reply isKindOf: Behavior)
		ifTrue: [^'"is a global variable.  ' , symbol , ' is a class in category ', reply category,
			'."', NewLine, 'Browser newOnClass: ' , symbol , '.'].
	symbol == #Smalltalk ifTrue: [^'"is a global.  Smalltalk is the only instance of SystemDictionary and holds all global variables."'].
	reply class == Dictionary
		ifTrue: 
			[classes _ Set new.
			Smalltalk allBehaviorsDo: [:each | (each sharedPools detect: [:pool | pool == reply]
					ifNone: [])
					~~ nil ifTrue: [classes add: each]].
			classes _ classes printString.
			^'"is a global variable.  ' , symbol , ' is a Dictionary.  It is a pool which is used by the following classes' , (classes copyFrom: 4 to: classes size) , '"'].
	^'"is a global variable.  ' , symbol , ' is ' , reply printString , '"'!
explainInst: string 
	"Is string an instance variable of this class?"

	| name each classes |
	model selectedClassOrMetaClass == nil ifTrue: [^nil].	  "no class is selected"
	classes _ (Array with: model selectedClassOrMetaClass)
				, model selectedClassOrMetaClass allSuperclasses.
	classes _ classes detect: [:each | (each instVarNames
			detect: [:name | name = string] ifNone: [])
			~~ nil] ifNone: [^nil].
	classes _ classes printString.
	^ '"is an instance variable of the receiver; defined in class ' , classes , '"',
		NewLine , classes , ' browseAllAccessesTo: ''' , string , '''.'!
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 |
	model messageListIndex = 0 ifTrue: [^nil].	"not in a message"
	classes _ Smalltalk allClassesImplementing: symbol.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	model selectedMessageName = 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 and use yellowbug to select ''implementors''."']
		ifFalse: 
			[lits _ (model selectedClassOrMetaClass compiledMethodAt:
				model selectedMessageName) 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 and use yellowbug to select ''messages''."'].!
explainNumber: string 
	"Is string a Number?"

	| strm c |
	(c _ string at: 1) isDigit ifFalse: [(c = $- and: [string size > 1])
			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 , '"']!
explainPartSel: string 
	"Is this a fragment of a multiple-argument selector sent in this method?"

	| lits frag whole reply classes s |
	model messageListIndex = 0 ifTrue: [^nil].  "not in a message"
	string last == $: ifFalse: [^nil].
	"Name of this method"
	lits _ Array with: model selectedMessageName.
	(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
					ifNone: []) ~~ nil]
				ifNone: []) ~~ nil
		ifTrue: [reply _ ', which is the selector of this very method!!'.
			s _ '.  To see the other definitions, go to the message list pane and use yellowbug to select ''implementors''."']
		ifFalse: 
			["Selectors called from this method"
			lits _ (model selectedClassOrMetaClass compiledMethodAt:
				model selectedMessageName) messages.
			(whole _ lits detect: [:each | (each keywords detect: [:frag | frag = string]
							ifNone: []) ~~ nil]
						ifNone: []) ~~ nil
				ifFalse: [string = 'primitive:'
					ifTrue: [^self explainChar: '<']
					ifFalse: [^nil]].
			reply _ '.'.
			s _ '.  To see the definitions, go to the message list pane and use yellowbug to select ''messages''."'].
	classes _ Smalltalk allClassesImplementing: whole.
	classes size > 12
		ifTrue: [classes _ 'many classes']
		ifFalse: [classes _ 'these classes ' , classes printString].
	^ '"' , string , ' is one part of the message selector ' , whole, reply , '  It is defined in ' , classes , s!
explainScan: string 
	"Remove beginning and trailing space, tab, cr."

	| c beg end |
	beg _ 1.
	end _ string size.
	
	[beg = end ifTrue: [^string copyFrom: 1 to: 1].
	"if all blank, tell about the first"
	c _ string at: beg.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [beg _ beg + 1].
	
	[c _ string at: end.
	c = Character space or: [c = Character tab or: [c = Character cr]]]
		whileTrue: [end _ end - 1].
	^string copyFrom: beg to: end	"Return purely visible characters"!
explainTemp: string 
	"Is string the name of a temporary variable (or block argument variable)?"

	| selectedClass tempNames i reply methodNode method |
	model messageListIndex = 0 ifTrue: [^nil].	"no message is selected"
	selectedClass _ model selectedClassOrMetaClass.
	tempNames _ selectedClass parserClass new parseArgsAndTemps: model selectedMessage notifying: nil.
	method _ selectedClass compiledMethodAt: model selectedMessageName.
	(i _ tempNames findFirst: [:each | each = string]) = 0 ifTrue: [
		(method numTemps > tempNames size)
			ifTrue: 
				["It must be an undeclared block argument temporary"
				methodNode _ selectedClass compilerClass new
							parse: model selectedMessage
							in: model selectedClassOrMetaClass
							notifying: nil.
				tempNames _ methodNode tempNames]
			ifFalse: [^nil]].
	(i _ tempNames findFirst: [:each | each = string]) > 0 ifTrue: [i > method numArgs
			ifTrue: [reply _ '"is a temporary variable in this method"']
			ifFalse: [reply _ '"is an argument to this method"']].
	^reply!
miniFormat
	"Replace selection with selection un-wrapped."

	| inStream outStream char |
	inStream _ ReadStream on: (self selection copyWithout: Character tab).
	outStream _ WriteStream on: (String new: self selection size).
	[inStream atEnd]
		whileFalse: 
			[char _ inStream next.
			char isSeparator
				ifTrue: 
					[outStream space.
					[inStream atEnd not and: [inStream peek isSeparator]]
						whileTrue: [inStream next]]
				ifFalse: [outStream nextPut: char]].
	self deselect.
	self replaceSelectionWith: outStream contents asText.
	self select! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BrowserCodeController class
	instanceVariableNames: ''!

!BrowserCodeController class methodsFor: 'class initialization'!
initialize
	"BrowserCodeController initialize"
	"1/8/96 sw: added senders/implementors/references.  1/15/96 added browse it.
	1/22/96 sw: show command-key equivalents
	1/24/96 sw: put many into shifted side, added find & more etc.
	1/26/96 sw: fixed up cmd key equivalent
	1/31/96 sw: BrowserCodeYellowButtonMenu/Msgs no longer used"

	NewLine _ String with: Character cr.  "used to append cr in explain messages"
	self allInstancesDo: [:i | i initializeYellowButtonMenu]! !

BrowserCodeController initialize!
StringHolderView subclass: #BrowserCodeView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Browser'!
BrowserCodeView comment:
'I am a StringHolderView of the source code retrieved in a Browser. BrowserCodeController is my default controller.'!

!BrowserCodeView methodsFor: 'controller access'!
defaultControllerClass

	^BrowserCodeController! !

!BrowserCodeView methodsFor: 'updating'!
update: aSymbol
	aSymbol == #messageListChanged ifTrue: [^ self].
	aSymbol == #classListChanged ifTrue: [^ self].
	aSymbol == #autoSelect ifTrue:
		[controller setSearch: model autoSelectString;
				againOrSame: true.
		^ self].
	^ super update: aSymbol!
updateDisplayContents 
	"Refer to the comment in StringHolderView|updateDisplayContents."

	| contents |
	contents _ model contents.
	displayContents asString ~= contents
		ifTrue: 
			[model messageListIndex ~= 0
				ifTrue: [contents _ contents asText
								makeSelectorBoldIn: model selectedClassOrMetaClass].
			self editString: contents.
			self displayView.
			model editSelection == #newMessage ifTrue:
				[controller selectFrom: 1 to: contents size]]! !ListController subclass: #BrowserListController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Browser'!
BrowserListController comment:
'I am a kind of ListController that blocks new selections if the model is locked--i.e., has been changed in some way that still requires completion.'!

!BrowserListController methodsFor: 'control defaults'!
redButtonActivity
	model okToChange  "Dont change selection if model is locked"
		ifTrue: [^ super redButtonActivity]! !ListView subclass: #BrowserListView
	instanceVariableNames: 'singleItemMode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Browser'!
BrowserListView comment:
'I am a ListView whose items are elements of the system, such as class categories or class names. I am abstract; my subclasses provide the connection between items to be viewed and aspects of an instance of Browser.'!

!BrowserListView methodsFor: 'initialize-release'!
initialize

	singleItemMode _ false.
	super initialize! !

!BrowserListView methodsFor: 'accessing'!
singleItemMode
	"Answer whether the list contains one item."

	^singleItemMode!
singleItemMode: aBoolean 
	"The argument indicates whether the list contains one element. If it does, 
	select it."

	singleItemMode _ aBoolean.
	singleItemMode ifTrue: [selection _ 1]! !

!BrowserListView methodsFor: 'selecting'!
findSelection: aPoint 
	"Refer to the comment in ListView|findSelection:."

	singleItemMode
		ifTrue: 
			[self flash.
			^nil]
		ifFalse: [^super findSelection: aPoint]! !

!BrowserListView methodsFor: 'updating'!
getList
	"Answer an Array of the items in the list."

	self subclassResponsibility!
getListAndDisplayView
	"Display the list of items."

	| newList |
	newList _ self getList.
	isEmpty & newList isEmpty
		ifTrue: [^self]
		ifFalse: 
			[self list: newList.
			self displayView; emphasizeView]! !

!BrowserListView methodsFor: 'model access'!
model: aBrowser

	super model: aBrowser.
	self list: self getList.
	singleItemMode ifTrue: [selection _ 1]! !

!BrowserListView methodsFor: 'list access'!
list: anArray 
	"Refer to the comment in ListView|list:."

	super list: anArray.
	singleItemMode ifTrue: [selection _ 1]! !StandardSystemView subclass: #BrowserView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Browser'!
BrowserView comment:
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the various system browsers: System Browser, System Category Browser, Class Browser, Message Category Browser, Message Browser. The number of subViews I contain depends on which of the browsing functions I am providing.'!

!BrowserView methodsFor: 'emphasis'!
emphasizeSubViews
	"Give the model a chance to know that things may have changed behind its back.  8/5/96 sw"

	model browserWindowActivated.
	super emphasizeSubViews! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

BrowserView class
	instanceVariableNames: ''!

!BrowserView class methodsFor: 'instance creation'!
browser: aBrowser 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of five subviews, starting with the list view of system categories. The 
	initial text view part is empty."

	self browser: aBrowser editString: nil!
browser: aBrowser editString: aString 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of five subviews, starting with the list view of system categories. The 
	initial text view part is a view of the characters in aString."

	| browserView systemCategoryListView classListView messageCategoryListView
	switchView messageListView browserCodeView |

	browserView _ self new model: aBrowser.
	systemCategoryListView _ self buildSystemCategoryListView: aBrowser.
	classListView _ self buildClassListView: aBrowser.
	switchView _ self buildInstanceClassSwitchView: aBrowser.
	messageCategoryListView _ self buildMessageCategoryListView: aBrowser.
	messageListView _ self buildMessageListView: aBrowser.
	browserCodeView _ self buildBrowserCodeView: aBrowser editString: aString.

	browserView addSubView: systemCategoryListView.
	browserView addSubView: classListView.
	browserView addSubView: switchView.
	browserView addSubView: messageCategoryListView.
	browserView addSubView: messageListView.
	browserView addSubView: browserCodeView.

	classListView 
		align: classListView viewport topLeft 	
		with: systemCategoryListView viewport topRight.
	switchView
		align: switchView viewport topLeft
		with: classListView viewport bottomLeft.
	messageCategoryListView 
		align: messageCategoryListView viewport topLeft 
		with: classListView viewport topRight.
	messageListView 
		align: messageListView viewport topLeft 
		with: messageCategoryListView viewport topRight.
	browserCodeView 
		align: browserCodeView viewport topLeft 
		with: systemCategoryListView viewport bottomLeft.
    
	aString notNil ifTrue: [aBrowser lock].

	^browserView!
classBrowser: aBrowser 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of four subviews, starting with the list view of classes in the model's 
	currently selected system category. The initial text view part is empty."

	^self classBrowser: aBrowser editString: nil!
classBrowser: aBrowser editString: aString 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of four subviews, starting with the list view of classes in the model's 
	currently selected system category. The initial text view part is a view 
	of the characters in aString."

	| browserView classListView messageCategoryListView switchView
	messageListView browserCodeView |

	browserView _ self new model: aBrowser.
	classListView _ self buildClassListView: aBrowser.
	switchView _ self buildInstanceClassSwitchView: aBrowser.
	messageCategoryListView _ self buildMessageCategoryListView: aBrowser.
	messageListView _ self buildMessageListView: aBrowser.
	browserCodeView _ self buildBrowserCodeView: aBrowser editString: aString.

	classListView borderWidthLeft: 2 right: 0 top: 2 bottom: 0.
	classListView singleItemMode: true.
	classListView noTopDelimiter.
	classListView noBottomDelimiter.
	classListView list: classListView getList.
	switchView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.

	browserView addSubView: classListView.
	browserView addSubView: switchView.
	browserView addSubView: messageCategoryListView.
	browserView addSubView: messageListView.
	browserView addSubView: browserCodeView.

	messageListView 
		align: messageListView viewport topLeft 
		with: messageCategoryListView viewport topRight.
	classListView 
		window: classListView window 
		viewport: (messageCategoryListView viewport topLeft - (0 @ 12) 
					corner: messageCategoryListView viewport topRight).
	switchView 
		window: switchView window 
		viewport: (messageListView viewport topLeft - (0 @ 12) 
					corner: messageListView viewport topRight).
	browserCodeView 
		window: browserCodeView window 
		viewport: (messageCategoryListView viewport bottomLeft 
					corner: messageListView viewport bottomRight + (0 @ 110)).
    
	aString notNil ifTrue: [aBrowser lock].

	^browserView!
messageBrowser: aBrowser 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of two subviews, starting with the list view of message selectors in the 
	model's currently selected category. The initial text view part is empty."

	^self messageBrowser: aBrowser editString: nil!
messageBrowser: aBrowser editString: aString 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of two subviews, starting with the list view of message selectors in the 
	model's currently selected category. The initial text view part is a view 
	of the characters in aString."

	| browserView messageListView browserCodeView |

	browserView _ self new model: aBrowser.
	messageListView _ self buildMessageListView: aBrowser.
	browserCodeView _ self buildBrowserCodeView: aBrowser editString: aString.

	messageListView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	messageListView singleItemMode: true.
	messageListView noTopDelimiter.
	messageListView noBottomDelimiter.
	messageListView list: messageListView getList.

	browserView addSubView: messageListView.
	browserView addSubView: browserCodeView.

	messageListView 
		window: messageListView window 
		viewport: (browserCodeView viewport topLeft - (0 @ 12) 
						corner: browserCodeView viewport topRight).
    
	aString notNil ifTrue: [aBrowser lock].

	^browserView!
messageCategoryBrowser: aBrowser 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of three subviews, starting with the list view of message categories in 
	the model's currently selected class. The initial text view part is empty."

	^self messageCategoryBrowser: aBrowser editString: nil!
messageCategoryBrowser: aBrowser editString: aString 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of three subviews, starting with the list view of message categories in 
	the model's currently selected class. The initial text view part is a view 
	of the characters in aString."

	| browserView messageCategoryListView messageListView browserCodeView |

	browserView _ self new model: aBrowser.
	messageCategoryListView _ self buildMessageCategoryListView: aBrowser.
	messageListView _ self buildMessageListView: aBrowser.
	browserCodeView _ self buildBrowserCodeView: aBrowser editString: aString.

	messageCategoryListView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	messageCategoryListView singleItemMode: true.
	messageCategoryListView noTopDelimiter.
	messageCategoryListView noBottomDelimiter.
	messageCategoryListView list: messageCategoryListView getList.

	browserView addSubView: messageCategoryListView.
	browserView addSubView: messageListView.
	browserView addSubView: browserCodeView.

	messageCategoryListView 
		window: messageCategoryListView window 
		viewport: (messageListView viewport topLeft - (0 @ 12) 
						corner: messageListView viewport topRight).
	browserCodeView 
		window: browserCodeView window 
		viewport: (messageListView viewport bottomLeft 
						corner: messageListView viewport bottomRight + (0 @ 110)).
    
	aString notNil ifTrue: [aBrowser lock].

	^browserView!
systemCategoryBrowser: aBrowser 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of five subviews, starting with the list view of the currently selected 
	system class category--a single item list. The initial text view part is 
	empty."

	^self systemCategoryBrowser: aBrowser editString: nil!
systemCategoryBrowser: aBrowser editString: aString 
	"Answer an instance of me on the model, aBrowser. The instance consists 
	of five subviews, starting with the list view of the currently selected 
	system class category--a single item list. The initial text view part is a 
	view of the characters in aString."

	| browserView systemCategoryListView classListView switchView
		messageCategoryListView messageListView browserCodeView |

	browserView _ self new model: aBrowser.
	systemCategoryListView _ self buildSystemCategoryListView: aBrowser.
	classListView _ self buildClassListView: aBrowser.
	switchView _ self buildInstanceClassSwitchView: aBrowser.
	messageCategoryListView _ self buildMessageCategoryListView: aBrowser.
	messageListView _ self buildMessageListView: aBrowser.
	browserCodeView _ self buildBrowserCodeView: aBrowser editString: aString.

	systemCategoryListView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	systemCategoryListView singleItemMode: true.
	systemCategoryListView noTopDelimiter.
	systemCategoryListView noBottomDelimiter.
	systemCategoryListView list: systemCategoryListView getList.

	browserView addSubView: systemCategoryListView.
	browserView addSubView: classListView.
	browserView addSubView: switchView.
	browserView addSubView: messageCategoryListView.
	browserView addSubView: messageListView.
	browserView addSubView: browserCodeView.

	switchView 
		align: switchView viewport topLeft 
		with: classListView viewport bottomLeft.
	messageCategoryListView 
		align: messageCategoryListView viewport topLeft 
		with: classListView viewport topRight.
	messageListView 
		align: messageListView viewport topLeft 
		with: messageCategoryListView viewport topRight.
	browserCodeView 
		window: browserCodeView window 
		viewport: (switchView viewport bottomLeft 
						corner: messageListView viewport bottomRight + (0 @ 110)).
	systemCategoryListView 
		window: systemCategoryListView window 
		viewport: (classListView viewport topLeft - (0 @ 12) 
						corner: messageListView viewport topRight).
    
	aString notNil ifTrue: [aBrowser lock].

	^browserView! !

!BrowserView class methodsFor: 'instance scheduling'!
browseFullForClass: aClass
	"Create and schedule a full Browser with the given class chosen. 1/16/96 sw"

	self browseFullForClass: aClass method: nil!
browseFullForClass: aClass method: aSelector
	"Create and schedule a full Browser and then select the class of the master object being inspected.  1/12/96 sw"

	Browser postOpenSuggestion: (Array with: aClass with: aSelector).
		"This takes effect after the Browser comes up"
	self openBrowser!
browseFullForClass: aClass method: aSelector from: aController
	"Create and schedule a full Browser and then select the class of the master object being inspected.  1/12/96 sw"

	aController controlTerminate.
	self browseFullForClass: aClass method: aSelector.
	aController controlInitialize!
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."

	self openBrowserEditString: nil!
openBrowserEditString: aString 
	"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 a view of 
	the characters in aString."

	self openBrowserView: (self browser: Browser new editString: aString)
		label: 'System Browser'!
openBrowserView: aBrowserView label: aString 
	"Schedule aBrowserView, labelling the view aString."
	
	aBrowserView label: aString.
	aBrowserView minimumSize: 300 @ 200.
	aBrowserView subViews do: [:each | each controller].
	aBrowserView controller open!
openClassBrowser: aBrowser editString: aString label: aLabel
	"Create and schedule a BrowserView with the specified window title.   The view  consists of four subviews, starting with the list view of classes in the  SystemOrganization's currently selected system category. The initial text  view part is a view of the characters in aString."

	self openBrowserView: (BrowserView classBrowser: aBrowser editString: aString)
		label: aLabel!
openMessageBrowser: aBrowser editString: aString 
	"Create and schedule a BrowserView with label 'Message Browser' 
	followed by the name of the selected class or metaclass. The view 
	consists of two subviews, starting with the list view of message selectors 
	in the System Organization's currently selected category. The initial text 
	view part is a view of the characters in aString."

	self openBrowserView: 
			(BrowserView messageBrowser: aBrowser editString: aString)
		label: aBrowser selectedClassOrMetaClassName , ' ' , aBrowser selectedMessageName!
openMessageBrowserForClass: aBehavior selector: aSymbol editString: aString
	"Create and schedule a message browser for the class, aBehavior, in 
	which the argument, aString, contains characters to be edited in the text 
	view. These characters are the source code for the message selector 
	aSymbol."

	| newBrowser aClass systemCatIndex messageCatIndex isMeta |
	newBrowser _ Browser new.
	(aBehavior isKindOf: Metaclass)
		ifTrue: [isMeta _ true. aClass _ aBehavior soleInstance]
		ifFalse: [isMeta _ false. aClass _ aBehavior].
	systemCatIndex _ SystemOrganization categories indexOf: aClass category.
	newBrowser systemCategoryListIndex: systemCatIndex.
	newBrowser classListIndex:
			((SystemOrganization listAtCategoryNumber: systemCatIndex)
					indexOf: aClass name).
	newBrowser metaClassIndicated: isMeta.
	messageCatIndex _ aBehavior organization numberOfCategoryOfElement: aSymbol.
	newBrowser messageCategoryListIndex: messageCatIndex.
	newBrowser messageListIndex:
			((aBehavior organization listAtCategoryNumber: messageCatIndex)
					indexOf: aSymbol).
	^self openMessageBrowser: newBrowser editString: aString!
openMessageCategoryBrowser: aBrowser editString: aString 
	"Create and schedule a BrowserView with label 'Message Category 
	Browser' followed by the name of the selected class or metaclass. The 
	view consists of three subviews, starting with the list view of message 
	categories in the System Organization's currently selected class. The 
	initial text view part is a view of the characters in aString."

	self openBrowserView: 
			(BrowserView messageCategoryBrowser: aBrowser editString: aString)
		label: 
			'Message Category Browser (' , aBrowser selectedClassOrMetaClassName , ')'!
openSystemCategoryBrowser: aBrowser editString: aString 
	"Create and schedule a BrowserView with label 'System Category 
	Browser'. The view consists of five subviews, starting with the single 
	item list view of the currently selected system category of the 
	SystemOrganization. The initial text view part is a view of the characters 
	in aString."

	self openBrowserView: 
			(BrowserView systemCategoryBrowser: aBrowser editString: aString)
		label:
			'System Category Browser'!
openSystemCategoryBrowser: aBrowser label: aLabel editString: aString 
	"Create and schedule a BrowserView with label 'System Category 
	Browser'. The view consists of five subviews, starting with the single 
	item list view of the currently selected system category of the 
	SystemOrganization. The initial text view part is a view of the characters 
	in aString.
	7/13/96 sw: created this variant in which the caller can specifiy the window title"

	self openBrowserView: (BrowserView systemCategoryBrowser: aBrowser editString: aString)
		label: aLabel! !

!BrowserView class methodsFor: 'private'!
buildBrowserCodeView: aBrowser editString: aString

	| aBrowserCodeView |
	aBrowserCodeView _ BrowserCodeView new.
	aBrowserCodeView model: aBrowser.
	aBrowserCodeView window: (0 @ 0 extent: 200 @ 110).
	aBrowserCodeView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.
	aString ~~ nil ifTrue: [aBrowserCodeView editString: aString].
	^aBrowserCodeView!
buildClassListView: aBrowser

	| aClassListView |
	aClassListView _ ClassListView new.
	aClassListView model: aBrowser.
	aClassListView window: (0 @ 0 extent: 50 @ 62).
	aClassListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	^aClassListView!
buildClassSwitchView: aBrowser

	| aSwitchView |
	aSwitchView _ SwitchView new.
	aSwitchView model: aBrowser.
	aSwitchView controller: LockedSwitchController new.
	aSwitchView selector: #classMessagesIndicated.
	aSwitchView controller selector: #indicateClassMessages.
	aSwitchView window: (0 @ 0 extent: 25 @ 8).
	aSwitchView label: 'class' asParagraph.
	^aSwitchView!
buildInstanceClassSwitchView: aBrowser
	| aView aSwitchView |
	aView _ View new model: aBrowser.
	aView window: (0 @ 0 extent: 50 @ 8).
	aView borderWidthLeft: 2 right: 0 top: 0 bottom: 2.
	aSwitchView _ self buildInstanceSwitchView: aBrowser.
	aView
		addSubView: aSwitchView
		align: aSwitchView viewport topLeft
		with: aView window topLeft.
	aSwitchView _ self buildClassSwitchView: aBrowser.
	aView
		addSubView: aSwitchView
		align: aSwitchView viewport topLeft
		with: aView lastSubView viewport topRight.
	^aView!
buildInstanceSwitchView: aBrowser

	| aSwitchView |
	aSwitchView _ SwitchView new.
	aSwitchView model: aBrowser.
	aSwitchView controller: LockedSwitchController new.
	aSwitchView borderWidthLeft: 0 right: 1 top: 0 bottom: 0.
	aSwitchView selector: #instanceMessagesIndicated.
	aSwitchView controller selector: #indicateInstanceMessages.
	aSwitchView window: (0 @ 0 extent: 25 @ 8).
	aSwitchView label: 'instance' asParagraph.
	^aSwitchView!
buildMessageCategoryListView: aBrowser

	| aMessageCategoryListView |
	aMessageCategoryListView _ MessageCategoryListView new.
	aMessageCategoryListView model: aBrowser.
	aMessageCategoryListView window: (0 @ 0 extent: 50 @ 70).
	aMessageCategoryListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	^aMessageCategoryListView!
buildMessageListView: aBrowser
	| aMessageListView |

	aMessageListView _ MessageListView new.
	aMessageListView model: aBrowser.
	aMessageListView window: (0 @ 0 extent: 50 @ 70).
	aMessageListView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	^ aMessageListView!
buildSystemCategoryListView: aBrowser

	| aSystemCategoryListView |
	aSystemCategoryListView _ SystemCategoryListView new.
	aSystemCategoryListView model: aBrowser.
	aSystemCategoryListView window: (0 @ 0 extent: 50 @ 70).
	aSystemCategoryListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	^aSystemCategoryListView! !Switch subclass: #Button
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
Button comment:
'I am a Switch that turns off automatically after being turned on, that is, I act like a push-button switch.'!

!Button methodsFor: 'state'!
turnOff
	"Sets the state of the receiver to 'off'. The off action of the receiver is not  
	executed."

	on _ false!
turnOn
	"The receiver remains in the 'off' state'."

	self doAction: onAction.
	self doAction: offAction! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Button class
	instanceVariableNames: ''!

!Button class methodsFor: 'instance creation'!
newOn 
	"Refer to the comment in Switch|newOn."

	self error: 'Buttons cannot be created in the on state'.
	^nil! !ArrayedCollection variableByteSubclass: #ByteArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Arrayed'!
ByteArray comment:
'I represent an ArrayedCollection whose elements can only be integers between 0 and 255. They are stored two bytes to a word.'!

!ByteArray methodsFor: 'accessing'!
doubleWordAt: i 
	"Answer the value of the double word (4 bytes) starting at byte index i."

	| b0 b1 b2 w |
	"Primarily for reading socket #s in Pup headers"
	b0 _ self at: i.  
	b1 _ self at: i+1.  
	b2 _ self at: i+2.  
	w _ self at: i+3.
	"Following sequence minimizes LargeInteger arithmetic for small results."
	b2=0 ifFalse: [w _ (b2 bitShift: 8) + w].
	b1=0 ifFalse: [w _ (b1 bitShift: 16) + w].
	b0=0 ifFalse: [w _ (b0 bitShift: 24) + w].
	^w!
doubleWordAt: i put: value 
	"Set the value of the double word (4 bytes) starting at byte index i."

	| w |
	"Primarily for setting socket #s in Pup headers"
	w _ value asInteger.
	self at: i put: (w digitAt: 4).
	self at: i + 1 put: (w digitAt: 3).
	self at: i + 2 put: (w digitAt: 2).
	self at: i + 3 put: (w digitAt: 1)!
wordAt: i 
	"Answer the value of the word (2 bytes) starting at index i."

	| j |
	j _ i + i.
	^((self at: j - 1) bitShift: 8) + (self at: j)!
wordAt: i put: v 
	"Set the value of the word (2 bytes) starting at index i."

	| j |
	j _ i + i.
	self at: j - 1 put: ((v bitShift: -8) bitAnd: 8r377).
	self at: j put: (v bitAnd: 8r377)! !

!ByteArray methodsFor: 'private'!
defaultElement

	^0!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	| tooMany |
	tooMany _ aStream position + self maxPrint.
	aStream nextPutAll: self class name, ' ('.
	self do: 
		[:element | 
		aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self].
		element asCharacter printOn: aStream.
		aStream space].
	aStream nextPut: $)!
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! !ParseNode subclass: #CascadeNode
	instanceVariableNames: 'receiver messages '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
CascadeNode comment: 'The first message has the common receiver, the rest have receiver == nil, which signifies cascading.'!

!CascadeNode methodsFor: 'initialize-release'!
receiver: receivingObject messages: msgs
	" Transcript show: 'abc'; cr; show: 'def' "

	receiver _ receivingObject.
	messages _ msgs! !

!CascadeNode methodsFor: 'code generation'!
emitForValue: stack on: aStream

	receiver emitForValue: stack on: aStream.
	1 to: messages size - 1 do: 
		[:i | 
		aStream nextPut: Dup.
		stack push: 1.
		(messages at: i) emitForValue: stack on: aStream.
		aStream nextPut: Pop.
		stack pop: 1].
	messages last emitForValue: stack on: aStream!
sizeForValue: encoder

	| size |
	size _ (receiver sizeForValue: encoder) + (messages size - 1 * 2).
	messages do: [:aMessage | size _ size + (aMessage sizeForValue: encoder)].
	^size! !

!CascadeNode methodsFor: 'printing'!
printOn: aStream indent: level
	self printOn: aStream indent: level precedence: 0!
printOn: aStream indent: level precedence: p
	| thisPrec |
	p > 0 ifTrue: [aStream nextPut: $(].
	thisPrec _ messages first precedence.
	receiver printOn: aStream indent: level precedence: thisPrec.
	1 to: messages size do: 
		[:i | 
		(messages at: i) printOn: aStream indent: level.
		i < messages size
			ifTrue: [aStream nextPut: $;.
					thisPrec >= 2 ifTrue: [aStream crtab: level]]].
	p > 0 ifTrue: [aStream nextPut: $)]! !

!CascadeNode methodsFor: 'equation translation'!
collectVariables
	^messages inject: receiver collectVariables into: [:array :message | array, message collectVariables]!
copyReplacingVariables: varDict 
	| t1 t2 |
	t1 _ receiver copyReplacingVariables: varDict.
	t2 _ messages collect: [:m | m copyReplacingVariables: varDict].
	^self class new receiver: t1 messages: t2!
specificMatch: aTree using: matchDict 
	(receiver match: aTree receiver using: matchDict)
		ifFalse: [^false].
	messages with: aTree messages do: [:m1 :m2 |
			(m1 match: m2 using: matchDict) ifFalse: [^false]].
	^true! !

!CascadeNode methodsFor: 'C translation'! !StringHolder subclass: #ChangeList
	instanceVariableNames: 'changeList list listIndex listSelections file hiddenList realIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!
ChangeList comment:
'A ChangeList represents a list of changes recorded on a file in fileOut
format.  It holds three lists:
	changeList - a list of ChangeRecords
	list - a list of one-line printable headers
	hiddenList - a list of Booleans.
Any item with a true in hiddenList will not be visible in the list.
In effect, there a two lists, one hidden and one visible.  They can
be exchanged by the -show hidden- command, and visible items
can be put into the hidden list with the -hide selection- command.'!

!ChangeList methodsFor: 'initialization-release'!
addItem: item text: text
	| cr |
	cr _ Character cr.
	changeList addLast: item.
	list addLast: (text collect: [:x | x = cr ifTrue: [$/] ifFalse: [x]])! !

!ChangeList methodsFor: 'scanning'!
scanCategory  "or other preamble"
	| itemPosition item tokens |
	itemPosition _ file position.
	item _ file nextChunk.
	tokens _ Scanner new scanTokens: item.
	(tokens size >= 3 and: [(tokens at: 2) = #methodsFor:])
		ifTrue: [self scanCategory: (tokens at: 3) class: (tokens at: 1) meta: false]
		ifFalse: [(tokens size >= 4 and: [(tokens at: 3) = #methodsFor:])
			ifTrue: [self scanCategory: (tokens at: 4) class: (tokens at: 1) meta: true]
			ifFalse: [self addItem: (ChangeRecord new file: file position: itemPosition type: #preamble) text: ('preamble: ' , item contractTo: 50)]]!
scanCategory: category class: class meta: meta
	| itemPosition method |
	[itemPosition _ file position.
	method _ file nextChunk.
	method size > 0]						"done when double terminators"
		whileTrue:
		[self addItem: (ChangeRecord new file: file position: itemPosition type: #method
							class: class category: category meta: meta)
			text: 'method: ' , class , (meta ifTrue: [' class '] ifFalse: [' ']) , (Parser new parseSelector: method)]!
scanFile: aFile from: startPosition to: stopPosition
	| itemPosition item prevChar |
	file _ aFile.
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	file position: startPosition.
'Scanning changes...'
	displayProgressAt: Sensor cursorPoint
	from: startPosition to: stopPosition
	during: [:bar |
	[file position < stopPosition]
		whileTrue:
		[bar value: file position.
		[file atEnd not and: [file peek isSeparator]]
				whileTrue: [prevChar _ file next].
		(file peekFor: $!!)
		ifTrue:
			[prevChar = Character cr ifTrue: [self scanCategory]]
		ifFalse:
			[itemPosition _ file position.
			item _ file nextChunk.
			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!
scanVersionsOf: method class: class meta: meta
		category: category selector: selector
	| sources position prevPos prevFileIndex preamble tokens sourceFilesCopy |
	changeList _ OrderedCollection new.
	list _ OrderedCollection new.
	listIndex _ 0.
	position _ method filePosition.
	sourceFilesCopy _ SourceFiles collect:
		[:x | x isNil ifTrue: [ nil ]
				ifFalse: [x readOnlyCopy]].
	file _ sourceFilesCopy at: method fileIndex.
	[position notNil & file notNil]
		whileTrue:
		[file position: (0 max: position-150).  "Skip back to before the preamble"
		[file position < (position-1)]  "then pick it up from the front"
			whileTrue: [preamble _ file nextChunk].
		prevPos _ nil.
		(preamble at: (preamble findLast: [:c | c isAlphaNumeric]))
			isDigit  "Only tokenize if preamble ends with a digit"
			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:
				[prevPos _ tokens at: tokens size-2.
				prevPos = 0
					ifTrue: [prevPos _ nil] "Zero means no source"
					ifFalse: [prevFileIndex _ tokens last]].
		self addItem:
				(ChangeRecord new file: file position: position
					type: #method class: class name category: category meta: meta)
			text: 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!
toggleListIndex: newListIndex
	"2/1/96 sw: removed changed: call, to avoid extra refresh whenever selection changes. The call had been 'self changed: #contents', but everything appears to work fine with it omitted."

	(listIndex ~= 0 and: [listIndex ~= newListIndex]) ifTrue:
		[listSelections at: listIndex put: false].  "turn off old selection if was on"
	listSelections at: newListIndex  "Complement selection state"
			put: (listSelections at: newListIndex) not.
	listIndex _ (listSelections at: newListIndex)
		ifTrue: [newListIndex]  "and set selection index accordingly"
		ifFalse: [0].
	self changed: #listIndex! !

!ChangeList methodsFor: 'menu actions'!
deselectAll 
	listIndex _ 0.
	listSelections atAllPut: false.
	self changed: #allSelections!
fileInSelections 
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileIn]]!
fileOutSelections 
	| f |
	f _ FileStream newFileNamed: (FillInTheBlank request: 'Enter file name' initialAnswer: 'Filename.st').
	listSelections with: changeList do: 
		[:selected :item | selected ifTrue: [item fileOutOn: f]].
	f close!
removeDoIts
	"Remove doits from the receiver, other than initializes. 1/26/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	changeList with: list do:
		[:chRec :str |
			(chRec type ~~ #doIt or:
				[str endsWith: 'initialize'])
					ifTrue:
						[newChangeList add: chRec.
						newList add: str]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list

	!
removeOlderMethodVersions
	"Remove older versions of entries from the receiver.  1/26/96 sw:"

	| newChangeList newList found |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.
	found _ OrderedCollection new.

	changeList reverseWith: list do:
		[:chRec :str |
			(found includes: str)
				ifFalse:
					[found add: str.
					newChangeList add: chRec.
					newList add: str]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList reversed.
			list _ newList reversed.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list!
removeSelections
	"Remove the selected items from the receiver.  9/18/96 sw"

	| newChangeList newList |

	newChangeList _ OrderedCollection new.
	newList _ OrderedCollection new.

	1 to: changeList size do:
		[:i | (listSelections at: i) ifFalse:
			[newChangeList add: (changeList at: i).
			newList add: (list at: i)]].
	newChangeList size < changeList size
		ifTrue:
			[changeList _ newChangeList.
			list _ newList.
			listIndex _ 0.
			listSelections _ Array new: list size withAll: false].
	self changed: #list

	!
selectAll
	listIndex _ 0.
	listSelections atAllPut: true.
	self changed: #allSelections!
selectConflicts
	"Selects all method definitions for which there is ALSO an entry in changes"
	| change class systemChanges |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(Smalltalk changes atSelector: change methodSelector
						class: class) ~~ #none]])]].
	self changed: #allSelections!
selectConflicts: changeSetOrList
	"Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList"
	| change class systemChanges |
	Cursor read showWhile: 
	[(changeSetOrList isKindOf: ChangeSet) ifTrue: [
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [(changeSetOrList atSelector: change methodSelector
						class: class) ~~ #none]])]]
	ifFalse: ["a ChangeList"
	1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			(change type = #method
			and: [(class _ change methodClass) notNil
			and: [changeSetOrList list includes: (list at: i)]])]]
	].
	self changed: #allSelections!
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  coll |
	aStream _ WriteStream on: (String new: 200).
	all _ ChangeSet allInstances.
	all do:
		[:sel | aStream nextPutAll: (sel name contractTo: 40); cr].
	coll _ ChangeList allInstances.
	coll do:
		[: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)].!
selectUnchangedMethods
	"Selects all method definitions for which there is already a method in the current image, whose source is exactly the same.  9/18/96 sw"
	| change class systemChanges |
	Cursor read showWhile: 
	[1 to: changeList size do:
		[:i | change _ changeList at: i.
		listSelections at: i put:
			((change type = #method and:
				[(class _ change methodClass) notNil]) and:
					[(class includesSelector: change methodSelector) and:
						[change string = (class sourceCodeAt: change methodSelector)]])]].
	self changed: #allSelections! !

!ChangeList methodsFor: 'viewing access'!
contents
	^ listIndex = 0
		ifTrue: ['']
		ifFalse: [(changeList at: listIndex) string]!
contents: aString
	listIndex = 0
		ifTrue: [self changed: #flash. ^ false]
		ifFalse: [Cursor read showWhile: [(changeList at: listIndex) fileIn].
				^ true]!
defaultBackgroundColor
	^ #lightBlue!
list
	^ list!
listIndex
	^ listIndex!
listSelectionAt: index
	^ listSelections at: index!
listSelectionAt: index put: value
	listIndex _ 0.
	^ listSelections at: index put: value! !

!ChangeList methodsFor: 'accessing'!
changeList
	^ changeList!
file
	^file! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeList class
	instanceVariableNames: ''!

!ChangeList class methodsFor: 'public access'!
browseFile: fileName    "ChangeList browseFile: 'AutoDeclareFix.st'"
	"Opens a changeList on the file named fileName"
	| changesFile changeList |
	changesFile _ FileStream readOnlyFileNamed: fileName.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: 0 to: changesFile size].
	changesFile close.
	self open: changeList name: fileName , ' log'!
browseRecent: charCount    "ChangeList browseRecent: 5000"
	"Opens a changeList on the end of the changes log file"
	| changesFile changeList end |
	changesFile _ (SourceFiles at: 2) readOnlyCopy.
	end _ changesFile size.
	Cursor read showWhile:
		[changeList _ self new
			scanFile: changesFile from: (0 max: end-charCount) to: end].
	changesFile close.
	self open: changeList name: 'Recent changes'!
browseRecentLog    "ChangeList browseRecentLog"
	"Browse changes logged since last quit"
	^ self browseRecent: (SourceFiles at: 2) size - Smalltalk lastQuitLogPosition!
browseVersionsOf: method class: class meta: meta
		category: category selector: selector 
	| changeList |
	Cursor read showWhile:
		[changeList _ self new
			scanVersionsOf: method class: class meta: meta
			category: category selector: selector].
	self openVersions: changeList name: 'Recent versions of ' , selector!
versionCountForSelector: aSelector class: aClass
	"Answer the number of versions known to the system for the given class and method, including the current version.  A result of greater than one means that there is at least one superseded version.  6/28/96 sw"
	
	| method |
	method _ aClass compiledMethodAt: aSelector.
	^ (self new
			scanVersionsOf: method class: aClass meta: aClass isMeta
			category: nil selector: aSelector) list size! !

!ChangeList class methodsFor: 'instance creation'!
open: aChangeList name: aString 
	"Open a view for the changeList, with a multiple selection list. "
	^ self open: aChangeList name: aString
		withListView: (ListViewOfMany new controller: ChangeListController new)!
open: aChangeList name: aString withListView: aListView
	"Create a standard system view for the messageSet, whose label is aString.
	The listView supplied may be either single or multiple selection type"
	| topView codeView |
	topView _ StandardSystemView new.
	topView model: aChangeList.
	topView label: aString.
	topView minimumSize: 180 @ 120.
	aListView model: aChangeList.
	aListView list: aChangeList list.
	aListView window: (0 @ 0 extent: 180 @ 100).
	aListView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	topView addSubView: aListView.
	codeView _ StringHolderView new.
	codeView model: aChangeList.
	codeView window: (0 @ 0 extent: 180 @ 300).
	codeView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	topView
		addSubView: codeView
		align: codeView viewport topLeft
		with: aListView viewport bottomLeft.
	topView controller open !
openVersions: aChangeList name: aString 
	"Open a standard system view for the changeList with a normal ListView"
	^ self open: aChangeList name: aString
		withListView: ListView new! !ListControllerOfMany subclass: #ChangeListController
	instanceVariableNames: ''
	classVariableNames: 'YellowButtonMenu YellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-Changes'!

!ChangeListController methodsFor: 'menu actions'!
deselectAll
	self controlTerminate.
	model deselectAll.
	self controlInitialize!
fileInSelections
	self controlTerminate.
	model fileInSelections.
	self controlInitialize!
fileOutSelections
	self controlTerminate.
	model fileOutSelections.
	self controlInitialize!
removeDoIts
	"Remove the doits from the browser.  1/26/96 sw"

	self controlTerminate.
	model removeDoIts.
	self controlInitialize!
removeOlderMethodVersions
	"Remove older method versions from the browser.  1/26/96 sw"

	self controlTerminate.
	model removeOlderMethodVersions.
	self controlInitialize!
removeSelections
	"Remove all selected items from the list.  9/18/96 sw"

	self controlTerminate.
	model removeSelections.
	self controlInitialize!
selectAll
	self controlTerminate.
	model selectAll.
	self controlInitialize!
selectConflicts
	self controlTerminate.
	model selectConflicts.
	self controlInitialize!
selectConflictsWith
	self controlTerminate.
	model selectConflictsWith.
	self controlInitialize!
selectUnchangedMethods
	"Select all methods in the receiver whose source is identical to the corresponding source currently in the image.  9/18/96 sw"

	self controlTerminate.
	model selectUnchangedMethods.
	self controlInitialize! !

!ChangeListController methodsFor: 'initialization'!
initialize
	super initialize.
	self initializeYellowButtonMenu!
initializeYellowButtonMenu
	self yellowButtonMenu: YellowButtonMenu 
		yellowButtonMessages: YellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeListController class
	instanceVariableNames: ''!

!ChangeListController class methodsFor: 'class initialization'!
initialize
	"Class initialization: initialize the Yellow Button menu.
	 1/26/96 sw: added the remove items
	 9/18/96 sw: added selectUnchangedMethods and removeSelections"

	YellowButtonMenu _ PopUpMenu 
		labels:
'fileIn selections
fileOut selections...
select conflicts
select conflicts with
select unchanged methods
select all
deselect all
remove doIts
remove older versions
remove selections'
		lines: #(2 6).
	YellowButtonMessages _ #(fileInSelections fileOutSelections selectConflicts selectConflictsWith selectUnchangedMethods selectAll deselectAll removeDoIts removeOlderMethodVersions removeSelections)
"
	ChangeListController initialize.
	ChangeListController allInstancesDo:
		[:x | x initializeYellowButtonMenu].
"! !

ChangeListController initialize!
Object subclass: #ChangeRecord
	instanceVariableNames: 'file position type class category meta '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!
ChangeRecord comment:
'A ChangeRecord represents a change recorded on a file in fileOut format.
It includes a type (more needs to be done here), and additional information
for certain types such as method defs which need class and category.'!

!ChangeRecord methodsFor: 'access'!
fileIn
	| methodClass |
	Cursor read showWhile:
		[(methodClass _ self methodClass) notNil ifTrue:
			[methodClass compile: self string classified: category].
		type = #doIt ifTrue:
			[Compiler evaluate: self string]]!
fileOutOn: f
	type == #method
		ifTrue:
			[f nextPut: $!!.
			f nextChunkPut: class asString
					, (meta ifTrue: [' class methodsFor: ']
							ifFalse: [' methodsFor: '])
					, category asString printString.
			f cr]
		ifFalse:
			[type == #preamble ifTrue: [f nextPut: $!!]].
	f nextChunkPut: self string.
	type == #method ifTrue: [f nextChunkPut: ' '].
	f cr!
methodClass 
	| methodClass |
	type == #method ifFalse: [^ nil].
	(Smalltalk includesKey: class asSymbol) ifFalse: [^ nil].
	methodClass _ Smalltalk at: class asSymbol.
	meta ifTrue: [^ methodClass class]
		ifFalse: [^ methodClass]!
methodSelector
	type == #method ifFalse: [^ nil].
	^ Parser new parseSelector: self string!
string 
	| string |
	file openReadOnly.
	file position: position.
	string _ file nextChunk.
	file close.
	^ string!
type
	^ type! !

!ChangeRecord methodsFor: 'initialization'!
file: f position: p type: t
	file _ f.
	position _ p.
	type _ t!
file: f position: p type: t class: c category: cat meta: m
	self file: f position: p type: t.
	class _ c.
	category _ cat.
	meta _ m! !Object subclass: #ChangeSet
	instanceVariableNames: 'classChanges methodChanges classRemoves name '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Support'!
ChangeSet comment:
'My instances keep track of the changes made to a system, so the user can make an incremental fileOut. The order in which changes are made is not remembered.'!

!ChangeSet methodsFor: 'initialize-release'!
initialize 
	"Reset the receiver to be empty."

	self wither.  "Avoid duplicate entries in AllChangeSets if initialize gets called twice"
	classChanges _ Dictionary new.
	methodChanges _ Dictionary new.
	classRemoves _ Set new.
	name _ ChangeSet defaultName!
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 !
wither
	"The receiver is to be clobbered.  Clear it out.  2/7/96 sw"

	classChanges _ nil.
	methodChanges _ nil.
	classRemoves _ nil.
	name _ nil! !

!ChangeSet methodsFor: 'testing'!
classChangeAt: className
	"Return what we know about class changes to this class."
	^ classChanges at: className ifAbsent: [Set new].!
classRemoves
	^ classRemoves!
isEmpty
	"Answer whether the receiver contains any elements."

	^(methodChanges isEmpty and: [classChanges isEmpty]) and: [classRemoves isEmpty]!
methodChangesAtClass: className
	"Return what we know about method changes to this class."
	^ methodChanges at: className ifAbsent: [Dictionary new].!
name
	"The name of this changeSet.
	 2/7/96 sw: If name is nil, we've got garbage.  Help to identify."

	^ name == nil
		ifTrue:
			['<no name -- garbage?>']
		ifFalse:
			[name]! !

!ChangeSet methodsFor: 'converting'!
asSortedCollection
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is the default less than or equal ordering."
	| result |
	result _ SortedCollection new.
	classChanges associationsDo: 
		[:clAssoc | 
		clAssoc value do: 
			[:changeType | result add: clAssoc key, ' - ', changeType]].
	methodChanges associationsDo: 
		[:clAssoc | 
		clAssoc value associationsDo: 
			[:mAssoc | result add: clAssoc key, ' ', mAssoc key, ' - ', mAssoc value]].
	classRemoves do:
		[:cName | result add: cName  , ' - ', 'remove'].
	^ result! !

!ChangeSet methodsFor: 'change management'!
absorbChangesInChangeSetsNamed: nameList
	"Absorb into the receiver all the changes found in  change sets of the given names.  *** classes renamed in aChangeSet may have have problems
1/22/96 sw"

	| aChangeSet |
	nameList do:
		[:aName | (aChangeSet _ ChangeSorter changeSetNamed: aName) ~~ nil
			ifTrue:
				[self assimilateAllChangesFoundIn: aChangeSet]]!
addClass: class 
	"Include indication that a new class was created."

	self atClass: class add: #add!
assimilateAllChangesFoundIn: aChangeSet
	"Make all changes in aChangeSet take effect on self as it they happened later.  *** classes renamed in aChangeSet may have have problems"

	| cls info |
	aChangeSet changedClassNames do: [:className |
		(cls _ Smalltalk classNamed: className) notNil ifTrue:
		[info _ aChangeSet classChangeAt: className.
		info do: [:each | self atClass: cls add: each].

		info _ aChangeSet methodChanges at: className 
			ifAbsent: [Dictionary new].
		info associationsDo: [:assoc |
			assoc value == #remove ifTrue:
					[self removeSelector: assoc key class: cls]
				ifFalse: 
					[self atSelector: assoc key class: cls put: assoc value]]]].
	self flag: #developmentNote.  "the following cannot work, since the class will not exist; SW comments this out 8/91 because it thwarts integration!!"
"aChangeSet classRemoves do:
		[:removed | self removeClass: (Smalltalk classNamed: removed)] "
!
changeClass: class 
	"Include indication that a class definition has been changed. 
	 6/10/96 sw: don't accumulate this information for classes that don't want logging
	 7/12/96 sw: use wantsChangeSetLogging flag"

	class wantsChangeSetLogging
		ifTrue:
			[self atClass: class add: #change]!
changedClasses
	"Answer a OrderedCollection of changed or edited classes.  Not including removed classes.  Sort alphabetically by name."

	"Much faster to sort names first, then convert back to classes.  Because metaclasses reconstruct their name at every comparison in the sorted collection.
	8/91 sw chgd to filter out non-existent classes (triggered by problems with class-renames"
	classChanges == nil ifTrue: [^ OrderedCollection new].
	^ self changedClassNames collect: 
		[:className | Smalltalk classNamed: className]
			thenSelect:
				[:aClass | aClass notNil]!
changedClassNames
	"Answer a OrderedCollection of the names of changed or edited classes.  Not including removed classes.  Sort alphabetically."

	| classes |
	classes _ SortedCollection new: (methodChanges size + classChanges size) *2.
	methodChanges keys do: [:className | classes add: className].
	classChanges keys do: [:className | 
		(methodChanges includesKey: className) ifFalse: [
			"avoid duplicates"
			classes add: className]].
	^ classes asOrderedCollection!
commentClass: class 
	"Include indication that a class comment has been changed."

	self atClass: class add: #comment!
convertClassAddsToClassChanges
	"1/22/96 sw: as part of a general policy of not storing 'new class' ever, but always having it as a changed class, in order to preserve the specific messages that get changed within this change set, we need to morph existing changesets so that class-adds become class-changes.  This has no method senders, but rather is for invocation from a doit.
	Note that this adds all the selectors for each added class to the changed method list"

	| chg aClass |
	self flag: #scottPrivate.
	self changedClassNames do:
		[:aClassName |
			chg _ self classChangeAt: aClassName.
			(chg includes: #add) ifTrue:
				[chg remove: #add.
				chg add: #change.
				aClass _ Smalltalk at: aClassName.
				aClass selectorsDo:
					[:aSelector | self addSelector: aSelector class: aClass].
				aClass class selectorsDo:
					[:aSelector | self addSelector: aSelector class: aClass class]]]!
flushClassRemoves
	classRemoves _ Set new!
forgetAllChangesFoundIn: aChangeSet
	"Remove from the receiver all method changes found in aChangeSet. The intention is facilitate the process of factoring a large set of changes into disjoint change sets.  3/13/96 sw.  Note that class-(re)-definition changes are not subtracted out, yet."

	| cls itsMethodChanges |

	aChangeSet == self ifTrue: [^ self].

	aChangeSet changedClassNames do:
		[:className | (cls _ Smalltalk classNamed: className) ~~ nil
			ifTrue:
				[itsMethodChanges _ aChangeSet methodChanges at: className  ifAbsent: [Dictionary new].
				itsMethodChanges associationsDo:
					[:assoc | self removeSelectorChanges:  assoc key class: cls]]]!
removeClass: class 
	"Include indication that a class has been forgotten."
	| cName |
	(self isNew: class) ifTrue:
		[^ self removeClassChanges: class]. 	"only remember old classes"
	cName _ (self atClass: class includes: #rename) 	"remember as old name"
		ifTrue: [self oldNameFor: class]
		ifFalse: [class name].
	self removeClassChanges: class.
	classRemoves add: cName!
removeClassAndMetaClassChanges: class
	"Remove all memory of changes associated with this class and its metaclass.  7/18/96 sw"

	classChanges removeKey: class name ifAbsent: [].
	methodChanges removeKey: class name ifAbsent: [].
	classChanges removeKey: class class name ifAbsent: [].
	methodChanges removeKey: class class name ifAbsent: [].
	classRemoves remove: class name ifAbsent: [].!
removeClassChanges: class
	"Remove all memory of changes associated with this class"

	classChanges removeKey: class name ifAbsent: [].
	methodChanges removeKey: class name ifAbsent: [].
	classRemoves remove: class name ifAbsent: [].!
removeNamedClassChanges: className
	"Remove all memory of changes associated with this class name.
	This is here as removeClassChanges: will not work if the class
	has been removed."

	classChanges removeKey: className ifAbsent: [].
	methodChanges removeKey: className ifAbsent: [].
	classRemoves remove: className ifAbsent: [].!
renameClass: class as: newName 
	"Include indication that a class has been renamed."

	| value |
	(self atClass: class includes: #rename) ifFalse:
		[self atClass: class add: 'oldName: ', class name. 	"only original name matters"
		self atClass: class add: #rename].
 	"copy changes using new name (metaclass too)"
	(Array with: classChanges with: methodChanges) do:
		[:changes |
		(value _ changes at: class name ifAbsent: [nil]) == nil ifFalse:
			[changes at: newName put: value.
			changes removeKey: class name].
		(value _ changes at: class class name ifAbsent: [nil]) == nil ifFalse:
			[changes at: (newName, ' class') put: value.
			changes removeKey: class class name]]!
reorganizeClass: class 
	"Include indication that a class was reorganized."

	self atClass: class add: #reorganize! !

!ChangeSet methodsFor: 'method changes'!
addSelector: selector class: class 
	"Include indication that a method has been added.
	 5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions."

	Utilities noteMethodSubmission: selector forClass: class name.
	self atSelector: selector class: class put: #add!
allMessagesForAddedClasses
	| messageList  mAssoc |
	"Smalltalk changes allMessagesForAddedClasses"
	messageList _ SortedCollection new.
	classChanges associationsDo:
		[:clAssoc |
		(clAssoc value includes: #add)
			ifTrue:
				[(Smalltalk at: clAssoc key) selectorsDo:
					[:aSelector | 
						messageList add: clAssoc key asString, ' ' , aSelector].
				(Smalltalk at: clAssoc key) class selectorsDo:
					[:aSelector | 
						messageList add: clAssoc key asString, ' class ' , aSelector]]].
	^ messageList asArray!
browseMessagesWithPriorVersions
	"Open a message list browser on the new and changed methods in the receiver which have at least one prior version.  6/28/96 sw"

	| aList aSelector aClass |

	aList _ self changedMessageListAugmented select:
		[:msg |  Utilities setClassAndSelectorFrom: msg in: 
				[:cl :sl | aClass _ cl.  aSelector _ sl].
			(ChangeList versionCountForSelector: aSelector class: aClass) > 1].
	aList size > 0 ifFalse: [self inform: 'None!!'.  ^ nil].
	Smalltalk browseMessageList: aList name: (self name, ' methods that have prior versions')!
changedMessageList
	"Used by a message set browser to access the list view information."

	| messageList |
	messageList _ SortedCollection new.
	methodChanges associationsDo: 
		[:clAssoc | 
		clAssoc value associationsDo: 
			[:mAssoc |
			mAssoc value = #remove ifFalse:
				[messageList add: clAssoc key asString, ' ' , mAssoc key]]].
	^messageList asArray!
changedMessageListAugmented
	"In addition to changedMessageList, put all messages for all added classes in the ChangeSet."
	^ self changedMessageList asArray, self allMessagesForAddedClasses!
changeSelector: selector class: class 
	"Include indication that a method has been edited. 
	 5/16/96 sw: tell Utilities of the change so it can put up an in-order browser on recent submissions."

	Utilities noteMethodSubmission: selector forClass: class name.
	(self atSelector: selector class: class) = #add 
		ifFalse: [self atSelector: selector class: class put: #change]
			"Don't forget a method is new just because it's been changed"!
removeSelector: selector class: class 
	"Include indication that a method has been forgotten."

	(self atSelector: selector class: class) = #add
		ifTrue: [self removeSelectorChanges: selector 
					class: class]					"Forgot a new method, no-op"
		ifFalse: [self atSelector: selector
					class: class
					put: #remove]!
removeSelectorChanges: selector class: class 
	"Remove all memory of changes associated with the argument, selector, in 
	this class."

	| dictionary |
	dictionary _ methodChanges at: class name ifAbsent: [^self].
	dictionary removeKey: selector ifAbsent: [].
	dictionary isEmpty ifTrue: [methodChanges removeKey: class name]!
selectorsInClass: aClass
	"Used by a ChangeSorter to access the list methods."
	"later include class changes"
	^ (methodChanges at: aClass ifAbsent: [^#()]) keys! !

!ChangeSet methodsFor: 'fileIn/Out'!
fileOut
	"File out the receiver, to a file whose name is a function of the change-set name and of the date and the time.  1/18/96 sw
 2/4/96 sw: show write cursor
	5/30/96 sw: put a dot before the date/time stamp"

	| file |
	Cursor write showWhile:
		[file _ FileStream newFileNamed: ((self name, '.', Utilities dateTimeSuffix, '.cs') truncateTo: 27).
		file header; timeStamp.
		self fileOutOn: file.
		file trailer; close]!
fileOutChangesFor: class on: stream 
	"Write out all the changes the receiver knows about this class.
	 5/15/96 sw: altered to call fileOutClassModifications:on: rather than fileOutClassChanges:on:, so that class headers won't go out as part of this process (they no go out at the beginning of the fileout"

	| changes |
					"first file out class changes"
	self fileOutClassModifications: class on: stream.
					"next file out changed methods"
	changes _ OrderedCollection new.
	(methodChanges at: class name ifAbsent: [^ self]) associationsDo: 
		[:mAssoc | 
		mAssoc value = #remove
			ifFalse: [changes add: mAssoc key]].
	changes isEmpty ifFalse: 
		[class fileOutChangedMessages: changes on: stream.
		stream cr]!
fileOutOn: stream 
	"Write out all the changes the receiver knows about.
	 5/15/96 sw: changed such that class headers for all changed classes go out at the beginning of the file."

	| classList |
	self isEmpty ifTrue: [self notify: 'Warning: no changes to file out'].
	classList _ ChangeSet superclassOrder: self changedClasses asOrderedCollection.
	classList do:
		[:aClass |  "if class defn changed, put it onto the file now"
			self fileOutClassDefinition: aClass on: stream].
	classList do:
		[:aClass |  "nb: he following no longer puts out class headers"
			self fileOutChangesFor: aClass on: stream].
	stream cr.
	classList do:
		[:aClass |
		self fileOutPSFor: aClass on: stream].
	classRemoves do:
		[:aClassName |
		stream nextChunkPut: aClassName, ' removeFromSystem'; cr].!
fileOutPSFor: class on: stream 
	"Write out removals and initialization for this class."

	(methodChanges at: class name ifAbsent: [^self]) associationsDo: 
		[:mAssoc | 
		mAssoc value = #remove
			ifTrue: [stream nextChunkPut:
				class name, ' removeSelector: ', mAssoc key storeString; cr]
			ifFalse: [(mAssoc key = #initialize and: [class isMeta])
					ifTrue: [stream nextChunkPut: class soleInstance name, ' initialize'; cr]]]! !

!ChangeSet methodsFor: 'private'!
atClass: class add: changeType

	(self isNew: class) ifFalse: 	"new classes don't matter"
		[(classChanges at: class name
				ifAbsent: [^classChanges at: class name put:
					(Set with: changeType)])
			add: changeType]!
atClass: class includes: changeType

	^(classChanges at: class name ifAbsent: [^false])
		includes: changeType!
atSelector: selector class: class

	^(methodChanges at: class name ifAbsent: [^#none])
		at: selector ifAbsent: [#none]!
atSelector: selector class: class put: changeType
	| dict |
	(self isNew: class) ifTrue: [^self]. 	"Don't keep method changes for new classes"
	(selector==#DoIt) | (selector==#DoItIn:) ifTrue: [^self].
	(methodChanges at: class name
		ifAbsent: 
			[dict _ IdentityDictionary new.
			methodChanges at: class name put: dict.
			dict])
		at: selector put: changeType !
fileOutClassChanges: class on: stream 
	"Write out class changes, i.e. new class, definition, comment, renaming."

	(self atClass: class includes: #add) ifTrue:
		[stream cr.
		class fileOutOn: stream.
		stream cr].

	(self atClass: class includes: #rename) ifTrue:
		[stream nextChunkPut: (self oldNameFor: class), ' rename: #', class name; cr].

	(self atClass: class includes: #change) ifTrue:
		[stream emphasis: 5; nextChunkPut: class definition; cr; emphasis: 1].

	(self atClass: class includes: #comment) ifTrue:
		[class organization putCommentOnFile: stream
			numbered: nil moveSource: false.
		stream cr].

	(self atClass: class includes: #reorganize) ifTrue:
		[class fileOutOrganizationOn: stream.
		stream cr]!
fileOutClassDefinition: class on: stream 
	"Write out class definition for the given class on the given stream, if the class definition was added or changed.  5/15/96 sw"

	((self atClass: class includes: #add) or: [self atClass: class includes: #change])
		ifTrue:
			[stream emphasis: 5; nextChunkPut: class definition; cr; emphasis: 1]!
fileOutClassModifications: class on: stream 
	"Write out class mod-- rename, comment, reorg, remove, on the given stream.  Differs from the superseded fileOutClassChanges:on: in that it does not deal with class definitions, and does not file out entire added classes.  5/15/96 sw"

	(self atClass: class includes: #rename) ifTrue:
		[stream nextChunkPut: (self oldNameFor: class), ' rename: #', class name; cr].

	(self atClass: class includes: #comment) ifTrue:
		[class organization putCommentOnFile: stream
			numbered: nil moveSource: false.
		stream cr].

	(self atClass: class includes: #reorganize) ifTrue:
		[class fileOutOrganizationOn: stream.
		stream cr]!
inspectMethodChanges
	methodChanges inspect!
isNew: class
	"Answer whether this class was added since the ChangeSet was cleared."

	(class isKindOf: Metaclass)
		ifTrue: [^self atClass: class soleInstance includes: #add "check class"]
		ifFalse: [^self atClass: class includes: #add]!
oldNameFor: class
	| cName |
	cName _ (classChanges at: class name) asOrderedCollection
				detect: [:x | 'oldName: *' match: x].
	^ (Scanner new scanTokens: cName) last! !

!ChangeSet methodsFor: 'accessing'!
methodChanges
	^methodChanges!
name: anObject
	name _ anObject!
printOn: aStream
	"2/7/96 sw: provide the receiver's name in the printout"
	super printOn: aStream.
	aStream nextPutAll: ' named ', self name! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeSet class
	instanceVariableNames: ''!

!ChangeSet class methodsFor: 'instance creation'! !

!ChangeSet class methodsFor: 'fileIn/Out'!
superclassOrder: classes 
	"Arrange the classes in the collection, classes, in superclass order so the 
	classes can be properly filed in."

	| all list i aClass superClass |
	list _ classes copy. 			"list is indexable"
	all _ OrderedCollection new: list size.
	[list size > 0]
		whileTrue: 
			[aClass _ list first.
			superClass _ aClass superclass.
			"Make sure it doesn't have an as yet uncollected superclass"
			[superClass == nil or: [list includes: superClass]]
				whileFalse: [superClass _ superClass superclass].
			i _ 1.
			[superClass == nil]
				whileFalse: 
					[i _ i + 1.
					aClass _ list at: i.
					superClass _ aClass superclass.
					"check as yet uncollected superclass"
					[superClass == nil or: [list includes: superClass]]
						whileFalse: [superClass _ superClass superclass]].
			all addLast: aClass.
			list _ list copyWithout: aClass].
	^all! !

!ChangeSet class methodsFor: 'defaults'!
defaultName
	| namesInUse try |
	namesInUse _ ChangeSorter gatherChangeSets
					collect: [:each | each name].
	1 to: 999999 do:
		[:i | try _ 'Unnamed' , i printString.
		(namesInUse includes: try) ifFalse: [^ try]]! !StringHolder subclass: #ChangeSorter
	instanceVariableNames: 'parent myChangeSet classList messageList buttonView '
	classVariableNames: 'AllChangeSets CngSetSelectors MsgListMenu SingleCngSetMenu CngSetMenu MsgListSelectors ClassSelectors ClassMenu '
	poolDictionaries: ''
	category: 'Interface-Changes'!

!ChangeSorter methodsFor: 'creation'!
aReadThis
	"This class presents a view of a single change set.  A DualChangeSorter owns two of me.  The name pane across the top has a menu of things to do to the ChangeSet I am currently showing.  
	Renames of classes are not shown properly.  'Copy to other side' overwrites what was there if the other change set had the same method or class change.

	ChangeSorter new open.
	ChangeSorter allInstances inspect
	"!
defaultBackgroundColor
	^ #lightBlue!
initialize
	myChangeSet _ Smalltalk changes.		"default"
	classList _ CngsClassList new.
	classList parent: self.
	messageList _ CngsMsgList new.
	messageList parent: self.
	MsgListMenu == nil ifTrue: [self class initialize].
	classList list: #().
	messageList list: #().
!
open
	| topView |
	self initialize.

	topView _ StandardSystemView new.
	topView model: self.
	topView label: self label.
	topView minimumSize: 360@360.
	self openView: topView.
	topView controller open		"Let the show begin"!
openView: topView
	"Create change sorter on one changeSet only.  Two of these in a DualChangeSorter."
	| classView messageView codeView |

	buttonView _ SwitchView new.
	buttonView model: self controller: TriggerController new.
	buttonView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	buttonView selector: #whatPolarity.
	buttonView controller selector: #cngSetActivity.
	buttonView window: (0 @ 0 extent: 360 @ 20).
	buttonView label: myChangeSet name asParagraph.

	classView _ GeneralListView new.
	classView controllerClass: GeneralListController.
	classView model: classList.
	classView window: (0 @ 0 extent: 180 @ 160).
	classView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	classView controller yellowButtonMenu: ClassMenu 
		yellowButtonMessages: ClassSelectors.
	classList controller: classView controller.


	messageView _ GeneralListView new.
	messageView controllerClass: GeneralListController.
	messageView model: messageList.
	messageView window: (0 @ 0 extent: 180 @ 160).
	messageView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	messageView controller yellowButtonMenu: MsgListMenu 
		yellowButtonMessages: MsgListSelectors.
	messageList controller: messageView controller.

	codeView _ BrowserCodeView new.
	codeView model: self.
	codeView window: (0 @ 0 extent: 360 @ 180).
	codeView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.
	"codeView editString: aString."

	topView addSubView: buttonView.
	topView addSubView: classView.
	topView addSubView: messageView.
	topView addSubView: codeView.

	classView 
		align: classView viewport topLeft 	
		with: buttonView viewport bottomLeft.
	messageView 
		align: messageView viewport topLeft 	
		with: classView viewport topRight.
	codeView 
		align: codeView viewport topLeft 	
		with: classView viewport bottomLeft.
! !

!ChangeSorter methodsFor: 'startUp'!
changed: what
	"Respond to an external change.  By tck, mid-1991.
	 3/1/96 sw: present message lists in sorted order"

	| cls |
	what == #set ifTrue: [^ self launch].
	what == #class ifTrue:
		[self verifyLabel.
		(cls _ classList selectedClassOrMetaClass) == nil
			ifFalse: [messageList list:
					((myChangeSet selectorsInClass: cls name) collect: 
						[:each | each printString]) asSortedCollection]
			ifTrue: [messageList list: #()].
		^ self].

	what == #message ifTrue:
		[self setContents.
		^ super changed: #editMessage].
	super changed: what!
label
	^ 'Changes go to "', (Smalltalk changes name), '"'!
launch
	"recompute what to show in all panes"
	| cls msg |
	buttonView label: myChangeSet name asParagraph.  "in case it changed"
	buttonView display.
	cls _ classList selection.		"save current selection"
	msg _ messageList selection.
	Cursor wait showWhile: [
		classList list: (myChangeSet changedClasses collect: 
				[:each | each printString]) asOrderedCollection].
	classList selection: cls.		"try to reselect old selection, if there"
	messageList selection: msg.
	self setContents.!
parent
	^parent!
parent: anObject
	parent _ anObject!
verifyLabel
	"May have changed since we last were in this window"
	buttonView == nil ifTrue: [^ self].
	buttonView topView label asString = self label 
		ifFalse: [buttonView topView relabel: self label].
! !

!ChangeSorter methodsFor: 'change set menu'!
browseChangeSet
	"Open a message list browser on the new and changed methods in the current change set.  2/2/96 sw"

	Smalltalk browseMessageList: myChangeSet changedMessageListAugmented name: 'Methods in Change Set ', myChangeSet name!
browseMessagesWithPriorVersions
	"Open a message list browser on the new and changed methods in the current change set which have at least one prior version.  Potentially a menu command, though its use is perhaps somewhat obscure, so for the moment I'm only getting at this feature via direct calls to the ChangeSet method, through explicit doIts.  6/28/96 sw"

	myChangeSet browseMessagesWithPriorVersions!
changeSet
	^ myChangeSet!
chooseCngSet
	"Put up a list of them"
	| index |
	ChangeSet instanceCount > AllChangeSets size ifTrue: [self gather].
	index _ (PopUpMenu labels: 
		(AllChangeSets collect: [:each | each name]) asStringWithCr) startUp.
	index = 0 ifFalse: [
		myChangeSet _ AllChangeSets at: index.
		buttonView label: myChangeSet name asParagraph.
		buttonView display.
		self changed: #set].!
cngSetActivity
	"Put up a menu and do what the user says.  1991 tck;
	5/9/96 sw: highlight button while mouse down
	5/29/96 sw: use different menu for single-change-sorter case"

	| index reply |

	buttonView displayComplemented.
	parent == nil "Single change sorter"
		ifTrue:
			[reply _ SingleCngSetMenu startUp.
			reply == nil ifFalse:
				[self perform: reply]]
		ifFalse:
			[index _ CngSetMenu startUp.
			index == 0 ifFalse:
				[self perform: (CngSetSelectors at: index)]].
	buttonView displayNormal!
copyToOther
	"Copy this entire change set into the one on the other side"

	"controller controlTerminate."
	| other |
	other _ (parent other: self) changeSet.

	other assimilateAllChangesFoundIn: myChangeSet.
	(parent other: self) launch.
	"controller controlInitialize"!
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; in the end, leave the current change-set unaltered.  5/30/96 sw."

	| aFileName  aNewChangeSet |

	aFileName _ FillInTheBlank request: 'Name of file to be imported: '.
	aFileName size == 0 ifTrue: [^ self].
	(FileDirectory default includesKey: aFileName) ifFalse:
		[self inform: 'Sorry -- cannot find that file'.
		^ self].

	aNewChangeSet _ self class newChangesFromFile: aFileName.
	aNewChangeSet ~~ nil ifTrue:
		[myChangeSet _ aNewChangeSet.
		buttonView label: aNewChangeSet name asParagraph.
		buttonView display.
		self changed: #set]!
fileOut
	"File out the current change set.  1/18/96 sw"

	myChangeSet fileOut!
gather
	"Make sure the class variable AllChangeSets is up to date.  1/22/96 sw"

	self class gatherChangeSets!
newCurrent
	"make my change set be the current one that changes go into"
	Smalltalk newChanges: myChangeSet.
	buttonView topView relabel: self label.!
newSet
	"Create a new changeSet and show it.  For splitting an existing one that is showing in the other pane..  1991-tck.
	 3/9/96 sw: make the new guy the current one, corresponding to 99.5% of normal use.  Also, reject name if already in use."

	| newName |
	newName _ FillInTheBlank request: 'A name for the new change set'
			initialAnswer: ChangeSet defaultName.

	newName isEmpty ifTrue: [^ self].
	(self class changeSetNamed: newName) ~~ nil
		ifTrue:
			[self inform: 'Sorry that name is already used'.
			^ self].

	myChangeSet _ ChangeSet new initialize.
	myChangeSet name: newName.
	AllChangeSets add: myChangeSet.
	buttonView label: myChangeSet name asParagraph.
	buttonView display.
	self newCurrent.
	self changed: #set!
remove
	"Completely destroy my change set.  Check if it's OK first.  tck 1991
	 1/22/96 sw MacPal -> Utilities.  2/7/96 sw: changed the order of the various checks; don't put up confirmer if the change set is empty"

	| message |

	myChangeSet == Smalltalk changes ifTrue:
		[self inform: 'Cannot remove the 
current change set.'.
		^ self].

	Project allInstances do: [:each |
		each projectChangeSet == myChangeSet ifTrue:
			[Utilities inform: 'This change set belongs to a 
project and cannot be removed.'.
			^ self]].

	myChangeSet isEmpty ifFalse:
		[message _ 'Are you certain that you want to 
forget all the changes in this set?'.
		(self confirm: message) ifFalse: [^ self]].

	"Go ahead and remove the change set"
	AllChangeSets remove: myChangeSet.
	myChangeSet wither.		"clear out its contents"
	"Show the current change set"
	myChangeSet _ Smalltalk changes.
	buttonView label: myChangeSet name asParagraph.
	buttonView display.
	self changed: #set!
rename
	"Store a new name string into the selected ChangeSet.  1991-tck.
	 3/9/96 sw: several fixes:  reject duplicate name; allow user to back out"

	| newName |
	newName _ FillInTheBlank request: 'A 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) ~~ nil
		ifTrue:
			[Utilities inform: 'Sorry that name is already used'.
			^ self].

	myChangeSet name: newName.
	buttonView label: newName asParagraph.
	buttonView display.
	myChangeSet == Smalltalk changes ifTrue:
		[buttonView topView relabel: self label]!
subtractOtherSide
	"Subtract the changes found on the other side from the requesting side.  3/13/96 sw"

	| other |
	other _ (parent other: self) changeSet.
	myChangeSet forgetAllChangesFoundIn: other.
	self launch!
whatPolarity
	"button at top is white (off), not black"
	^ false! !

!ChangeSorter methodsFor: 'class list'!
selectedClass
	^ classList selectedClass!
selectedClassOrMetaClass
	^ classList selectedClassOrMetaClass! !

!ChangeSorter methodsFor: 'message list'!
messageListIndex
	^ messageList listIndex!
selectedMessage
	^ self selectedClassOrMetaClass sourceMethodAt: self selectedMessageName!
selectedMessageName
	| sel |
	^ (sel _ messageList selection) == nil ifFalse: [sel asSymbol]
		ifTrue: [nil]! !

!ChangeSorter methodsFor: 'code pane'!
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 notice |
	messageList listIndex = 0 ifTrue: [^ false].
	class _ self selectedClassOrMetaClass.
	oldSelector _ self selectedMessageName.
	category _ class organization categoryOfElement: oldSelector.
	selector _ class
				compile: aString
				classified: category
				notifying: aController.
	selector == nil ifTrue: [^false].
	selector == oldSelector ifFalse: [self changed: #message].
	notice _ class checkForPerform: selector in: aController.
	notice size = 0 ifFalse: ["insert the notice"
			aController notify: notice
				at: contents size + 1
				in: nil.
			self lock  "code is dirty"].
	^true!
editSelection
	^ #editMessage!
setContents
	"return the source code that shows in the bottom pane"
	| sel class strm what |
	self unlock.
	(classList selection) == nil ifTrue: [^ contents _ ''].
	class _ classList selectedClassOrMetaClass.
	(sel _ messageList selection) == nil
		ifFalse: [
			what _ (myChangeSet atSelector: (sel _ sel asSymbol) class: class).
			what == #remove ifFalse: [
				(class includesSelector: sel) ifFalse: [
					^ contents _ 'was added, but it''s gone!! ******'].
				^ contents _ (class sourceMethodAt: sel) copy]
			  ifTrue: [^ contents _ 'remove the method ******']]
		ifTrue: [strm _ WriteStream on: (String new: 100).
			(myChangeSet classChangeAt: class name) do: [:each |
				each = #remove ifTrue: [strm nextPutAll: '**** entire class was removed ****'; cr].
				each = #add ifTrue: [strm nextPutAll: '**** entire class was added ****'; cr].
				each = #change ifTrue: [strm nextPutAll: '**** class definition was changed ****'; cr].
				each = #comment ifTrue: [strm nextPutAll: '**** new class comment ****'; cr]].
			^ contents _ strm contents].!
spawn: aString 
	"Create and schedule a message browser for the receiver in which the 
	argument, aString, contains characters to be edited in the text view."

	messageList listIndex = 0 ifTrue: [^ self].
	^ BrowserView
		openMessageBrowserForClass: self selectedClassOrMetaClass
		selector: self selectedMessageName
		editString: aString! !

!ChangeSorter methodsFor: 'accessing'!
messageList
	^messageList! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ChangeSorter class
	instanceVariableNames: ''!

!ChangeSorter class methodsFor: 'as yet unclassified'!
changeSetNamed: aName
	"Return the change set of the given name, or nil if none found.  1/22/96 sw"

	self gatherChangeSets.
	AllChangeSets do:
		[:aChangeSet | aChangeSet name = aName ifTrue:
			[^ aChangeSet]].
	^ nil!
gatherChangeSets
	"Collect any change sets created in other projects  1/22/96 sw
	 2/7/96 sw: filter out moribund guys"

	ChangeSet allInstancesDo: [:each |
		(AllChangeSets includes: each) ifFalse:
			[AllChangeSets add: each]].
	^ AllChangeSets _ AllChangeSets select:
		[:each | each isMoribund not]

	"ChangeSorter gatherChangeSets"!
initialize
	"Initialize the class.  1991-tck
	Modified 1/12/96 sw: added a bunch of new items, not all of them implemented yet.  2/2/96 sw: added browse change set.  Also made it such that if AllChangeSets already exists, this won't clobber the existing order.  2/5/96 sw: changed wording of some items
	5/8/96 sw: added subtractOtherSide
	5/29/96 sw: added SingleCngSetMenu, for single change sorter
	5/30/96 sw: added fileIntoNewChangeSet
	7/23/96 di: removed SingleCngSetMenu, since not used"

	AllChangeSets == nil ifTrue:
		[AllChangeSets _ OrderedCollection new].
	self gatherChangeSets.

	CngSetMenu _ PopUpMenu labels: 
'make changes go to me
new...
file into new...
show...
fileOut
browse
rename
copy all to other side
subtract other side
remove'    lines: #(1 3 7 9).
	CngSetSelectors  _ 
		#(newCurrent newSet fileIntoNewChangeSet chooseCngSet fileOut browseChangeSet rename copyToOther subtractOtherSide remove).

	ClassMenu _ PopUpMenu labels: 
'browse class
browse full
inst var refs
class vars
copy to other side
forget' 
			lines: #().
	ClassSelectors _ 
		#(browse browseFull instVarRefs classVariables copyToOther forget).

	MsgListMenu _ PopUpMenu labels: 
'fileOut
senders
implementors
senders of...
implementors of...
implementors of sent msgs
versions
copy to other side
forget' 
			lines: #(1 6 7).
	MsgListSelectors _ 
		#(fileOut senders implementors browseSendersOfMessages messages
		allImplementorsOf versions copyToOther forget).
	false ifTrue: [
		"Just so senders will find it here!!!!!!  Never executed."
		(CngsMsgList new) fileOut; senders; implementors; messages;  
			versions; copyToOther; forget.
		(MessageListController new) browseSendersOfMessages; 
			allImplementorsOf].

	"
	ChangeSorter initialize.
	GeneralListController allInstancesDo:
		[:each  | each model parent class == ChangeSorter ifTrue: [
			each yellowButtonMenu: ClassMenu 
				yellowButtonMessages: ClassSelectors.
			each yellowButtonMenu: MsgListMenu 
				yellowButtonMessages: MsgListSelectors]].
	"!
makeCurrent: aChangeSet
	"Make aChangeSet be the one that changes will accumulate into.  5/30/96 sw"

	Smalltalk newChanges: aChangeSet!
newChangesFromFile: aFileName
	"File in the code from the file of the given name, into a new change set whose name is derived from that of the filename.  Leave the 'current change set' unchanged.   Returns the new change set; Returns nil on failure.  5/30/96 sw"

	|  newName aNewChangeSet existingChanges |

	existingChanges _ Smalltalk changes.
	newName _ aFileName sansPeriodSuffix.
	(self changeSetNamed: newName) ~~ nil
		ifTrue:
			[self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.
			^ nil].

	aNewChangeSet _ ChangeSet new initialize.
	aNewChangeSet name: newName.
	AllChangeSets add: aNewChangeSet.
	self makeCurrent: aNewChangeSet.
	(FileStream oldFileNamed: aFileName) fileIn.
	Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.
	self makeCurrent: existingChanges.
	^ aNewChangeSet!
newChangesFromFileStream: aFileStream
	"File in the code from the file, into a new change set whose name is derived from the filename.  Leave the 'current change set' unchanged.   Returns the new change set;  Returns nil on failure.  7/12/96 sw"

	|  newName aNewChangeSet existingChanges aFileName |

	existingChanges _ Smalltalk changes.
	aFileName _ aFileStream localName.
	newName _ aFileName sansPeriodSuffix.
	(self changeSetNamed: newName) ~~ nil
		ifTrue:
			[self inform: 'Sorry -- "', newName, '" is already used as a change-set name'.
			aFileStream close.
			^ nil].

	aNewChangeSet _ ChangeSet new initialize.
	aNewChangeSet name: newName.
	AllChangeSets add: aNewChangeSet.
	self makeCurrent: aNewChangeSet.
	aFileStream fileIn.
	Transcript cr; show: 'File ', aFileName, ' successfully filed in to change set ', newName.
	self makeCurrent: existingChanges.
	^ aNewChangeSet! !

ChangeSorter initialize!
Magnitude subclass: #Character
	instanceVariableNames: 'value '
	classVariableNames: 'CharacterTable '
	poolDictionaries: ''
	category: 'Collections-Text'!
Character comment:
'I represent a character by storing its associated ASCII code (extended to 256 codes). My instances are created uniquely, so that all instances of a character ($R, for example) are identical.'!

!Character methodsFor: 'accessing'!
asciiValue
	"Answer the value of the receiver that represents its ascii encoding."

	^value!
digitValue
	"Answer 0-9 if the receiver is $0-$9, 10-35 if it is $A-$Z or $a-$z, and < 0 
	otherwise. This is used to parse literal numbers of radix 2-36."

	value <= $9 asciiValue 
		ifTrue: [^value - $0 asciiValue].
	value >= $A asciiValue 
		ifTrue: [value <= $Z asciiValue ifTrue: [^value - $A asciiValue + 10]].
	value >= $a asciiValue 
		ifTrue: [value <= $z asciiValue ifTrue: [^value - $a asciiValue + 10]].
	^-1! !

!Character methodsFor: 'comparing'!
< aCharacter 
	"Answer true if the receiver's value < aCharacter's value."

	^self asciiValue < aCharacter asciiValue!
= 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!
> aCharacter 
	"Answer true if the receiver's value > aCharacter's value."

	^self asciiValue > aCharacter asciiValue!
hash
	"Hash is reimplemented because = is implemented."

	^value! !

!Character methodsFor: 'testing'!
isAlphaNumeric
	"Answer whether the receiver is a letter or a digit."

	^self isLetter or: [self isDigit]!
isDigit
	"Answer whether the receiver is a digit."

	^value >= 48 and: [value <= 57]!
isLetter
	"Answer whether the receiver is a letter."

	^(8r141 <= value and: [value <= 8r172])
		or: [8r101 <= value and: [value <= 8r132]]!
isLowercase
	"Answer whether the receiver is a lowercase letter.
	(The old implementation answered whether the receiver is not an uppercase letter.)"

	^8r141 <= value and: [value <= 8r172]!
isSeparator
	"Answer whether the receiver is one of the separator characters--space, 
	cr, tab, line feed, or form feed."

	value = 32 ifTrue: [^true].	"space"
	value = 13 ifTrue: [^true].	"cr"
	value = 9 ifTrue: [^true].	"tab"
	value = 10 ifTrue: [^true].	"line feed"
	value = 12 ifTrue: [^true].	"form feed"
	^false!
isSpecial
	"Answer whether the receiver is one of the special characters"

	^'+/\*~<>=@%|&?!!' includes: self!
isUppercase
	"Answer whether the receiver is an uppercase letter.
	(The old implementation answered whether the receiver is not a lowercase letter.)"

	^8r101 <= value and: [value <= 8r132]!
isVowel
	"Answer whether the receiver is one of the vowels, AEIOU, in upper or 
	lower case."

	^'AEIOU' includes: self asUppercase!
tokenish
	"Answer whether the receiver is a valid token-character--letter, digit, or 
	colon."

	^self isLetter or: [self isDigit or: [self = $:]]! !

!Character methodsFor: 'copying'!
copy
	"Answer with the receiver because Characters are unique."!
deepCopy
	"Answer with the receiver because Characters are unique."! !

!Character methodsFor: 'printing'!
hex
	^ String with: ('0123456789ABCDEF' at: value//16+1)
			with:  ('0123456789ABCDEF' at: value\\16+1)!
isLiteral

	^true!
printOn: aStream

	aStream nextPut: $$.
	aStream nextPut: self!
storeOn: aStream
	"Character literals are preceded by '$'."

	aStream nextPut: $$; nextPut: self! !

!Character methodsFor: 'converting'!
asCharacter
	"Answer the receiver itself."

	^self!
asInteger
	"Answer the value of the receiver."

	^value!
asLowercase
	"If the receiver is uppercase, answer its matching lowercase Character."
	
	self isUppercase ifTrue: [^Character value: value+8r40]!
asString
	| cString |
	cString _ String new: 1.
	cString at: 1 put: self.
	^ cString!
asSymbol 
	"Answer a Symbol consisting of the receiver as the only element."

	^Symbol internCharacter: self!
asUppercase
	"If the receiver is lowercase, answer its matching uppercase Character."
	
	(8r141 <= value and: [value <= 8r172])  "self isLowercase"
		ifTrue: [^ Character value: value - 8r40]
		ifFalse: [^ self]!
to: other
	"Answer with a collection in ascii order -- $a to: $z"
	^ (self asciiValue to: other asciiValue) collect:
				[:ascii | Character value: ascii]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Character class
	instanceVariableNames: ''!

!Character class methodsFor: 'class initialization'!
initialize
	"Create the table of unique Characters. This code is not shown so that the
	user can not destroy the system by trying to recreate the table."! !

!Character class methodsFor: 'instance creation'!
digitValue: x 
	"Answer the Character whose digit value is x. For example, answer $9 for 
	x=9, $0 for x=0, $A for x=10, $Z for x=35."

	| index |
	index _ x asInteger.
	^CharacterTable at: 
		(index < 10
			ifTrue: [48 + index]
			ifFalse: [55 + index])
		+ 1!
new
	"Creating new characters is not allowed."

	self error: 'cannot create new characters'!
separators
	^ #(32 "space"
		13 "cr"
		9 "tab"
		10 "line feed"
		12 "form feed")
		collect: [:v | Character value: v]

	
!
value: anInteger 
	"Answer the Character whose value is anInteger."

	^CharacterTable at: anInteger + 1! !

!Character class methodsFor: 'accessing untypeable characters'!
apple
	"Answer the Character representing an Apple."

	^self value: 20!
backspace
	"Answer the Character representing a backspace."

	^self value: 8!
cr
	"Answer the Character representing a carriage return."

	^self value: 13!
enter
	"Answer the Character representing enter."

	^self value: 3!
esc
	"Answer the Character representing an escape."

	^self value: 160!
newPage
	"Answer the Character representing a form feed."

	^self value: 12!
space
	"Answer the Character representing a space."

	^self value: 32!
tab
	"Answer the Character representing a tab."

	^self value: 9! !

!Character class methodsFor: 'constants'!
alphabet
	"In case someone needs it"
	^'abcdefghijklmnopqrstuvwxyz'!
characterTable
	"Answer the class variable in which unique Characters are stored."

	^CharacterTable! !

Character initialize!
Rectangle subclass: #CharacterBlock
	instanceVariableNames: 'stringIndex character '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Support'!
CharacterBlock comment:
'My instances contain information about displayed characters. They are used to return the results of methods:
	Paragraph characterBlockAtPoint: aPoint and
	Paragraph characterBlockForIndex: stringIndex.
Any recomposition or movement of a Paragraph can make the instance obsolete.'!

!CharacterBlock methodsFor: 'accessing'!
character
	"Answer the character in the receiver."

	^character!
stringIndex
	"Answer the position of the receiver in the string it indexes."

	^stringIndex! !

!CharacterBlock methodsFor: 'comparing'!
< aCharacterBlock 
	"Answer whether the string index of the receiver precedes that of 
	aCharacterBlock."

	^stringIndex < aCharacterBlock stringIndex!
<= aCharacterBlock 
	"Answer whether the string index of the receiver does not come after that 
	of aCharacterBlock."

	^(self > aCharacterBlock) not!
= aCharacterBlock

	self species = aCharacterBlock species
		ifTrue: [^stringIndex = aCharacterBlock stringIndex]
		ifFalse: [^false]!
> aCharacterBlock 
	"Answer whether the string index of the receiver comes after that of 
	aCharacterBlock."

	^aCharacterBlock < self!
>= aCharacterBlock 
	"Answer whether the string index of the receiver does not precede that of 
	aCharacterBlock."

	^(self < aCharacterBlock) not! !

!CharacterBlock methodsFor: 'copying'!
copy

	^self deepCopy! !

!CharacterBlock methodsFor: 'printing'!
printOn: aStream

	aStream nextPutAll: 'a CharacterBlock with index '.
	stringIndex printOn: aStream.
	aStream nextPutAll: ' and character '.
	character printOn: aStream.
	aStream nextPutAll: ' and rectangle '.
	super printOn: aStream! !

!CharacterBlock methodsFor: 'private'!
newStringIndex: anInteger Character: aCharacter BoundingRectangle: aRectangle

	stringIndex _ anInteger.
	character _ aCharacter.
	super origin: aRectangle topLeft.
	super corner: aRectangle corner!
newStringIndex: anInteger Character: aCharacter TopLeft: originPoint Extent: extentPoint

	stringIndex _ anInteger.
	character _ aCharacter.
	super origin: originPoint.
	super extent: extentPoint! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CharacterBlock class
	instanceVariableNames: ''!

!CharacterBlock class methodsFor: 'instance creation'!
stringIndex: anInteger character: aCharacter boundingRectangle: aRectangle 
	"Answer an instance of me with values set to the arguments."

	^self new
		newStringIndex: anInteger
		Character: aCharacter
		BoundingRectangle: aRectangle!
stringIndex: anInteger character: aCharacter topLeft: originPoint extent: extentPoint 
	"Answer an instance of me with values set to the arguments."

	^self new
		newStringIndex: anInteger
		Character: aCharacter
		TopLeft: originPoint
		Extent: extentPoint! !CharacterScanner subclass: #CharacterBlockScanner
	instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Support'!
CharacterBlockScanner comment:
'My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.'!

!CharacterBlockScanner methodsFor: 'scanning'!
characterBlockAtPoint: aPoint in: aParagraph
	"Answer a CharacterBlock for character in aParagraph at point aPoint. It 
	is assumed that aPoint has been transformed into coordinates appropriate 
	to the text's destination form rectangle and the composition rectangle."

	super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle.
	characterPoint _ aPoint.
	^self buildCharacterBlockIn: aParagraph!
characterBlockForIndex: targetIndex in: aParagraph 
	"Answer a CharacterBlock for character in aParagraph at targetIndex. The 
	coordinates in the CharacterBlock will be appropriate to the intersection 
	of the destination form rectangle and the composition rectangle."

	super 
		initializeFromParagraph: aParagraph 
		clippedBy: aParagraph clippingRectangle.
	characterIndex _ targetIndex.
	characterPoint _ 
		aParagraph rightMarginForDisplay @ 
			(aParagraph topAtLineIndex: 
				(aParagraph lineIndexOfCharacterIndex: characterIndex)).
	^self buildCharacterBlockIn: aParagraph!
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) @ textStyle lineGrid.
	^super characterNotInFont! !

!CharacterBlockScanner methodsFor: 'stop conditions'!
cr
	"Answer a CharacterBlock that specifies the current location of the mouse 
	relative to a carriage return stop condition that has just been 
	encountered. The ParagraphEditor convention is to denote selections by 
	CharacterBlocks, sometimes including the carriage return (cursor is at 
	the end) and sometimes not (cursor is in the middle of the text)."

	((characterIndex ~= nil
		and: [characterIndex > text size])
			or: [(line last = text size)
				and: [(destY + textStyle lineGrid) < characterPoint y]])
		ifTrue:	["When off end of string, give data for next character"
				destY _ destY +  textStyle lineGrid.
				lastCharacter _ nil.
				characterPoint _ 
					Point
						x: ((text at: lastIndex) = CR
								ifTrue: [leftMargin]
								ifFalse: [nextLeftMargin])
						y: destY.
				lastIndex _ lastIndex + 1.
				lastCharacterExtent x: 0.
				^ true].
		lastCharacter _ CR.
		characterPoint _ destX @ destY.
		lastCharacterExtent x: rightMargin - destX.
		^true!
crossedX
	"Text display has wrapping. The scanner just found a character past the x 
	location of the cursor. We know that the cursor is pointing at a character 
	or before one."

	| leadingTab currentX |
	((characterPoint x <= (destX + ((lastCharacterExtent x) // 2)))
		or: [line last = lastIndex])
		ifTrue:	[lastCharacter _ (text at: lastIndex).
				characterPoint _ destX @ destY.
				^true].
	"Pointing past middle of a character, return the next character."
	lastIndex _ lastIndex + 1.
	lastCharacter _ text at: lastIndex.
	currentX _ destX + lastCharacterExtent x.
	lastCharacterExtent x: (font widthOf: lastCharacter).
	characterPoint _ currentX @ destY.

	"Yukky if next character is space or tab."
	(lastCharacter = Space and: [textStyle alignment = Justified])
		ifTrue:	[lastCharacterExtent x:
					(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:	[lastCharacterExtent x: (textStyle nextTabXFrom: currentX
							leftMargin: leftMargin rightMargin: rightMargin) -
								currentX]
				ifFalse:	[lastCharacterExtent x:  (((currentX + (textStyle tabWidth -
								(line justifiedTabDeltaFor: spaceCount))) -
									currentX) max: 0)]].
	^ true
!
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:	[characterPoint x: 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.
				lastCharacterExtent x: 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.
				lastCharacterExtent x: 0.
				^true].
	"just off end of line without crossing x"
	lastIndex _ lastIndex + 1.
	^true!
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.
	lastSpaceOrTabExtent x:  spaceWidth + pad.
	(destX + lastSpaceOrTabExtent x)  >= characterPoint x
		ifTrue: [lastCharacterExtent _ lastSpaceOrTabExtent copy.
				^self crossedX].
	lastIndex _ lastIndex + 1.
	destX _ destX + lastSpaceOrTabExtent x.
	^ false
!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	stopConditions at: (Space asciiValue + 1) put:
		(textStyle alignment = Justified ifTrue: [#paddedSpace] ifFalse: [nil])!
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.
	lastSpaceOrTabExtent x: (currentX - destX max: 0).
	currentX >= characterPoint x
		ifTrue: 
			[lastCharacterExtent _ lastSpaceOrTabExtent copy.
			^self crossedX].
	destX _ currentX.
	lastIndex _ lastIndex + 1.
	^false! !

!CharacterBlockScanner methodsFor: 'private'!
buildCharacterBlockIn: aText

	| lineIndex runLength lineStop done stopCondition |
	"handle nullText"
	(aText numberOfLines = 0 or: [text size = 0])
		ifTrue:	[^CharacterBlock
					stringIndex: 1	"like being off end of string"
					character: nil
					topLeft: ((aText leftMarginForDisplayForLine: 1) @
								(aText compositionRectangle) top)
					extent: (0 @ textStyle lineGrid)].

	"find the line"
	lineIndex _ aText lineIndexOfTop: characterPoint y.
	destY _ (aText topAtLineIndex: lineIndex).
	line _ aText lines at: lineIndex.
	rightMargin _ aText rightMarginForDisplay.

	(lineIndex = aText numberOfLines and:
		[(destY + textStyle lineGrid) < characterPoint y])
			ifTrue:	["if beyond lastLine, force search to last character"
					characterPoint x: rightMargin]
			ifFalse:	[characterPoint y < (aText compositionRectangle) top
						ifTrue: ["force search to first line"
								characterPoint _
								(aText compositionRectangle) topLeft].
					characterPoint x > rightMargin
						ifTrue:	[characterPoint x: rightMargin]].
	destX _ leftMargin _ aText leftMarginForDisplayForLine: lineIndex.
	nextLeftMargin_ aText leftMarginForDisplayForLine: lineIndex+1.
	lastIndex _ line first.

	self setStopConditions.		"also sets font"
	runLength _ (text runLengthFor: line first).
	characterIndex ~~ nil
		ifTrue:	[lineStop _ characterIndex	"scanning for index"]
		ifFalse:	[lineStop _ line last].
	(runStopIndex _ lastIndex + (runLength - 1)) > lineStop
		ifTrue:	[runStopIndex _ lineStop].
	lastCharacterExtent _ 0 @ textStyle lineGrid.
	spaceCount _ 0. done  _ false.

	[done]
	whileFalse:
	[stopCondition _ self scanCharactersFrom: lastIndex to: runStopIndex
			in: text string rightX: characterPoint x
			stopConditions: stopConditions displaying: false.

	"see setStopConditions for stopping conditions for character block 	operations."
	lastCharacterExtent x: (font widthOf: (text at: lastIndex)).
	(self perform: stopCondition)
		ifTrue:	[^CharacterBlock
					stringIndex: lastIndex
					character: lastCharacter
					topLeft: characterPoint
					extent: lastCharacterExtent]]! !BitBlt subclass: #CharacterScanner
	instanceVariableNames: 'lastIndex xTable stopConditions text textStyle leftMargin rightMargin font line runStopIndex spaceCount spaceWidth '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Support'!
CharacterScanner comment:
'My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.'!

!CharacterScanner methodsFor: 'scanning'!
characterNotInFont
	"All fonts have an illegal character to be used when a character is not 
	within the font's legal range. When characters out of ranged are 
	encountered in scanning text, then this special character indicates the 
	appropriate behavior. The character is usually treated as a unary 
	message understood by a subclass of CharacterScanner."

	| illegalAsciiString saveIndex stopCondition | 
	saveIndex _ lastIndex.
	illegalAsciiString _ String with: (font maxAscii + 1) asCharacter.
	stopCondition _ 
		self scanCharactersFrom: 1 to: 1
			in: illegalAsciiString
			rightX: rightMargin stopConditions: stopConditions
			displaying: self doesDisplaying.
	lastIndex _ saveIndex + 1.
	stopCondition ~= (stopConditions at: EndOfRun)
		ifTrue:	[^self perform: stopCondition]
		ifFalse: [lastIndex = runStopIndex
					ifTrue:	[^self perform: (stopConditions at: EndOfRun)].
				^false]
!
leadingTab
	"return true if only tabs lie to the left"
	line first to: lastIndex do:
		[:i | (text at: i) == Tab ifFalse: [^ false]].
	^ true!
scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops displaying: display 
	"Primitive. This is the inner loop of text display--but see 
	scanCharactersFrom: to:rightX: which would get the string, 
	stopConditions and displaying from the instance. March through source 
	String from startIndex to stopIndex. If any character is flagged with a 
	non-nil entry in stops, then return the corresponding value. Determine 
	width of each character from xTable. If dextX would exceed rightX, then 
	return stops at: 258. If displaying is true, then display the character. 
	Advance destX by the width of the character. If stopIndex has been 
	reached, then return stops at: 257. Fail under the same conditions that 
	the Smalltalk code below would cause an error. Optional. See Object 
	documentation whatIsAPrimitive."
	| ascii nextDestX |
	<primitive: 103>
	lastIndex _ startIndex.
	[lastIndex <= stopIndex]
		whileTrue: 
			[ascii _ (sourceString at: lastIndex) asciiValue.
			(stopConditions at: ascii + 1) == nil
				ifFalse: [^stops at: ascii + 1].
			sourceX _ xTable at: ascii + 1.
			nextDestX _ destX + (width _ (xTable at: ascii + 2) - sourceX).
			nextDestX > rightX ifTrue: [^stops at: CrossedX].
			display ifTrue: [self copyBits].
			destX _ nextDestX.
			lastIndex _ lastIndex + 1].
	lastIndex _ stopIndex.
	^stops at: EndOfRun! !

!CharacterScanner methodsFor: 'private'!
doesDisplaying

	^false!
initializeFromParagraph: aParagraph clippedBy: clippingRectangle

	text _ aParagraph text.
	textStyle _ aParagraph textStyle. 
	destForm _ aParagraph destinationForm.
	self fillColor: aParagraph fillColor.	"sets halftoneForm"
	self combinationRule: aParagraph rule.
	self clipRect: clippingRectangle.
	sourceY _ 0!
setFont 
	"Set the font and the stop conditions for the font."
	| newFont |
	newFont _ textStyle fontAt: (text emphasisAt: lastIndex).
	font == newFont ifTrue: [^ self].  "no need to reinitialize"
	font _ newFont.
	spaceWidth _ font widthOf: Space. 
	sourceForm _ font glyphs.
	xTable _ font xTable.
	height _ font height.
	stopConditions _ font stopConditions.
	stopConditions at: Space asciiValue + 1 put: #space.
	stopConditions at: Tab asciiValue + 1 put: #tab.
	stopConditions at: CR asciiValue + 1 put: #cr.
	stopConditions at: EndOfRun put: #endOfRun.
	stopConditions at: CrossedX put: #crossedX! !Object subclass: #CharRecog
	instanceVariableNames: 'mp p sts pts bmin bmax op cPat in dirs ftrs prevFeatures '
	classVariableNames: 'CharacterDictionary '
	poolDictionaries: 'TextConstants '
	category: 'System-Support'!
CharRecog comment:
'Alan Kay''s "one-page" character recognizer.  Currently hooked up to text panes, such that you can get it started by hitting cmd-r in any pane.  

To reinitialize the recognition dictionary, evaluate

	CharRecog reinitializeCharacterDictionary

 '!

!CharRecog methodsFor: 'recognizer'!
directionFrom: p1 to: p2 | ex |

"This does 8 directions and is not used in current recognizer"
"get the bounding box"		ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"				ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"			((ex y = 0) or: [(ex x/ex y) abs > 2]) ifTrue:
	"look for w-e"					[ex x > 0 ifTrue:[^' we-- ']
	"it's an e-w"						ifFalse:[^' ew-- ']].
"look for vertical line"		((ex x = 0) or: [(ex y/ex x) abs > 2]) ifTrue:
	"look for n-s"				[(ex y > 0) ifTrue:[ ^' ns||']
	"it's a s-n"						ifFalse:[^' sn|| ']].
"look for a diagonal"			(ex x/ex y) abs <= 2 ifTrue:
	"se or ne"					[ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// '].
	"sw or nw"									ex y > 0 ifTrue:[^' sw// ']. ^' nw// '].
!
extractFeatures | xl xr yl yh reg px py |
"get extent bounding box"	in _ bmax - bmin. 

"Look for degenerate forms first: . - |"
"look for a dot"				in < (3@3) ifTrue: [^' dot... '].

"Feature 5: turns (these are already in ftrs)"

"Feature 4: absolute size"	in < (10@10) ifTrue: [ftrs _  'SML ', ftrs] ifFalse:
							[in <=  (70@70) ifTrue: [ftrs _ 'REG ', ftrs] ifFalse:
							[in > (70@70) ifTrue: [ftrs _ 'LRG ', ftrs]]].

"Feature 3: aspect ratio"
	"horizontal shape"		((in y = 0) or: [(in x/in y) abs > 3]) ifTrue:
								[ftrs _ 'HOR ', ftrs] ifFalse:
	"vertical shape"			[((in x = 0) or: [(in y/in x) abs >= 3]) ifTrue:
								[ftrs _ 'VER ', ftrs] ifFalse:
	"boxy shape"			[((in x/in y) abs <= 3) ifTrue:
								[ftrs _ 'BOX ', ftrs.
"Now only for boxes"
"Feature 2: endstroke reg"	ftrs _ (self regionOf: (pts last)), ftrs.
							
"Feature 1: startstroke reg"	ftrs _ (self regionOf: (pts contents at: 1)), ftrs.]]].

^ftrs



!
fourDirsFrom:  p1 to: p2 | ex |

"get the bounding box"		ex _ p2 - p1. "unlike bmax-bmin, this can have negatives"

"Look for degenerate forms first: . - |"
"look for a dot"				ex abs < (3@3) ifTrue: [^' dot... '].
"look for hori line"			((ex y = 0) or: [(ex x/ex y) abs > 1]) ifTrue:
	"look for w-e"					[ex x > 0 ifTrue:[^'WE ']
	"it's an e-w"						ifFalse:[^'EW ']].
"look for vertical line"		((ex x = 0) or: [(ex y/ex x) abs >= 1]) ifTrue:
	"look for n-s"				[(ex y > 0) ifTrue:[ ^'NS ']
	"it's a s-n"						ifFalse:[^'SN ']].

"look for a diagonal			(ex x/ex y) abs <= 2 ifTrue:"
	"se or ne					[ex x > 0 ifTrue:[ex y > 0 ifTrue:[^' se// ']. ^' ne// ']."
	"sw or nw									ex y > 0 ifTrue:[^' sw// ']. ^' nw// ']."
!
learnPrev
	"The character recognized before this one was wrong.  (Got here via the gesture for 'wrong'.)  Bring up a dialog box on that char.  8/21/96 tk"

						| old result |
	old _ CharacterDictionary at: prevFeatures ifAbsent: [^ ''].
"get right char from user"	result _ FillInTheBlank request:
						('Redefine the gesture we thought was "', old asString, '".', '
(Letter or:  tab  cr  wrong  bs  select  caret)
', prevFeatures) initialAnswer: '' avoiding: (bmin rounded corner: bmax rounded).

"ignore or..."				(result = '~' | result = '') ifTrue: ['']
"...enter new char"			ifFalse: [
								CharacterDictionary at: prevFeatures 
									put: result].
					"caller erases bad char"
"good char"			^ result!
recognize | prv cdir result features char r s t dir |

"Alan Kay's recognizer as of 1/31/96.  This version preserved for historical purposes, and also because it's still called by the not-yet-deployed method recogPar.  Within the current image, the recognizer is now called via #recognizeAndDispatch:until:"


"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
					[(Sensor mousePoint x) < 50] whileFalse:

"First-Time"			[pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
						[
"ink raw input"			p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[ pts nextPut: t. 
"bounding box"			bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue: [
"store new dirs"					cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 			p place: t; go: 1; place: r.
							].
 "End Each-Time Loop"	].

"Last-Time"	

"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
"...or get from user"			[ result _ FillInTheBlank request:
							 'Not recognized. type char, or type ~: ', features.
"ignore or..."				result = '~' ifTrue: ['']
"...enter new char"			ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"		(char = 'cr' ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]). 

"End First-Time Loop"	]. 

"End Event-Loop" ]. 

			   
 !
recognizeAndDispatch: charDispatchBlock ifUnrecognized: unrecognizedFeaturesBlock until: terminationBlock
	"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true.  This method derives directly from Alan's 1/96 #recognize method, but factors out the character dispatch and the termination condition from the main body of the method.  2/2/96 sw.   2/5/96 sw: switch to using a class variable for the character dictionary, and don't put vacuous entries in the dictionary if the user gives an empty response to the prompt, and don't send empty characters onward, and use a variant of the FillInTheBlank that keeps the prompt clear of the working window.  8/17/96 tk: Turn cr, tab, bs into strings so they work.
	 9/18/96 sw: in this variant, the block for handling unrecognized features is handed in as an argument, so that in some circumstances we can avoid putting up a prompt.  unrecognizedFeaturesBlock should be a one-argument block, which is handed in the features and which is expected to return a string which indicates the determined translation -- empty if none."

	| prv cdir features char r s t dir |

"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
					[terminationBlock value] whileFalse:

"First-Time"			[pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
"ink raw input"			[p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[pts nextPut: t. 
"bounding box"				bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue:
"store new dirs"					[cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 				p place: t; go: 1; place: r]].
 "End Each-Time Loop"

"Last-Time"	
"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
							[unrecognizedFeaturesBlock value: features].

"special chars"		char size > 0 ifTrue:
						[char = 'tab' ifTrue: [char _ Tab].
						char = 'cr' ifTrue:	[char _ CR].
"must be a string"		char class == Character ifTrue: 
							[char _ String with: char].
						char = 'bs' ifTrue:	[char _ BS].
"control the editor"		charDispatchBlock value: char]]]
 !
recognizeAndDispatch: charDispatchBlock until: terminationBlock
	"Recognize characters, and dispatch each one found by evaluating charDispatchBlock; proceed until terminationBlock is true. 9/18/96 sw"

	^ self recognizeAndDispatch: charDispatchBlock
		ifUnrecognized: 
			[:features | self stringForUnrecognizedFeatures: features]
		until: terminationBlock
 !
recognizeAndPutInTranscript
	"Call Alan's recognizer repeatedly until the mouse is near the left edge of the screen, and dispatch keystrokes inferred to the Trancript.  2/2/96 sw"

	^ self recognizeAndDispatch:

		[:char | (char = 'cr') ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]]

		until:
			[Sensor mousePoint x < 50]

"CharRecog new recognizeAndPutInTranscript"!
recogPar | prv cdir result features char r s t dir |

"Inits"				(p _ Pen new) defaultNib: 1; down.
	"for points"		pts _ ReadWriteStream on: #().

"Event Loop"	
		[Sensor anyButtonPressed] whileFalse: [(Sensor mousePoint x < 50) ifTrue: [^''].].

"First-Time"			pts reset.		
"will hold features"		ftrs _ ''.

					  (Sensor anyButtonPressed) ifTrue:
						[pts nextPut: (bmin _ bmax _ t _ s _ sts _ Sensor mousePoint).
						p place: sts. cdir _ nil.

"Each-Time"		[Sensor anyButtonPressed] whileTrue:
						[
"ink raw input"			p goto: (r _ Sensor mousePoint).
"smooth it"				s _ (0.5*s) + (0.5*r).
"thin the stream"		((s x - t x) abs > 3 or:[(s y - t y) abs > 3]) ifTrue:
							[ pts nextPut: t. 
"bounding box"			bmin _ bmin min: s. bmax _ bmax max: s.
"get current dir"				dir _ (self fourDirsFrom: t to: s). t _ s.
							dir ~= ' dot... ' ifTrue: [
"store new dirs"					cdir ~= dir ifTrue: [ftrs _ ftrs, (cdir _ dir)]].
"for inked t's" 			p place: t; go: 1; place: r.
							].
 "End Each-Time Loop"	].

"Last-Time"	
"start a new recog for next point"	[CharRecog new recognize] fork.

"save last points"		pts nextPut: t; nextPut: r.
"find rest of features"	features _ self extractFeatures.
"find char..."			char _ CharacterDictionary at: features ifAbsent:
"...or get from user"			[ result _ FillInTheBlank request:
							 'Not recognized. type char, or type ~: ', features.
"ignore or..."				result = '~' ifTrue: ['']
"...enter new char"			ifFalse: [CharacterDictionary at: features put: result. result]].

"control the editor"		(char = 'cr' ifTrue: [Transcript cr] ifFalse:
						[char = 'bs' ifTrue: [Transcript bs] ifFalse:
						[char = 'tab' ifTrue:[Transcript tab] ifFalse:
						[Transcript show: char]]]). 

"End First-Time Loop"	]. 



			   
 !
regionOf: pt 

| px py reg xl yl yh xr rg |
"it's some other character"	rg _ in/3. 	xl _ bmin x + rg x. xr _ bmax x - rg x.
"divide box into 9 regions"				yl _ bmin y + rg y. yh _ bmax y - rg y.

					px _ pt x. py _ pt y.
					reg _ (px < xl ifTrue: [py < yl ifTrue: ['NW ']
										"py >= yl"	ifFalse:[ py < yh ifTrue:['W ']
																	ifFalse: ['SW ']]]
					ifFalse: [px < xr ifTrue: [py < yl ifTrue: ['N ']
													ifFalse: [py < yh ifTrue: ['C ']
																	ifFalse: ['S ']]]
					ifFalse: [py < yl ifTrue: ['NE ']
									ifFalse: [py < yh ifTrue: ['E ']
													ifFalse: ['SE ']]]]).
^reg.
					!
stringForUnrecognizedFeatures: features
	"Prompt the user for what string the current features represent, and return the result.  9/18/96 sw"

	| result |
	result _ FillInTheBlank request:
('Not recognized. type char, or "tab", "cr" or "bs",
or hit return to ignore 
', features) initialAnswer: '' avoiding: (bmin rounded corner: bmax rounded).

	^ (result = '~' | result = '')
		ifTrue:
			['']
		ifFalse:
			[CharacterDictionary at: features put: result. result]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CharRecog class
	instanceVariableNames: ''!

!CharRecog class methodsFor: 'initialization'!
initialize
	"Iniitialize the character dictionary if it doesn't exist yet.  2/5/96 sw"

	CharacterDictionary == nil ifTrue:
		[CharacterDictionary _ Dictionary new]!
reinitializeCharacterDictionary
	"Reset the character dictionary to be empty, ready for a fresh start.  2/5/96 sw"

	CharacterDictionary _ Dictionary new

"CharRecog reinitializeCharacterDictionary" ! !

!CharRecog class methodsFor: 'saving dictionary'!
readRecognizerDictionaryFrom: aFileName
	"Read a fresh version of the Recognizer dictionary in from a file of the given name.  7/26/96 sw"
	"CharRecog readRecognizerDictionaryFrom: 'RecogDictionary.2 fixed'"

   | aReferenceStream |
   aReferenceStream _ ReferenceStream fileNamed: aFileName.
   CharacterDictionary _ aReferenceStream next.
   aReferenceStream close.
!
saveRecognizerDictionaryTo: aFileName
	"Save the current state of the Recognizer dictionary to disk.  7/26/96 sw"

   | aReferenceStream |
aReferenceStream _ ReferenceStream fileNamed: aFileName.
   aReferenceStream nextPut: CharacterDictionary.
   aReferenceStream close! !

CharRecog initialize!
Arc subclass: #Circle
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
Circle comment:
'I represent a full circle. I am made from four Arcs.'!

!Circle methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	1 to: 4 do:
		[:i |
		super quadrant: i.
		super displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]! !

!Circle methodsFor: 'display box access'!
computeBoundingBox

	^center - radius + form offset extent: form extent + (radius * 2) asPoint! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Circle class
	instanceVariableNames: ''!

!Circle class methodsFor: 'examples'!
exampleOne 
	"Click any button somewhere on the screen. The point will be the center
	of the circcle of radius 150."

	| aCircle aForm |
	aForm _ Form extent: 1@30.
	aForm fillBlack.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display
	
	"Circle exampleOne"!
exampleTwo
	"Designate a rectangular area that should be used as the brush for
	displaying the circle. Click any button at a point on the screen which
	will be the center location for the circle. The curve will be displayed
	with a long black form."

	| aCircle aForm |
	aForm _ Form fromUser.
	aCircle _ Circle new.
	aCircle form: aForm.
	aCircle radius: 150.
	aCircle center: Sensor waitButton.
	aCircle displayOn: Display at: 0 @ 0 rule: Form reverse
 
	 "Circle exampleTwo"! !ClassDescription subclass: #Class
	instanceVariableNames: 'name classPool sharedPools '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
Class comment:
'My instances describe the representation and behavior of objects. I add more comprehensive programming support facilities to the basic attributes of Behavior and the descriptive facilities of ClassDescription. An example is accessing shared (pool) variables.'!

!Class methodsFor: 'initialize-release'!
declare: varString 
	"Declare class variables common to all instances. Answer whether 
	recompilation is advisable."

	| newVars conflicts assoc class |
	newVars _ 
		(Scanner new scanFieldNames: varString)
			collect: [:x | x asSymbol].
	newVars do:
		[:var | var first isLowercase
			ifTrue: [self error: var, ' class variable name should be capitalized; proceed to include anyway.']].
	conflicts _ false.
	classPool == nil 
		ifFalse: [(classPool keys reject: [:x | newVars includes: x]) do: 
					[:var | self removeClassVarName: var]].
	(newVars reject: [:var | self classPool includesKey: var])
		do: [:var | "adding"
			"check if new vars defined elsewhere"
			(self scopeHas: var ifTrue: [:ignored | ignored])
				ifTrue: 
					[self error: var , ' is defined elsewhere'.
					conflicts _ true]].
	newVars size > 0
		ifTrue: 
			[classPool _ self classPool.
			"in case it was nil"
			newVars do: [:var | classPool declare: var from: Undeclared]].
	^conflicts!
obsolete
	"Change the receiver to an obsolete class by changing its name to have
	the prefix -AnObsolete-."

	name _ 'AnObsolete' , name.
	classPool _ Dictionary new.
	self class obsolete.
	super obsolete!
removeFromSystem
	"Forget the receiver from the Smalltalk global dictionary. Any existing 
	instances will refer to an obsolete version of the receiver."

	Smalltalk removeClassFromSystem: self.
	self obsolete!
sharing: poolString 
	"Set up sharedPools. Answer whether recompilation is advisable."
	| oldPools poolName pool found |
	oldPools _ self sharedPools.
	sharedPools _ OrderedCollection new.
	(Scanner new scanFieldNames: poolString) do: 
		[:poolName | 
		sharedPools add: (Smalltalk at: poolName asSymbol)].
	sharedPools isEmpty ifTrue: [sharedPools _ nil].
	oldPools do: [:pool | found _ false.
				self sharedPools do: [:p | p == pool ifTrue: [found _ true]].
				found ifFalse: [^ true "A pool got deleted"]].
	^ false!
superclass: sup methodDict: md format: ft name: nm organization: org instVarNames: nilOrArray classPool: pool sharedPools: poolSet 
	"Answer an instance of me, a new class, using the arguments of the 
	message as the needed information."

	superclass _ sup.
	methodDict _ md.
	format _ ft.
	name _ nm.
	organization _ org.
	instanceVariables _ nilOrArray.
	classPool _ pool.
	sharedPools _ poolSet!
validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods 
	"Recompile the receiver and redefine its subclasses if necessary."

	super
		validateFrom: oldClass
		in: environ
		instanceVariableNames: invalidFields
		methods: invalidMethods.
	self ~~ oldClass
		ifTrue: 
			[environ at: name put: self.
			oldClass obsolete]! !

!Class methodsFor: 'accessing'!
classPool
	"Answer the dictionary of class variables."

	classPool == nil
		ifTrue: [^Dictionary new]
		ifFalse: [^classPool]!
name
	"Answer the name of the receiver."

	name == nil
		ifTrue: [^super name]
		ifFalse: [^name]! !

!Class methodsFor: 'testing'!
hasMethods
	"Answer a Boolean according to whether any methods are defined for the 
	receiver (includes whether there are methods defined in the receiver's 
	metaclass)."

	^super hasMethods or: [self class hasMethods]! !

!Class methodsFor: 'copying'!
copy
	| newClass |
	newClass _ self class copy new
		superclass: superclass
		methodDict: methodDict copy
		format: format
		name: name
		organization: organization copy
		instVarNames: instanceVariables copy
		classPool: classPool copy
		sharedPools: sharedPools.
	Class instSize+1 to: self class instSize do:
		[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
	^ newClass!
copyForValidation
	"Make a copy of the receiver (a class) but do not install the created class 
	as a new class in the system. This is used for creating a new version of 
	the receiver in which the installation is deferred until all changes are 
	successfully completed."
	| newClass |
	newClass _ self class copy new
		superclass: superclass
		methodDict: methodDict copy
		format: format
		name: name
		organization: organization
		instVarNames: instanceVariables copy
		classPool: classPool
		sharedPools: sharedPools.
	Class instSize+1 to: self class instSize do:
		[:offset | newClass instVarAt: offset put: (self instVarAt: offset)].
	^ newClass! !

!Class methodsFor: 'class name'!
rename: aString 
	"The new name of the receiver is the argument, aString."

	| newName |
	newName _ aString asSymbol.
	(Smalltalk includesKey: newName)
		ifTrue: [^self error: newName , ' already exists'].
	(Undeclared includesKey: newName)
		ifTrue: [^ PopUpMenu notify: 'There are references to, ' , aString printString , '
from Undeclared. Check them after this change.'].
	Smalltalk renameClass: self as: newName.
	name _ newName.
	self comment: self comment.
	self class comment: self class comment! !

!Class methodsFor: 'instance variables'!
addInstVarName: aString
	"Add the argument, aString, as one of the receiver's instance variables."

	superclass class
		name: self name
		inEnvironment: Smalltalk
		subclassOf: superclass
		instanceVariableNames: self instanceVariablesString , aString
		variable: self isVariable
		words: self isWords
		pointers: self isPointers
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
		comment: nil
		changed: false!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance variables."

	| newInstVarString |
	(self instVarNames includes: aString)
		ifFalse: [self error: aString , ' is not one of my instance variables'].
	newInstVarString _ ''.
	(self instVarNames copyWithout: aString) do: 
		[:varName | newInstVarString _ newInstVarString , ' ' , varName].
	superclass class
		name: self name
		inEnvironment: Smalltalk
		subclassOf: superclass
		instanceVariableNames: newInstVarString
		variable: self isVariable
		words: self isWords
		pointers: self isPointers
		classVariableNames: self classVariablesString
		poolDictionaries: self sharedPoolsString
		category: self category
		comment: nil
		changed: false! !

!Class methodsFor: 'class variables'!
addClassVarName: aString 
	"Add the argument, aString, as a class variable of the receiver.
	Signal an error if the first character of aString is not capitalized,
	or if it is already a variable named in the class."
	| symbol index |
	aString first isLowercase
		ifTrue: [^self error: aString, ' class variable name should be capitalized; proceed to include anyway.'].
	symbol _ aString asSymbol.
	self withAllSubclasses do: 
		[:subclass | 
		subclass scopeHas: symbol
			ifTrue: [:temp | 
					^ self error: aString 
						, ' is already used as a variable name in class ' 
						, subclass name]].
	classPool == nil ifTrue: [classPool _ Dictionary new].
	(classPool includesKey: symbol) ifFalse: 
		["Pick up any refs in Undeclared"
		classPool declare: symbol from: Undeclared.
		Smalltalk changes changeClass: self]!
allClassVarNames
	"Answer a Set of the names of the receiver's class variables, including those
	defined in the superclasses of the receiver."

	| aSet |
	superclass == nil
		ifTrue: 
			[^self classVarNames]  "This is the keys so it is a new Set."
		ifFalse: 
			[aSet _ superclass allClassVarNames.
			aSet addAll: self classVarNames.
			^aSet]!
classVarNames
	"Answer a Set of the names of the class variables defined in the receiver."

	^self classPool keys!
initialize
	"Typically used for the initialization of class variables and metaclass 
	instance variables. Does nothing, but may be overridden in Metaclasses."

	^self!
removeClassVarName: aString 
	"Remove the class variable whose name is the argument, aString, from 
	the names defined in the receiver, a class. Create an error notification if 
	aString is not a class variable or if it is still being used in the code of 
	the class."

	| anAssoc aSymbol |
	aSymbol _ aString asSymbol.
	(classPool includesKey: aSymbol)
		ifFalse: [^self error: aString, ' is not a class variable'].
	anAssoc _ classPool associationAt: aSymbol.
	self withAllSubclasses do:
		[:subclass |
		(Array with: subclass with: subclass class) do:
			[:classOrMeta |
			(classOrMeta whichSelectorsReferTo: (classPool associationAt: aSymbol))
				isEmpty
					ifFalse: [^self error: aString
								, ' is still used in code of class '
								, classOrMeta name]]].
	classPool removeKey: aSymbol! !

!Class methodsFor: 'pool variables'!
addSharedPool: aDictionary 
	"Add the argument, aDictionary, as one of the receiver's pool dictionaries. 
	Create an error if the dictionary is already one of the pools."

	(self sharedPools includes: aDictionary)
		ifTrue: [^self error: 'The dictionary is already in my pool'].
	sharedPools == nil
		ifTrue: [sharedPools _ OrderedCollection with: aDictionary]
		ifFalse: [sharedPools add: aDictionary]!
allSharedPools
	"Answer a Set of the pools the receiver shares, including those defined 
	in the superclasses of the receiver."

	| aSet |
	superclass == nil
		ifTrue:
			[^self sharedPools copy]
		ifFalse: 
			[aSet _ superclass allSharedPools.
			aSet addAll: self sharedPools.
			^aSet]!
removeSharedPool: aDictionary 
	"Remove the pool dictionary, aDictionary, as one of the receiver's pool 
	dictionaries. Create an error notification if the dictionary is not one of 
	the pools.
	9/12/96 tk: Note that it removes the wrong one if there are two empty Dictionaries in the list."

	| satisfiedSet workingSet aSubclass|
	(self sharedPools includes: aDictionary)
		ifFalse: [^self error: 'the dictionary is not in my pool'].

	"first see if it is declared in a superclass in which case we can remove it."
	(self selectSuperclasses: [:class | class sharedPools includes: aDictionary]) isEmpty
		ifFalse: [sharedPools remove: aDictionary.
				sharedPools isEmpty ifTrue: [sharedPools _ nil].
				^self]. 

	"second get all the subclasses that reference aDictionary through me rather than a 
	superclass that is one of my subclasses."

	workingSet _ self subclasses asOrderedCollection.
	satisfiedSet _ Set new.
	[workingSet isEmpty] whileFalse:
		[aSubclass _ workingSet removeFirst.
		(aSubclass sharedPools includes: aDictionary)
			ifFalse: 
				[satisfiedSet add: aSubclass.
				workingSet addAll: aSubclass subclasses]].

	"for each of these, see if they refer to any of the variables in aDictionary because 
	if they do, we can not remove the dictionary."
	satisfiedSet add: self.
	satisfiedSet do: 
		[:aSubclass | 
		aDictionary associationsDo: 
			[:aGlobal | 
			(aSubclass whichSelectorsReferTo: aGlobal) isEmpty 
				ifFalse: [^self error: aGlobal key 
								, ' is still used in code of class '
								, aSubclass name]]].
	sharedPools remove: aDictionary.
	sharedPools isEmpty ifTrue: [sharedPools _ nil]!
sharedPools
	"Answer a Set of the pool dictionaries declared in the receiver."

	sharedPools == nil
		ifTrue: [^OrderedCollection new]
		ifFalse: [^sharedPools]! !

!Class methodsFor: 'compiling'!
compileAllFrom: oldClass
	"Recompile all the methods in the receiver's method dictionary (not the
	subclasses). Also recompile the methods in the metaclass."

	super compileAllFrom: oldClass.
	self class compileAllFrom: oldClass class!
possibleVariablesFor: misspelled continuedFrom: oldResults

	| results |
	results _ misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults.
	self sharedPools do: [:pool | 
		results _ misspelled correctAgainstDictionary: pool continuedFrom: results ].
	superclass == nil
		ifTrue: 
			[ ^ misspelled correctAgainstDictionary: Smalltalk continuedFrom: results ]
		ifFalse:
			[ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]!
scopeHas: varName ifTrue: assocBlock 
	"Look up the first argument, varName, in the context of the receiver. If it is there,
	pass the association to the second argument, assocBlock, and answer true.
	Else answer false.
	9/11/96 tk: Allow key in shared pools to be a string for HyperSqueak"

	| assoc pool |
	assoc _ self classPool associationAt: varName ifAbsent: [].
	assoc == nil
		ifFalse: 
			[assocBlock value: assoc.
			^true].
	self sharedPools do: 
		[:pool | 
		varName = #Textual ifTrue: [self halt].
		assoc _ pool associationAt: varName ifAbsent: [
			pool associationAt: varName asString ifAbsent: []].
		assoc == nil
			ifFalse: 
				[assocBlock value: assoc.
				^true]].
	superclass == nil
		ifTrue: 
			[assoc _ Smalltalk associationAt: varName ifAbsent: [].
			assoc == nil
				ifFalse: 
					[assocBlock value: assoc.
					^true].
			^false].
	^superclass scopeHas: varName ifTrue: assocBlock! !

!Class methodsFor: 'subclass creation'!
subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat 
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver)."

	self isVariable
		ifTrue: 
			[self isPointers 
				ifTrue: [^self
							variableSubclass: t
							instanceVariableNames: f
							classVariableNames: d
							poolDictionaries: s
							category: cat].
			self isBytes 
				ifTrue: [^self
							variableByteSubclass: t
							instanceVariableNames: f
							classVariableNames: d
							poolDictionaries: s
							category: cat].
			^self
				variableWordSubclass: t
				instanceVariableNames: f
				classVariableNames: d
				poolDictionaries: s
				category: cat].
	^self class
		name: t
		inEnvironment: Smalltalk
		subclassOf: self
		instanceVariableNames: f
		variable: false
		words: true
		pointers: true
		classVariableNames: d
		poolDictionaries: s
		category: cat
		comment: nil
		changed: false!
variableByteSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable byte-sized nonpointer variables."

	self instSize > 0 
		ifTrue: [^self error: 'cannot make a byte subclass of a class with named fields'].
	(self isVariable and: [self isWords])
		ifTrue: [^self error: 'cannot make a byte subclass of a class with word fields'].
	(self isVariable and: [self isPointers])
		ifTrue: [^self error: 
					'cannot make a byte subclass of a class with pointer fields'].
	^self class name: t 
		inEnvironment: Smalltalk
		subclassOf: self 
		instanceVariableNames: f
		variable: true 
		words: false 
		pointers: false
		classVariableNames: d 
		poolDictionaries: s 
		category: cat 
		comment: nil
		changed: false!
variableSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable pointer variables."

	self isBits 
		ifTrue: 
			[^self error: 
				'cannot make a pointer subclass of a class with non-pointer fields'].
	^self class name: t 
		inEnvironment: Smalltalk
		subclassOf: self 
		instanceVariableNames: f
		variable: true 
		words: true 
		pointers: true
		classVariableNames: d 
		poolDictionaries: s 
		category: cat 
		comment: nil
		changed: false!
variableWordSubclass: t instanceVariableNames: f 
	classVariableNames: d poolDictionaries: s category: cat
	"This is the standard initialization message for creating a new class as a 
	subclass of an existing class (the receiver) in which the subclass is to 
	have indexable word-sized nonpointer variables."

	self instSize > 0 
		ifTrue: [^self error: 
					'cannot make a word subclass of a class with named fields'].
	self isBytes
		ifTrue: [^self error: 'cannot make a word subclass of a class with byte fields'].
	(self isVariable and: [self isPointers])
		ifTrue: [^self error: 
					'cannot make a word subclass of a class with pointer fields'].
	^self class name: t 
		inEnvironment: Smalltalk
		subclassOf: self 
		instanceVariableNames: f
		variable: true 
		words: true 
		pointers: false
		classVariableNames: d 
		poolDictionaries: s 
		category: cat 
		comment: nil
		changed: false! !

!Class methodsFor: 'fileIn/Out'!
fileOut
	"Create a file whose name is the name of the receiver with '.st' as the 
	extension, and file a description of the receiver onto it."
	| fileStream |
	fileStream _ FileStream newFileNamed: self name , '.st'.
	fileStream header; timeStamp.
	self sharedPools size > 0 ifTrue:
		[self shouldFileOutPools
			ifTrue: [self fileOutSharedPoolsOn: fileStream]].
	self fileOutOn: fileStream
		moveSource: false
		toFile: 0.
	fileStream trailer; close!
fileOutMethod: selector
	"Write source code of a single method on a file.  Make up a name for the file."
	| fileStream |
	(self includesSelector: selector) ifFalse: [^ self].
	fileStream _ FileStream newFileNamed: 
		(self name , '-' , (selector copyReplaceAll: ':' with: '')) , '.st'.
	fileStream header; timeStamp.
	self printCategoryChunk: (self whichCategoryIncludesSelector: selector)
		on: fileStream.
	self printMethodChunk: selector
		on: fileStream
		moveSource: false
		toFile: 0.
	fileStream nextChunkPut: ' '; trailer; close!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver on aFileStream. If the boolean argument,
	moveSource, is true, then set the trailing bytes to the position of aFileStream and
	to fileIndex in order to indicate where to find the source code."

	Transcript cr; show: name.
	super
		fileOutOn: aFileStream
		moveSource: moveSource
		toFile: fileIndex.
	self class nonTrivial
		ifTrue:
			[aFileStream cr; nextPutAll: '"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!!'; cr; cr.
			self class
				fileOutOn: aFileStream
				moveSource: moveSource
				toFile: fileIndex]!
fileOutPool: aPool onFileStream: aFileStream 
	| aPoolName |
	aPoolName _ Smalltalk keyAtValue: aPool.
	Transcript cr; show: aPoolName.
	aFileStream nextPutAll: 'Transcript show: ''' , aPoolName , '''; cr!!'; cr.
	aFileStream nextPutAll: 'Smalltalk at: #' , aPoolName , ' put: Dictionary new!!'; cr.
	aPool asSortedCollection do: [ :anItem | 
		aFileStream nextPutAll: aPoolName , ' at: #' , anItem key asString , ' put:  '.
		(anItem value isKindOf: Number)
			ifTrue: [anItem value printOn: aFileStream]
			ifFalse: [aFileStream nextPutAll: '('.
					anItem value printOn: aFileStream.
					aFileStream nextPutAll: ')'].
		aFileStream nextPutAll: '!!'; cr].
	aFileStream cr!
fileOutSharedPoolsOn: aFileStream
	"file out the shared pools of this class after prompting the user about each pool"
	| poolsToFileOut |
	poolsToFileOut _ self sharedPools select: 
		[:aPool | (self shouldFileOutPool: (Smalltalk keyAtValue: aPool))].
	poolsToFileOut do: [:aPool | self fileOutPool: aPool onFileStream: aFileStream].
	!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	super reformatAll.		"me..."
	self class reformatAll	"...and my metaclass"!
removeFromChanges
	"References to the receiver, a class, and its metaclass should no longer be included in the system ChangeSet.
	7/18/96 sw: call removeClassAndMetaClassChanges:"

	Smalltalk changes removeClassAndMetaClassChanges: self!
shouldFileOutPool: aPoolName
	"respond with true if the user wants to file out aPoolName"
	^self confirm: ('FileOut the sharedPool ', aPoolName, '?')!
shouldFileOutPools
	"respond with true if the user wants to file out the shared pools"
	^self confirm: 'FileOut selected sharedPools?'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Class class
	instanceVariableNames: ''!

!Class class methodsFor: 'instance creation'!
template: category 
	"Answer an expression that can be edited and evaluated in order to 
	define a new class."

	^'Object subclass: #NameOfClass
	instanceVariableNames: ''instVarName1 instVarName2''
	classVariableNames: ''ClassVarName1 ClassVarName2''
	poolDictionaries: ''''
	category: ''' , category , ''''! !

!Class class methodsFor: 'fileIn/Out'!
fileOutPool: aString
	"file out the global pool named aString"
	| f |
	f _ FileStream newFileNamed: aString, '.st'.
	self new fileOutPool: (Smalltalk at: aString asSymbol) onFileStream: f. 	f close.
	! !Object subclass: #ClassCategoryReader
	instanceVariableNames: 'class category '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Support'!
ClassCategoryReader comment:
'I represent a mechanism for retrieving class descriptions stored on a file.'!

!ClassCategoryReader methodsFor: 'fileIn/Out'!
scanFrom: aStream 
	"File in methods from the stream, aStream. Print the name and category of 
	the methods in the transcript view."

	| string |
	[string _ aStream nextChunk.
	string size > 0]						"done when double terminators"
		whileTrue: [class compile: string classified: category].
	Transcript show: class name , '<' , category , '
'! !

!ClassCategoryReader methodsFor: 'private'!
setClass: aClass category: aCategory

	class _ aClass.
	category _ aCategory! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ClassCategoryReader class
	instanceVariableNames: ''!

!ClassCategoryReader class methodsFor: 'instance creation'!
class: aClass category: aCategory 
	"Answer an instance of me for the category, aCategory, of the class, 
	aClass."

	^self new setClass: aClass category: aCategory! !ClassCategoryReader subclass: #ClassCompiledCategoryReader
	instanceVariableNames: ''
	classVariableNames: 'NewMethods '
	poolDictionaries: ''
	category: 'Kernel-Support'!
ClassCompiledCategoryReader comment:
'A ClassCompiledCategoryReader reads a series of compiled methods stored in the following format and terminated by an extra $!!.
	<header word>!!<byte codes in hex>!!
	<literal storeStrings each terminated by a space>
	!!<method selector>!!<source code>!!
See Behavior<storeLiteral:on: to explain ##<global name> and ###<ÿclass name>.

When the file name ends with .f.st, this format is produced by the method ClassDescriptio<printMethodChunk:on:moveSource:toFile:.  Also see ClassDescription<printCategoryChunk:on:.

CompiledMethods are not installed when read.  Instead, they are added to a collection NewMethods (a class variable) whose elements are arrays of the form
{class. category. selector. compiledMethod}.  Later in the file (after all classes and methods have been defined, but before calls on initialize methods have been made), there should be a call on:
			ClassCompiledCategoryReader installNewMethods.
This call is produced by the methods ChangeSet<fileOutOn: and ReadWriteStream<fileOutChangesFor: when the file name ends with .f.st'!

!ClassCompiledCategoryReader methodsFor: 'fileIn/Out'!
scanFrom: aStream 
	"File in compiled methods from the stream, aStream. Much faster than
	 superclass method.  To save even more time, do not print the name and
	 category of the methods in the transcript view."
	| file string header byteCodes method mStrm scanner selector remoteString |
	file _ SourceFiles at: 2.
	file isNil ifFalse:
		[file setToEnd. class printCategoryChunk: category on: file. file cr].
	[string _ aStream nextChunk.
	 string size > 0]						"done when double terminators"
		whileTrue:
			[header _ string asNumber.
			byteCodes _ ByteArray fromHex: aStream nextChunk.
			method _ CompiledMethod
						newMethod: byteCodes size+3
						header: header.
			mStrm _ ReadWriteStream with: method.
			mStrm position: method initialPC - 1.
			mStrm nextPutAll: byteCodes.
			scanner _ Scanner new scan: (ReadStream on: aStream nextChunk).
			1 to: method numLiterals do:
				[:i |
				 method literalAt: i put:
					(class literalScannedAs: scanner nextLiteral notifying: nil)].
			selector _ aStream nextChunk asSymbol.
			file isNil ifFalse:
				[remoteString _ RemoteString new
					fromFile: aStream
					onFileNumber: 2
					toFile: file.
				 method setSourcePosition: remoteString position inFile: 2].
			NewMethods add:
				(Array with: class with: category with: selector with: method)].
	file isNil ifFalse: [file nextChunkPut: ' '; flush]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ClassCompiledCategoryReader class
	instanceVariableNames: ''!

!ClassCompiledCategoryReader class methodsFor: 'class initialization'!
initialize

	NewMethods _ OrderedCollection new: 100

"ClassCompiledCategoryReader initialize"! !

!ClassCompiledCategoryReader class methodsFor: 'fileIn/Out'!
installNewMethods

	| clsCatSelMth class category selector method |
	NewMethods do: 
		[:clsCatSelMth |
		class _ clsCatSelMth at: 1.
		category _ clsCatSelMth at: 2.
		selector _ clsCatSelMth at: 3.
		method _ clsCatSelMth at: 4.
		(methodDict includesKey: selector)
			ifTrue: [Smalltalk changes changeSelector: selector class: class]
			ifFalse: [Smalltalk changes addSelector: selector class: class].
		class organization classify: selector under: category.
		class addSelector: selector withMethod: method].
	self initialize! !

ClassCompiledCategoryReader initialize!
Behavior subclass: #ClassDescription
	instanceVariableNames: 'instanceVariables organization '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Classes'!
ClassDescription comment:
'I add a number of facilities to basic Behavior:
	Named instance variables
	Category organization for methods
	The notion of a name of this class (implemented as subclass responsibility)
	The maintenance of a ChangeSet, and logging changes on a file
	Most of the mechanism for fileOut.
	
I am an abstract class, in particular, my facilities are intended for inheritance by two subclasses, Class and Metaclass.'!

!ClassDescription methodsFor: 'initialize-release'!
obsolete
	"Make the receiver obsolete."

	organization _ nil.
	super obsolete!
subclassOf: newSuper oldClass: oldClass instanceVariableNames: newInstVarString variable: v words: w pointers: p ifBad: badBlock 
	"Basic initialization message for creating classes using the information 
	provided as arguments. Answer whether old instances will be 
	invalidated."

	| oldNames newNames usedNames invalid oldSuperMeta newInstVarArray oldSpec |
	oldNames _ self allInstVarNames.
	usedNames _ #(self super thisContext true false nil ) asSet.
	newInstVarArray _ Scanner new scanFieldNames: newInstVarString.
	newNames _ newSuper allInstVarNames , newInstVarArray.
	newNames size > 62
		ifTrue: [self error: 'A class cannot have more than 62 instance variables'.
				^ badBlock value].
	newNames do: 
		[:fieldName | 
		(usedNames includes: fieldName)
			ifTrue: 
				[self error: fieldName , ' is reserved (maybe in a superclass)'.
				^ badBlock value].
		usedNames add: fieldName].
	(invalid _ superclass ~~ newSuper)
		ifTrue: 
			["superclass changed"
			oldSuperMeta _ superclass class.
			superclass removeSubclass: self.
			superclass _ newSuper.
			superclass addSubclass: self.
			self class superclass == oldSuperMeta 
				ifTrue: ["Only false when self is a metaclass"
						self class superclass: newSuper class]].
	instanceVariables _ newInstVarArray size = 0 ifFalse: [newInstVarArray].
	invalid _ invalid |   "field names changed"
			(newNames size < oldNames size or:
				[(newNames copyFrom: 1 to: oldNames size) ~= oldNames]).
	oldSpec _ self instSpec.
	self
		format: newNames size
		variable: v
		words: w
		pointers: p.
	invalid _ invalid | (self instSpec ~= oldSpec).  "format changed"
	^invalid!
updateInstancesFrom: oldClass 
	"Recreate any existing instances of the argument, oldClass, as instances of 
	the receiver, which is a newly changed class. Permute variables as 
	necessary."

	| oldInstVarNames map variable old new instSize offset fieldName oldInstances |
	oldClass someInstance == nil ifTrue: [^self].
	"no instances to convert"
	oldInstVarNames _ oldClass allInstVarNames.
	map _ 
		self allInstVarNames 
			collect: [:instVarName | oldInstVarNames indexOf: instVarName].
	variable _ self isVariable.
	instSize _ self instSize.

	"Now perform a bulk mutation of old instances into new ones"
	oldInstances _ oldClass allInstances asArray.
	oldInstances elementsExchangeIdentityWith:
		(oldInstances collect: 
		[:old | 
		variable
			ifTrue: [new _ self basicNew: old basicSize]
			ifFalse: [new _ self basicNew].
		1 to: instSize do: 
			[:offset |  (map at: offset) > 0 ifTrue:
				[new instVarAt: offset
						put: (old instVarAt: (map at: offset))]].
		variable 
			ifTrue: [1 to: old basicSize do: 
						[:offset |
						new basicAt: offset put: (old basicAt: offset)]].
		new])!
validateFrom: oldClass in: environ instanceVariableNames: invalidFields methods: invalidMethods 
	"Recompile the receiver, a class, and redefine its subclasses if necessary.
	The parameter invalidFields is no longer really used"

	| sub newSub invalidSubMethods |
	oldClass becomeUncompact.  "Its about to be abandoned"
	invalidMethods & self hasMethods
		ifTrue: 
			[Transcript show: 'recompiling ' , self name , '...'.
			self compileAllFrom: oldClass.
			Transcript show: ' done'; cr].
	invalidSubMethods _ invalidMethods | (self instSize ~= oldClass instSize).
	self == oldClass
		ifTrue: [invalidSubMethods ifFalse: [^self]]
		ifFalse: [self updateInstancesFrom: oldClass].
	oldClass subclasses do: 
		[:sub | 
		newSub _ sub copyForValidation.
		newSub
			subclassOf: self
			oldClass: sub
			instanceVariableNames: sub instVarNames
			variable: sub isVariable
			words: sub isBytes not
			pointers: sub isBits not
			ifBad: [self error: 'terrible problem in recompiling subclasses!!'].
		newSub
			validateFrom: sub
			in: environ
			instanceVariableNames: invalidFields
			methods: invalidSubMethods]! !

!ClassDescription methodsFor: 'accessing'!
classVersion
	"Default.  Any class may return a later version to inform readers that use ReferenceStream.  8/17/96 tk"
	^ 0!
comment
	"Answer the receiver's comment."

	| aString |
	aString _ self organization classComment.
	aString size = 0 ifTrue: [^''].
	"get string only of classComment, undoubling quotes"
	^ String readFromString: aString!
comment: aString 
	"Set the receiver's comment to be the argument, aString."

	| aStream |
	aString size = 0
		ifTrue: 
			[self organization classComment: aString]
		ifFalse: 
			["double internal quotes of the comment string"
			aStream _ WriteStream on: (String new: aString size).
			aStream nextPutAll: self name , ' comment:'; cr.
			aString storeOn: aStream.
			self organization classComment: aStream contents.
	Smalltalk changes commentClass: self]!
commentTemplate
	"Answer an expression to edit and evaluate in order to produce the 
	receiver's comment."

	| aString |
	aString _ self organization classComment.
	aString size = 0
		ifTrue: [ ^ self name , ' comment:
''This class has not yet been commented''']
		ifFalse: [ ^ aString]!
isMeta
	^ false!
name
	"Answer a String that is the name of the receiver."

	self subclassResponsibility!
theNonMetaClass
	"Sent to a class or metaclass, always return the class"

	^self! !

!ClassDescription methodsFor: 'copying'!
copy: sel from: class 
	"Install the method associated with the first argument, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under -As yet not 
	classified-."

	self copy: sel
		from: class
		classified: nil!
copy: sel from: class classified: cat 
	"Install the method associated with the first arugment, sel, a message 
	selector, found in the method dictionary of the second argument, class, 
	as one of the receiver's methods. Classify the message under the third 
	argument, cat."

	| code category |
	"Useful when modifying an existing class"
	code _ class sourceMethodAt: sel.
	code == nil
		ifFalse: 
			[cat == nil
				ifTrue: [category _ class organization categoryOfElement: sel]
				ifFalse: [category _ cat].
			(methodDict includesKey: sel)
				ifTrue: [code asString = (self sourceMethodAt: sel) asString 
							ifFalse: [self error: self name 
										, ' ' 
										, sel 
										, ' will be redefined if you proceed.']].
			self compile: code classified: category]!
copyAll: selArray from: class 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	-As yet not classified-."

	self copyAll: selArray
		from: class
		classified: nil!
copyAll: selArray from: class classified: cat 
	"Install all the methods found in the method dictionary of the second 
	argument, class, as the receiver's methods. Classify the messages under 
	the third argument, cat."

	selArray do: 
		[:s | self copy: s
				from: class
				classified: cat]!
copyAllCategoriesFrom: aClass 
	"Specify that the categories of messages for the receiver include all of 
	those found in the class, aClass. Install each of the messages found in 
	these categories into the method dictionary of the receiver, classified 
	under the appropriate categories."

	aClass organization categories do: [:cat | self copyCategory: cat from: aClass]!
copyCategory: cat from: class 
	"Specify that one of the categories of messages for the receiver is cat, as 
	found in the class, class. Copy each message found in this category."

	self copyCategory: cat
		from: class
		classified: cat!
copyCategory: cat from: aClass classified: newCat 
	"Specify that one of the categories of messages for the receiver is the 
	third argument, newCat. Copy each message found in the category cat in 
	class aClass into this new category."

	self copyAll: (aClass organization listAtCategoryNamed: cat)
		from: aClass
		classified: newCat! !

!ClassDescription methodsFor: 'printing'!
classVariablesString
	"Answer a string of my class variable names separated by spaces."

	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self classPool keysDo: [:key | aStream nextPutAll: key; space].
	^aStream contents!
instanceVariablesString
	"Answer a string of my instance variable names separated by spaces."

	| aStream names |
	aStream _ WriteStream on: (String new: 100).
	names _ self instVarNames.
	1 to: names size do: [:i | aStream nextPutAll: (names at: i); space].
	^aStream contents!
printOn: aStream 

	aStream nextPutAll: self name!
sharedPoolsString
	"Answer a string of my shared pool names separated by spaces."

	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self sharedPools do: [:x | aStream nextPutAll: (Smalltalk keyAtValue: x); space].
	^aStream contents!
storeOn: aStream
	"Classes and Metaclasses have global names."

	aStream nextPutAll: self name! !

!ClassDescription methodsFor: 'instance variables'!
addInstVarName: aString 
	"Add the argument, aString, as one of the receiver's instance variables."

	self subclassResponsibility!
browseClassVariables
	"Put up a browser showing the receiver's class variables.  2/1/96 sw"

	self classPool inspectWithLabel: 'Class Variables in ', self name!
browseClassVarRefs 
	"1/17/96 sw: moved here from Browser so that it could be used from a variety of places."

	| lines labelStream vars allVars index owningClasses |

	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	owningClasses _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class classVarNames asSortedCollection.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var.
			owningClasses add: class].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ self].
	Smalltalk browseAllCallsOn:
		((owningClasses at: index) classPool associationAt: (allVars at: index))!
browseInstVarDefs 
	"Copied from browseInstVarRefs.  Should be consolidated some day. 7/29/96 di
	7/30/96 sw: did the consolidation"

	self chooseInstVarThenDo:	
		[:aVar | self browseAllStoresInto: aVar]!
browseInstVarRefs 
	"1/16/96 sw: moved here from Browser so that it could be used from a variety of places.
	 7/30/96 sw: call chooseInstVarThenDo: to get the inst var choice"

	self chooseInstVarThenDo: 
		[:aVar | self browseAllAccessesTo: aVar]!
chooseInstVarThenDo: aBlock 
	"Put up a menu of all the instance variables in the receiver, and when the user chooses one, evaluate aBlock with the chosen variable as its parameter.  7/30/96 sw"

	| lines labelStream vars allVars index |

	lines _ OrderedCollection new.
	allVars _ OrderedCollection new.
	labelStream _ WriteStream on: (String new: 200).
	self withAllSuperclasses reverseDo:
		[:class |
		vars _ class instVarNames.
		vars do:
			[:var |
			labelStream nextPutAll: var; cr.
			allVars add: var].
		vars isEmpty ifFalse: [lines add: allVars size]].
	labelStream isEmpty ifTrue:
		[^ (PopUpMenu labels: ' OK ')
			startUpWithCaption: 'There are no
instance variables.'].
	labelStream skip: -1 "cut last CR".
	index _ (PopUpMenu labels: labelStream contents lines: lines) startUp.
	index = 0 ifTrue: [^ self].
	aBlock value: (allVars at: index)!
forceNewFrom: anArray
    "Create a new instance of the class and fill
    its instance variables up with the array."
    | object max |

    object _ self new.
    max _ self instSize.
    anArray doWithIndex: [:each :index |
        index > max ifFalse:
            [object instVarAt: index put: each]].
    ^ object!
instVarNames
	"Answer an Array of the receiver's instance variable names."

	instanceVariables == nil
		ifTrue: [^#()]
		ifFalse: [^instanceVariables]!
removeInstVarName: aString 
	"Remove the argument, aString, as one of the receiver's instance 
	variables. Create an error notification if the argument is not found."

	self subclassResponsibility! !

!ClassDescription methodsFor: 'method dictionary'!
removeCategory: aString 
	"Remove each of the messages categorized under aString in the method 
	dictionary of the receiver. Then remove the category aString."
	| categoryName |
	categoryName _ aString asSymbol.
	(self organization listAtCategoryNamed: categoryName) do:
		[:sel | self removeSelector: sel].
	self organization removeCategory: categoryName!
removeSelector: aSymbol 
	"Remove the message whose selector is aSymbol from the method 
	dictionary of the receiver, if it is there. Answer nil otherwise."

	(methodDict includesKey: aSymbol) ifFalse: [^nil].
	super removeSelector: aSymbol.
	self organization removeElement: aSymbol.
	Smalltalk changes removeSelector: aSymbol class: self.
	self acceptsLoggingOfCompilation ifTrue:
		[Smalltalk logChange: self name , ' removeSelector: #' , aSymbol]! !

!ClassDescription methodsFor: 'organization'!
category
	"Answer the system organization category for the receiver."

	^SystemOrganization categoryOfElement: self name!
category: cat 
	"Categorize the receiver under the system category, cat, removing it from 
	any previous categorization."

	(cat isKindOf: String)
		ifTrue: [SystemOrganization classify: self name under: cat asSymbol]
		ifFalse: [self errorCategoryName]!
organization
	"Answer the instance of ClassOrganizer that represents the organization 
	of the messages of the receiver."

	organization==nil
		ifTrue: [organization _ 
				 ClassOrganizer defaultList: 
						methodDict keys asSortedCollection asArray].
	^organization!
whichCategoryIncludesSelector: aSelector 
	"Answer the category of the argument, aSelector, in the organization of 
	the receiver, or answer nil if the receiver does not inlcude this selector."

	(self includesSelector: aSelector)
		ifTrue: [^organization categoryOfElement: aSelector]
		ifFalse: [^nil]! !

!ClassDescription methodsFor: 'compiling'!
acceptsLoggingOfCompilation
	"weird name is so that it will come lexically before #compile, so that a clean build can make it through.  7/7/96 sw"

	^ true!
checkForPerform: selector in: aController
	"If this newly accepted method contains a perform:, remind the user to put in fake code with the selectors the perform would use.  So senders of those selectors will find this code.  tck 1991
	1/22/96 sw: MacPal -> Utilities
	1/24/96 sw: temporarily, at least, bypassed this guy"
 
	| meth hasPerform |
	self flag: #noteToDan.
	"Ted put this into our image back in 1991, in an effort to force uses who insist on using #perform to put some fake source into their code so that all the selectors likely to be invoked by the perform will be retrieved when one queries senders.  While agreeing this a promising approach, in practice I found it quite a nuisance and also the found the implementation somewhat flawed, so for the moment (more for my personal convenience than as any kind of formal statement) I've commented it out...  2/5/96 sw"

	"My approach to this would be to disallow all uses of perform:, and replace them with
	obj perform: selector from: #(list of selectors).
This provides in-code documenstation, leverage for senders and inplementersOf.  It gives type inference the clue it needs as well, not to mention the possibility of run-time checks on perform: 4/22/96 di"

	true ifTrue: [^ ''].

	selector == nil ifTrue: [^ ''].
	meth _ self compiledMethodAt: selector.
	hasPerform _ false.
	#(perform: perform:with: perform:with:with: perform:with:with:with: perform:withArguments:) do: [:each |
		(meth pointsTo: "faster than hasLiteral:" each) ifTrue: [
			hasPerform _ true]].
	hasPerform ifFalse: [^ self].		"normal case, no perform: here"
	(meth pointsTo: #doNotListPerformSelectors) ifTrue: [^ ''].
	Sensor leftShiftDown ifTrue: [^ ''].  
		"When need to accept a method that has many selectors performed
		and needs to be fast so don't want to include doNotListPerformSelectors."

	self inform: 
'This method contains a perform:.
Please list all selectors that will 
be performed in the Selectors 
Performed section of this method.'.

	(meth pointsTo: #listPerformSelectorsHere) ifFalse: [
		"insert section in the method"
		^ '.

	false ifTrue: ["Selectors Performed"
		"Please list all selectors that could be args to the 
		perform: in this method.  Do this so senders will find
		this method as one of the places the selector is sent from."
		"Use a temp with the class name as the reciever, like this:
		aBrowser accept."
		self listPerformSelectorsHere.		"tells the parser its here"
		].']!
compile: code classified: heading 
	"Compile the argument, code, as source code in the context of the 
	receiver and install the result in the receiver's method dictionary under 
	the classification indicated by the second argument, heading. nil is to be 
	notified if an error occurs. The argument code is either a string or an 
	object that converts to a string or a PositionableStream on an object that 
	converts to a string."

	^self
		compile: code
		classified: heading
		notifying: (SyntaxError new category: heading)!
compile: text classified: category notifying: requestor 
	| selector dict priorMethod method |
	method _ self
		compile: text asString
		notifying: requestor
		trailer: #(0 0 0 )
		ifFail: [^nil]
		elseSetSelectorAndNode: 
			[:sel :node | selector _ sel.
			priorMethod _ methodDict at: selector ifAbsent: [nil]].
	(SourceFiles isNil or: [(SourceFiles at: 2) == nil])
		ifFalse: [self acceptsLoggingOfCompilation
					ifTrue:
						[method
						putSource: text asString
						class: self category: category
						inFile: 2 priorMethod: priorMethod]].
	self organization classify: selector under: category.
	^selector!
compile: code notifying: requestor 
	"Refer to the comment in Behavior|compile:notifying:." 

	^self compile: code
		 classified: ClassOrganizer default
		 notifying: requestor!
compile: code notifying: requestor trailer: bytes ifFail: failBlock
	"For backward compatibility."
	| selector |
	self compile: code notifying: requestor trailer: bytes
		ifFail: failBlock
		elseSetSelectorAndNode: [:sel :node | selector _ sel].
	^ selector!
compile: code notifying: requestor trailer: bytes
		ifFail: failBlock
		elseSetSelectorAndNode: selAndNodeBlock
	"Intercept this message in order to remember system changes.
	 5/15/96 sw: modified so that if the class does not wish its methods logged in the changes file, then they also won't be accumulated in the current change set.
	7/12/96 sw: use wantsChangeSetLogging to determine whether to put in change set"

	| methodNode selector method |
	methodNode _ self compilerClass new
				compile: code
				in: self
				notifying: requestor
				ifFail: failBlock.
	selector _ methodNode selector.
	selAndNodeBlock value: selector value: methodNode.
	self wantsChangeSetLogging ifTrue:
		[(methodDict includesKey: selector)
			ifTrue: [Smalltalk changes changeSelector: selector class: self]
			ifFalse: [Smalltalk changes addSelector: selector class: self]].
	methodNode encoder requestor: requestor.  "Why was this not preserved?"
	method _ methodNode generate: bytes.
	self addSelector: selector withMethod: method.
	^ method!
wantsChangeSetLogging
	"Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.  7/12/96 sw"


	^ true! !

!ClassDescription methodsFor: 'fileIn/Out'!
definition
	"Answer a String that defines the receiver."

	| aStream |
	aStream _ WriteStream on: (String new: 300).
	aStream nextPutAll: 
		(superclass == nil
			ifTrue: ['nil']
			ifFalse: [superclass name])
		, self kindOfSubclass.
	self name storeOn: aStream.
	aStream cr; tab; nextPutAll: 'instanceVariableNames: '.
	aStream store: self instanceVariablesString.
	aStream cr; tab; nextPutAll: 'classVariableNames: '.
	aStream store: self classVariablesString.
	aStream cr; tab; nextPutAll: 'poolDictionaries: '.
	aStream store: self sharedPoolsString.
	aStream cr; tab; nextPutAll: 'category: '.
	(SystemOrganization categoryOfElement: self name) asString storeOn: aStream.
	^aStream contents!
fileOutCategory: aString 
	"Create a file whose name is the name of the receiver with -.st- as the 
	extension, and file a description of the receiver's category aString onto it."

	| fileName fileStream |
	fileName _ (self name , '-' , aString , '.st') asFileName.
	fileStream _ FileStream newFileNamed: fileName.
	fileStream header; timeStamp.
	self fileOutCategory: aString
		on: fileStream
		moveSource: false
		toFile: 0.
	fileStream trailer; close!
fileOutCategory: aString on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the receiver's category, aString, onto aFileStream. If 
	the boolean argument, moveSource, is true, then set the trailing bytes to 
	the position of aFileStream and to fileIndex in order to indicate where to 
	find the source code."

	aFileStream cr.
	self printCategoryChunk: aString on: aFileStream.
	(self organization listAtCategoryNamed: aString)
		do: [:sel | self
				printMethodChunk: sel
				on: aFileStream
				moveSource: moveSource
				toFile: fileIndex].
	aFileStream nextChunkPut: ' '!
fileOutChangedMessages: aSet on: aFileStream 
	"File a description of the messages of the receiver that have been 
	changed (i.e., are entered into the argument, aSet) onto aFileStream."

	self fileOutChangedMessages: aSet
		on: aFileStream
		moveSource: false
		toFile: 0!
fileOutChangedMessages: aSet on: aFileStream moveSource: moveSource toFile: fileIndex 
	"File a description of the messages of the receiver that have been 
	changed (i.e., are entered into the argument, aSet) onto 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."
	| org sels |
	(org _ self organization) categories do: 
		[:cat | 
		sels _ (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel].
		sels size > 0
			ifTrue: 
				[self printCategoryChunk: cat on: aFileStream.
				sels do: [:sel | 
						self printMethodChunk: sel
							on: aFileStream
							moveSource: moveSource
							toFile: fileIndex].
				aFileStream nextChunkPut: ' ']]!
fileOutOn: aFileStream 
	"File a description of the receiver on aFileStream."

	self fileOutOn: aFileStream
		moveSource: false
		toFile: 0!
fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex
	"File a description of the receiver on aFileStream. If the boolean 
	argument, moveSource, is true, then set the trailing bytes to the position 
	of aFileStream and to fileIndex in order to indicate where to find the 
	source code."
	aFileStream emphasis: 5.
	aFileStream nextChunkPut: self definition.
	aFileStream emphasis: 3.
	self organization
		putCommentOnFile: aFileStream
		numbered: fileIndex
		moveSource: moveSource.
	self organization categories do: 
		[:heading |
		self
			fileOutCategory: heading
			on: aFileStream
			moveSource: moveSource
			toFile: fileIndex]!
fileOutOrganizationOn: aFileStream
	"File a description of the receiver's organization on aFileStream."

	aFileStream emphasis: 3.
	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: self name, ' reorganize'; cr.
	aFileStream nextChunkPut: self organization printString; cr.
	aFileStream emphasis: 1!
kindOfSubclass
	"Answer a string that describes what kind of subclass the receiver is, i.e.,
	variable, variable byte, variable word, or not variable."

	self isVariable
		ifTrue: [self isBits
					ifTrue: [self isBytes
								ifTrue: [^' variableByteSubclass: ']
								ifFalse: [^' variableWordSubclass: ']]
					ifFalse: [^' variableSubclass: ']]
		ifFalse: [^' subclass: ']!
methods
	"Answer a ClassCategoryReader for accessing the messages in the method dictionary category, 'as yet unclassified', of the receiver.  Used for filing in fileouts made with Smalltalk/V"

	^ClassCategoryReader class: self category: 'imported from V' asSymbol!
methodsFor: aString 
	"Answer a ClassCategoryReader for accessing the messages in the method 
	dictionary category, aString, of the receiver."

	^ClassCategoryReader class: self category: aString asSymbol

	"False methodsFor: 'logical operations' inspect"!
methodsFor: aString priorSource: sourcePosition inFile: fileIndex
	"Prior source pointer ignored when filing in."
	^ self methodsFor: aString!
moveChangesTo: newFile 
	"Used in the process of condensing changes, this message requests that 
	the source code of all methods of the receiver that have been changed 
	should be moved to newFile."

	| changes |
	self organization moveChangedCommentToFile: newFile numbered: 2.
	changes _ methodDict keys select: [:sel | (methodDict at: sel) fileIndex > 1].
	self fileOutChangedMessages: changes
		on: newFile
		moveSource: true
		toFile: 2!
printCategoryChunk: aString on: aFileStream
	"Print the message describing that methods for the category aString follow 
	next on aFileStream."

	aFileStream command: 'H3'.
	aFileStream cr; nextPut: $!!.
	aFileStream nextChunkPut: (self name , ' methodsFor: ''' , aString , '''').
	aFileStream command: '/H3'.
!
printCategoryChunk: category on: aFileStream priorMethod: priorMethod
	"Print the message indicating that methods for the category follow 
	next on aFileStream.  If priorMethod is not nil, the message also
	indicates where to find the prior source code"

	aFileStream cr; command: 'H3'; nextPut: $!!.
	aFileStream nextChunkPut: (String streamContents:
		[:strm |
		strm nextPutAll: self name;
			nextPutAll: ' methodsFor: ';
			print: category asString.
		priorMethod notNil ifTrue:
			[strm nextPutAll: ' priorSource: ';
				print: priorMethod filePosition;
				nextPutAll: ' inFile: ';
				print: priorMethod fileIndex]]).
	aFileStream command: '/H3'.!
printMethodChunk: aSelector on: aFileStream moveSource: moveSource toFile: fileIndex
	"Print the source for the method of aSelector on aFileSteam, and move 
	the source to the source file specified by fileIndex if moveSource is true."
	| position method fastStream |
	aFileStream cr.
	moveSource ifTrue: [position _ aFileStream position].
	method _ self compiledMethodAt: aSelector.
	self copySourceCodeAt: aSelector to: aFileStream.
	moveSource ifTrue: [method setSourcePosition: position inFile: fileIndex]!
reformatAll 
	"Reformat all methods in this class.
	Leaves old code accessible to version browsing"
	self selectorsDo: [:sel | self reformatMethodAt: sel]!
reformatMethodAt: selector 
	| newCodeString method |
	newCodeString _ (self compilerClass new)
		format: (self sourceCodeAt: selector)
		in: self
		notifying: nil.
	method _ self compiledMethodAt: selector.
	method
		putSource: newCodeString
		class: self
		category: (self organization categoryOfElement: selector)
		inFile: 2 priorMethod: method!
reorganize
	"Record that the receiver is being reorganized and answer the receiver's organization."

	Smalltalk changes reorganizeClass: self.
	^self organization! !

!ClassDescription methodsFor: 'private'!
errorCategoryName
	self error: 'Category name must be a String'!
space
	"Answer a rough estimate of number of objects in this class and its metaclass"
	| objs words method metaSpace |
	objs _ words _ 0.
	self selectorsDo:
		[:sel | objs_ objs+1.
		method _ self compiledMethodAt: sel.
		words _ words + (method size+1//2) + 2 + 4 "dict and org'n space".
		method literals do:
			[:lit | (lit isMemberOf: String) ifTrue:
				[words _ words+2+(lit size+1//2).
				objs _ objs+1]]].
	(self isMemberOf: Metaclass) ifFalse:
		[metaSpace _ self class space.
		objs _ objs + metaSpace first.
		words _ words + metaSpace last].
	^ Array with: objs with: words! !BrowserListController subclass: #ClassListController
	instanceVariableNames: ''
	classVariableNames: 'ClassListYellowButtonMenu ClassListYellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-Browser'!
ClassListController comment:
'I am a kind of LockedListController that creates a yellow button menu so that messages can be sent to the list selection (a Class) to:
	browse	create a class browser
	categories	print the message categories
	comment	print a comment describing the purpose of the class
	definition	print the expression that defines the class
	fileOut	print a description of the class on an external file
	hierarchy	print a description of the superclass hierarchy
	remove	expunge the class from the system'!

!ClassListController methodsFor: 'initialize-release'!
initialize

	super initialize.
	self initializeYellowButtonMenu! !

!ClassListController methodsFor: 'menu messages'!
browse
	"Create and schedule a class browser on the selected class."

	self controlTerminate.
	model buildClassBrowser.
	self controlInitialize!
browseClassRefs
	"Request a browser of references to the current class."

	self controlTerminate.
	model browseClassRefs.
	self controlInitialize!
browseClassVarRefs
	"Request a browser of references to a chosen class variable."

	self controlTerminate.
	model browseClassVarRefs.
	self controlInitialize!
browseInstVarDefs
	"Request a browser of methods that access a chosen instance variable."

	self controlTerminate.
	model browseInstVarDefs.
	self controlInitialize!
browseInstVarRefs
	"Request a browser of methods that access a chosen instance variable."

	self controlTerminate.
	model browseInstVarRefs.
	self controlInitialize!
classVariables
	"Request a dictionary inspector on the chosen class's clas variables.  2/5/96 sw."

	self controlTerminate.
	model browseClassVariables.
	self controlInitialize!
comment
	"Request that the receiver's view display the comment of the selected 
	class so that it can be edited."

	self controlTerminate.
	model editComment.
	self controlInitialize!
definition
	"Request that the receiver's view display the definition of the selected 
	class so that it can be edited."

	self controlTerminate.
	model editClass.
	self controlInitialize!
fileOut
	"Print a description of the selected class onto an external file."

	self controlTerminate.
	Cursor write showWhile:
		[model fileOutClass].
	self controlInitialize!
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 messageCategoryListIndex messageListIndex |
	self controlTerminate.

	model classListIndex = 0 ifTrue: [^ self].
	model okToChange ifFalse: [^ self].
	aClass _ model selectedClassOrMetaClass.
	selectors _ aClass selectors asSortedArray.
	reply _ (SelectionMenu labelList: selectors selections: selectors) startUp.
	reply == nil ifTrue: [^ self].
	cat _ aClass whichCategoryIncludesSelector: reply.
	messageCategoryListIndex _ model messageCategoryList indexOf: cat.
	model messageCategoryListIndex: messageCategoryListIndex.
	messageListIndex _ (model messageList indexOf: reply).
	model messageListIndex: messageListIndex.
	self controlInitialize.
!
hierarchy
	"Request that the receiver's view display the class hierarchy (super- and 
	subclasses) of the selected class so that it can be edited."

	self controlTerminate.
	model hierarchy.
	self controlInitialize!
printOut
	"Make a file with the description of the selected mesage category.
	Defaults to the same file as fileOut, but could be changed in any given
	implementation to have a prettier format."

	self fileOut!
remove
	"Remove the selected class from the system. A Confirmer is created."

	self controlTerminate.
	model removeClass.
	self controlInitialize!
rename
	"Request to rename the currently selected class."
	self controlTerminate.
	model renameClass.
	self controlInitialize! !

!ClassListController methodsFor: 'private'!
changeModelSelection: anInteger
	model toggleClassListIndex: anInteger!
initializeYellowButtonMenu

	self yellowButtonMenu: ClassListYellowButtonMenu 
		yellowButtonMessages: ClassListYellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ClassListController class
	instanceVariableNames: ''!

!ClassListController class methodsFor: 'class initialization'!
initialize
	"Initialize the yellow button menu information.
	 2/1/96 sw: added class vars
	 7/29/96 sw: added 'find method' feature"
	
	ClassListYellowButtonMenu _
		PopUpMenu 
				labels: 
'browse class
printOut
fileOut
hierarchy
definition
comment
inst var refs..
class var refs...
class vars
class refs
rename...
remove
find method...' 
				lines: #(3 6 10 12).
	ClassListYellowButtonMessages _ 
		#(browse printOut fileOut
		hierarchy definition comment
		browseInstVarRefs browseClassVarRefs classVariables browseClassRefs
		rename remove findMethod)
	"
	ClassListController initialize.
	ClassListController allInstancesDo:
		[:x | x initializeYellowButtonMenu].
	"! !

ClassListController initialize!
BrowserListView subclass: #ClassListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Browser'!
ClassListView comment:
'I am a BrowserListView whose items are the class names in the Browser I view. ClassListController is my default controller.'!

!ClassListView methodsFor: 'updating'!
getList 
	"Refer to the comment in BrowserListView|getList."

	| selectedClassName |
	singleItemMode
		ifTrue: 
			[selectedClassName _ model selectedClassName.
			selectedClassName == nil ifTrue: [selectedClassName _ '    '].
			^Array with: selectedClassName asSymbol]
		ifFalse: [^model classList]!
update: aSymbol

	(aSymbol == #systemCategorySelectionChanged) |
	(aSymbol == #editSystemCategories) |
	(aSymbol == #classListChanged)
		ifTrue:  [self updateClassList. ^self].
	(aSymbol == #classSelectionChanged)
		ifTrue: [self updateClassSelection. ^self]! !

!ClassListView methodsFor: 'controller access'!
defaultControllerClass

	^ClassListController! !

!ClassListView methodsFor: 'private'!
updateClassList

	singleItemMode ifFalse: [self getListAndDisplayView] !
updateClassSelection

	singleItemMode 
		ifTrue: [self getListAndDisplayView]
		ifFalse: [self moveSelectionBox: model classListIndex]! !Object subclass: #ClassOrganizer
	instanceVariableNames: 'globalComment categoryArray categoryStops elementArray '
	classVariableNames: 'NullCategory Default '
	poolDictionaries: ''
	category: 'Kernel-Support'!
ClassOrganizer comment:
'I represent method categorization information for classes.'!

!ClassOrganizer methodsFor: 'accessing'!
categories
	"Answer an Array of categories (names)."
	(categoryArray size = 1 
		and: [categoryArray first = Default & (elementArray size = 0)])
		ifTrue: [^Array with: NullCategory].
	^categoryArray!
categories: anArray 
	"Reorder my categories to be in order of the argument, anArray. If the 
	resulting organization does not include all elements, then give an error."

	| newCategories newStops newElements catName list runningTotal | 
	newCategories _ Array new: anArray size.
	newStops _ Array new: anArray size.
	newElements _ Array new: 0.
	runningTotal _ 0.
	1 to: anArray size do:
		[:i |
		catName _ (anArray at: i) asSymbol.
		list _ self listAtCategoryNamed: catName.
				newElements _ newElements, list.
				newCategories at: i put: catName.
				newStops at: i put: (runningTotal _ runningTotal + list size)].
	elementArray do:
		[:element | "check to be sure all elements are included"
		(newElements includes: element)
			ifFalse: [^self error: 'New categories must match old ones']].
	"Everything is good, now update my three arrays."
	categoryArray _ newCategories.
	categoryStops _ newStops.
	elementArray _ newElements!
categoryOfElement: element 
	"Answer the category associated with the argument, element."

	| index |
	index _ self numberOfCategoryOfElement: element.
	index = 0
		ifTrue: [^nil]
		ifFalse: [^categoryArray at: index]!
changeFromString: aString 
	"Parse the argument, aString, and make this be the receiver's structure."

	| scanner oldElements newElements newCategories newStops currentStop anArray |
	scanner _ Scanner new scanTokens: aString.
	"If nothing was scanned and I had no elements before, then default me"
	(scanner size = 0 and: [elementArray size = 0])
		ifTrue: [^self setDefaultList: Array new].

	oldElements _ elementArray asSet.
	newCategories _ Array new: scanner size.
	newStops _ Array new: scanner size.
	currentStop _ 0.
	newElements _ WriteStream on: (Array new: 16).
	1 to: scanner size do: 
		[:i | 
		anArray _ scanner at: i.
		newCategories at: i put: anArray first asSymbol.
		(anArray copyFrom: 2 to: anArray size) asSortedCollection do:
			[:elem |
			(oldElements remove: elem ifAbsent: [nil]) notNil ifTrue:
				[newElements nextPut: elem.
				currentStop _ currentStop+1]].
		newStops at: i put: currentStop].

	"Ignore extra elements but don't lose any existing elements!!"
	oldElements _ oldElements collect:
		[:elem | Array with: (self categoryOfElement: elem) with: elem].
	newElements _ newElements contents.
	categoryArray _ newCategories.
	categoryStops _ newStops.
	elementArray _ newElements.
	oldElements do: [:pair | self classify: pair last under: pair first].!
listAtCategoryNamed: categoryName
	"Answer the array of elements associated with the name, categoryName."

	| i |
	i _ categoryArray indexOf: categoryName ifAbsent: [^Array new].
	^self listAtCategoryNumber: i!
listAtCategoryNumber: anInteger 
	"Answer the array of elements stored at the position indexed by 
	anInteger."

	| firstIndex lastIndex |
	firstIndex _ 
		(anInteger > 1
			ifTrue: [categoryStops at: anInteger - 1]
			ifFalse: [0])
		+ 1.
	lastIndex _ categoryStops at: anInteger.
	^elementArray copyFrom: firstIndex to: lastIndex!
numberOfCategoryOfElement: element 
	"Answer the index of the category with which the argument, element, is 
	associated."

	| categoryIndex elementIndex |
	categoryIndex _ 1.
	elementIndex _ 0.
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			["point to correct category"
			[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: [categoryIndex _ categoryIndex + 1].
			"see if this is element"
			element = (elementArray at: elementIndex) ifTrue: [^categoryIndex]].
	^0!
removeElement: element 
	"Remove the selector, element, from all categories."
	| categoryIndex elementIndex nextStop newElements |
	categoryIndex _ 1.
	elementIndex _ 0.
	nextStop _ 0.
	"nextStop keeps track of the stops in the new element array"
	newElements _ WriteStream on: (Array new: elementArray size).
	[(elementIndex _ elementIndex + 1) <= elementArray size]
		whileTrue: 
			[[elementIndex > (categoryStops at: categoryIndex)]
				whileTrue: 
					[categoryStops at: categoryIndex put: nextStop.
					categoryIndex _ categoryIndex + 1].
			(elementArray at: elementIndex) = element
				ifFalse: 
					[nextStop _ nextStop + 1.
					newElements nextPut: (elementArray at: elementIndex)]].
	[categoryIndex <= categoryStops size]
		whileTrue: 
			[categoryStops at: categoryIndex put: nextStop.
			categoryIndex _ categoryIndex + 1].
	elementArray _ newElements contents!
removeEmptyCategories
	"Remove empty categories."

	| categoryIndex currentStop keptCategories keptStops |
	keptCategories _ WriteStream on: (Array new: 16).
	keptStops _ WriteStream on: (Array new: 16).
	currentStop _ categoryIndex _ 0.
	[(categoryIndex _ categoryIndex + 1) <= categoryArray size]
		whileTrue: 
			[(categoryStops at: categoryIndex) > currentStop
				ifTrue: 
					[keptCategories nextPut: (categoryArray at: categoryIndex).
					keptStops nextPut: (currentStop _ categoryStops at: categoryIndex)]].
	categoryArray _ keptCategories contents.
	categoryStops _ keptStops contents.
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]

	"ClassOrganizer allInstancesDo: [:co | co removeEmptyCategories]."! !

!ClassOrganizer methodsFor: 'compiler access'!
classComment
	"Answer the comment associated with the object that refers to the 
	receiver."

	globalComment == nil ifTrue: [^''].
	^globalComment string!
classComment: aString 
	"Store the comment, aString, associated with the object that refers to the 
	receiver."

	aString size = 0
		ifTrue: [globalComment _ nil]
		ifFalse: [globalComment _ RemoteString newString: aString onFileNumber: 2]!
classify: element under: heading 
	"Store the argument, element, in the category named heading."

	| catName catIndex elemIndex realHeading |
	heading = NullCategory
		ifTrue: [realHeading _ Default]
		ifFalse: [realHeading _ heading asSymbol].
	(catName _ self categoryOfElement: element) = realHeading
		ifTrue: [^self].  "done if already under that category"

	catName ~~ nil ifTrue: 
		[realHeading = Default
			ifTrue: [^self].	"return if exists and realHeading is default"
		self removeElement: element].	"remove if in another category"

	(categoryArray indexOf: realHeading) = 0 ifTrue: [self addCategory: realHeading].
	"add realHeading if not there already"

	catIndex _ categoryArray indexOf: realHeading.
	elemIndex _ 
		catIndex > 1
			ifTrue: [categoryStops at: catIndex - 1]
			ifFalse: [0].
	[(elemIndex _ elemIndex + 1) <= (categoryStops at: catIndex) 
		and: [element >= (elementArray at: elemIndex)]] whileTrue.

	"elemIndex is now the index for inserting the element. Do the insertion before it."
	elementArray _ 
		(elementArray copyFrom: 1 to: elemIndex - 1)
			, (Array with: element) 
			, (elementArray copyFrom: elemIndex to: elementArray size).	"insertion"

	"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]!
classifyAll: aCollection under: heading

	aCollection do:
		[:element | self classify: element under: heading]!
hasNoComment
	"Answer whether the class classified by the receiver has a comment."

	^globalComment == nil!
moveChangedCommentToFile: aFileStream numbered: sourceIndex 
	"This is part of source code compression. Move the comment about the 
	class classified by the receiver from the file referenced by sourceIndex 
	and to the stream, aFileStream."

	(globalComment ~~ nil and: [globalComment sourceFileNumber > 1])
		ifTrue: 
			[aFileStream cr; cr.
			globalComment _ 
				RemoteString
					newString: globalComment string
					onFileNumber: sourceIndex
					toFile: aFileStream]!
putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource 
	"Store the comment about the class onto file, aFileStream."

	| newRemoteString |
	globalComment ~~ nil
		ifTrue: 
			[aFileStream cr.
			newRemoteString _ 
				RemoteString
						newString: globalComment string
						onFileNumber: sourceIndex
						toFile: aFileStream.
			moveSource ifTrue: [globalComment _ newRemoteString]]! !

!ClassOrganizer methodsFor: 'method dictionary'!
addCategory: newCategory
	^ self addCategory: newCategory before: nil !
addCategory: catString before: nextCategory
	"Add a new category named heading.
	If default category exists and is empty, remove it.
	If nextCategory is nil, then add the new one at the end,
	otherwise, insert it before nextCategory."
	| index newCategory |
	newCategory _ catString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^self].	"heading already exists, so done"
	index _ categoryArray indexOf: nextCategory
		ifAbsent: [categoryArray size + 1].
	categoryArray _ categoryArray
		copyReplaceFrom: index
		to: index-1
		with: (Array with: newCategory).
	categoryStops _ categoryStops
		copyReplaceFrom: index
		to: index-1
		with: (Array with: (index = 1
				ifTrue: [0]
				ifFalse: [categoryStops at: index-1])).
	"remove empty default category"
	(self listAtCategoryNamed: Default) size = 0
		ifTrue: [self removeCategory: Default]!
removeCategory: cat 
	"Remove the category named, cat. Create an error notificiation if the 
	category has any elements in it."

	| index lastStop |
	index _ categoryArray indexOf: cat ifAbsent: [^self].
	lastStop _ 
		index = 1
			ifTrue: [0]
			ifFalse: [categoryStops at: index - 1].
	(categoryStops at: index) - lastStop > 0 
		ifTrue: [^self error: 'cannot remove non-empty category'].
	categoryArray _ 
		(categoryArray copyFrom: 1 to: index - 1)
			, (categoryArray copyFrom: index + 1 to: categoryArray size).
	categoryStops _ 
		(categoryStops copyFrom: 1 to: index - 1)
			, (categoryStops copyFrom: index + 1 to: categoryStops size).
	categoryArray size = 0
		ifTrue:
			[categoryArray _ Array with: Default.
			categoryStops _ Array with: 0]
!
renameCategory: oldCatString toBe: newCatString
	"Rename a category. No action if new name already exists,
	or if old name does not exist."
	| index oldCategory newCategory |
	oldCategory _ oldCatString asSymbol.
	newCategory _ newCatString asSymbol.
	(categoryArray indexOf: newCategory) > 0
		ifTrue: [^self].	"new name exists, so no action"
	(index _ categoryArray indexOf: oldCategory) = 0
		ifTrue: [^self].	"old name not found, so no action"
	categoryArray at: index put: newCategory! !

!ClassOrganizer methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	| elementIndex lastStop |
	elementIndex _ 1.
	lastStop _ 1.
	1 to: categoryArray size do: 
		[:i | 
		aStream nextPut: $(.
		(categoryArray at: i) asString printOn: aStream.
		[elementIndex <= (categoryStops at: i)]
			whileTrue: 
				[aStream space.
				(elementArray at: elementIndex) printOn: aStream.
				elementIndex _ elementIndex + 1].
		aStream nextPut: $).
		aStream cr]! !

!ClassOrganizer methodsFor: 'fileIn/Out'!
scanFrom: aStream
	"Reads in the organization from the next chunk on aStream.
	Categories or elements not found in the definition are not affected.
	New elements are ignored."

	self changeFromString: aStream nextChunk! !

!ClassOrganizer methodsFor: 'private'!
setDefaultList: aSortedCollection

	self classComment: ''.
	categoryArray _ Array with: Default.
	categoryStops _ Array with: aSortedCollection size.
	elementArray _ aSortedCollection asArray! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ClassOrganizer class
	instanceVariableNames: ''!

!ClassOrganizer class methodsFor: 'class initialization'!
default 
	^ Default!
initialize
	Default _ 'as yet unclassified' asSymbol.
	NullCategory _ 'no messages' asSymbol.
	"ClassOrganizer initialize"!
nullCategory
	^ NullCategory! !

!ClassOrganizer class methodsFor: 'instance creation'!
defaultList: aSortedCollection 
	"Answer an instance of me with initial elements from the argument, 
	aSortedCollection."

	^self new setDefaultList: aSortedCollection! !

!ClassOrganizer class methodsFor: 'documentation'!
documentation
	"Instances consist of an Array of category names (categoryArray), each of 
	which refers to an Array of elements (elementArray). This association is 
	made through an Array of stop indices (categoryStops), each of which is 
	the index in elementArray of the last element (if any) of the 
	corresponding category. For example: categories _ Array with: 'firstCat' 
	with: 'secondCat' with: 'thirdCat'. stops _ Array with: 1 with: 4 with: 4. 
	elements _ Array with: #a with: #b with: #c with: #d. This means that 
	category firstCat has only #a, secondCat has #b, #c, and #d, and 
	thirdCat has no elements. This means that stops at: stops size must be the 
	same as elements size." ! !

ClassOrganizer initialize!
Model subclass: #CngsClassList
	instanceVariableNames: 'parent list listIndex controller '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!

!CngsClassList methodsFor: 'menu messages'!
browse
	"Create and schedule a message browser on the selected class (and message)."

	| myClass |
	controller controlTerminate.
	myClass _ self selectedClassOrMetaClass.
	myClass notNil ifTrue: [
		Browser postOpenSuggestion: 
			(Array with: myClass with: parent selectedMessageName).
		Browser newOnClass: self selectedClass].
	controller controlInitialize!
browseFull
	"Create and schedule a System Browser with the selected class as its opening selection.  1/12/96 sw"

	| myClass |

	(myClass _ self selectedClassOrMetaClass) notNil ifTrue: 
		[BrowserView browseFullForClass: myClass method: parent selectedMessageName from: controller]!
browseInstVarRefs
	"Browse inst refs for the selected class.  1/15/96 sw"

	| myClass |

	(myClass _ self selectedClassOrMetaClass) notNil ifTrue: 
		[myClass browseInstVarRefs]!
classVariables
	"Browse class variables selected class. 2/1/96 sw"

	| myClass |

	(myClass _ self selectedClassOrMetaClass) notNil ifTrue: 
		[myClass browseClassVariables]!
copyToOther
	"Place this change in the other changeSet also"
	| changeSet other info cls |

	controller controlTerminate.
	changeSet _ parent changeSet.
	other _ (parent parent other: parent) changeSet.

	info _ changeSet classChangeAt: (cls _ self selectedClassOrMetaClass) name.
	info do: [:each | other atClass: cls add: each].

	info _ changeSet methodChanges at: cls name ifAbsent: [Dictionary new].
	info associationsDo: [:ass |
		other atSelector: ass key class: cls put: ass value].
	(parent parent other: parent) launch.
	controller controlInitialize!
forget
	"Remove all mention of this class from the changeSet"
	controller controlTerminate.
	listIndex = 0 ifFalse: [
		parent changeSet removeClassChanges: self selectedClassOrMetaClass.
		parent launch].
	controller controlInitialize!
instVarRefs
	"Browse inst refs for the selected class.  1/15/96 sw"

	| myClass |

	(myClass _ self selectedClassOrMetaClass) notNil ifTrue: 
		[myClass browseInstVarRefs]!
performMenuMessage: sel
	self perform: sel! !

!CngsClassList methodsFor: 'list'!
changed: what
	what == #emphasize ifTrue: [^ parent launch].
	super changed: what!
list
	^ list!
list: anObject
	list _ anObject.
	listIndex _ 0.
	self changed: #list.
	parent changed: #class!
selectedClass
	| class |
	listIndex = 0 ifTrue: [^ nil].
	class _ self selectedClassOrMetaClass.
	^ class theNonMetaClass		"the class, or soleInstance if its a metaclass"!
selectedClassOrMetaClass
	| sel |
	^ listIndex = 0
		ifFalse: [Smalltalk classNamed: (list at: listIndex)]
		ifTrue: [nil]!
selection
	^ listIndex = 0 
		ifFalse: [list at: listIndex]
		ifTrue: [nil]!
selection: item
	"If this item is in the list, select it."
	| index |
	(index _ list indexOf: item) = 0 ifFalse: [
		listIndex == index ifFalse: [
				self toggleListIndex: index]
			ifTrue: [self changed: #listIndex.
				parent changed: #class]].!
toggleListIndex: aNumber
	"What to do when the user chooses an item"
	listIndex == aNumber ifTrue: [listIndex _ 0]
		ifFalse: [listIndex _ aNumber].
	self changed: #listIndex.
	parent changed: #class! !

!CngsClassList methodsFor: 'accessing'!
controller: anObject
	controller _ anObject!
listIndex
	^listIndex!
parent
	^parent!
parent: anObject
	parent _ anObject! !Model subclass: #CngsMsgList
	instanceVariableNames: 'parent list listIndex controller '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!

!CngsMsgList methodsFor: 'as yet unclassified'!
allImplementorsOf
	"Create and schedule a message set browser on all implementors of all
	the messages sent by the current method."

	controller controlTerminate.
	self browseAllMessages.
	controller controlInitialize!
browseAllMessages
	"Create and schedule a message set browser on all implementors of all
	the messages sent by the current method.  Originally conceived and implemented by tck, 1991
	 2/5/96 sw: give it a title"

	| method filteredList aClass aName |	

	listIndex ~= 0 ifTrue:
		[method _ (aClass _ parent selectedClassOrMetaClass) compiledMethodAt:
						(aName _ parent selectedMessageName).
		filteredList _ method messages reject: 
			[:each | #(new initialize = ) includes: each].
		Smalltalk browseAllImplementorsOfList: filteredList asSortedCollection
			 title: 'All messages sent in ', aClass name, '.', aName]!
browseSendersOfMessages
	"Create and schedule a message set browser on the senders of a user-chosen selector sent in the current message."

	controller controlTerminate.
	listIndex = 0 ifFalse: [
		Smalltalk showMenuThenBrowseSendersOf:
			(parent selectedClassOrMetaClass compiledMethodAt: 
				self selection asSymbol) messages asSortedCollection].
	controller controlInitialize!
copyToOther
	"Place this change in the other changeSet also"
	| changeSet other info cls sel |
	listIndex = 0 ifTrue: [^ self].

	controller controlTerminate.
	changeSet _ parent changeSet.
	other _ (parent parent other: parent) changeSet.
	cls _ parent selectedClassOrMetaClass.
	sel _ self selection asSymbol.

	info _ changeSet methodChanges at: cls name ifAbsent: [Dictionary new].
	other atSelector: sel
		class: cls 
		put: (info at: sel).
	(parent parent other: parent) launch.
	controller controlInitialize!
fileOut
	"this method"
	listIndex = 0 ifFalse: [
		controller controlTerminate.
		Cursor write showWhile:
			[parent selectedClassOrMetaClass fileOutMethod: 
				self selection asSymbol].
		controller controlInitialize].!
forget
	"Drop this method from the changeSet"
	listIndex = 0 ifTrue: [^ self].
	parent changeSet removeSelectorChanges: parent selectedMessageName 
			class: parent selectedClassOrMetaClass.
	parent launch.!
implementors
	"Create and schedule a message set browser on the implementations of the 
	selected message."

	controller controlTerminate.
	listIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOf: self selection asSymbol].
	controller controlInitialize!
list: anObject
	list _ anObject.
	listIndex _ 0.
	self changed: #list.
	parent changed: #message!
messages
	"Create and schedule a message set browser on the the messages sent by 
	the selected message."

	controller controlTerminate.
	listIndex = 0 ifFalse: [
		Smalltalk showMenuThenBrowse:
			(parent selectedClassOrMetaClass compiledMethodAt: 
				self selection asSymbol) messages asSortedCollection].
	controller controlInitialize!
performMenuMessage: sel
	self perform: sel!
selection
	^ listIndex = 0 
		ifFalse: [list at: listIndex]
		ifTrue: [nil]!
selection: item
	"If this item is in the list, select it."
	| index |
	(index _ list indexOf: item) = 0 ifFalse: [
		
		self toggleListIndex: index.
		self changed: #listIndex.
"		self toggleListIndex: index."
		" listIndex _ index. "].!
senders
	"Create and schedule a message set browser on the methods in which the 
	selected message is sent."

	controller controlTerminate.
	listIndex ~= 0 
		ifTrue: [Smalltalk browseAllCallsOn: self selection asSymbol].
	controller controlInitialize!
toggleListIndex: aNumber
	"What to do when the user chooses an item"
	listIndex == aNumber ifTrue: [listIndex _ 0]
		ifFalse: [listIndex _ aNumber].
	self changed: #listIndex.
	parent changed: #message!
versions
	"Create and schedule a changelist browser on the versions of the 
	selected message."

	| class selector |
	controller controlTerminate.
	listIndex = 0 ifFalse: [
		class _ parent selectedClassOrMetaClass.
		selector _ parent selectedMessageName.
		ChangeList
			browseVersionsOf: (class compiledMethodAt: selector)
			class: parent selectedClass
			meta: class isMeta
			category: (class whichCategoryIncludesSelector: selector)
			selector: selector].
	controller controlInitialize! !

!CngsMsgList methodsFor: 'accessing'!
controller: anObject
	controller _ anObject!
list
	^list!
listIndex
	^listIndex!
parent
	^parent!
parent: anObject
	parent _ anObject! !Object subclass: #Collection
	instanceVariableNames: ''
	classVariableNames: 'RandomForPicking '
	poolDictionaries: ''
	category: 'Collections-Abstract'!
Collection comment:
'I am the abstract superclass of all classes that represent a group of elements.'!

!Collection methodsFor: 'accessing'!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally _ 0.
	self do: [:each | tally _ tally + 1].
	^tally! !

!Collection methodsFor: 'testing'!
includes: anObject 
	"Answer whether anObject is one of the receiver's elements."

	self do: [:each | anObject = each ifTrue: [^true]].
	^false!
includesAllOf: aCollection 
	"Answer whether all the elements of aCollection are in the receiver."
	aCollection do: [:elem | (self includes: elem) ifFalse: [^ false]].
	^ true!
includesAnyOf: aCollection 
	"Answer whether any element of aCollection is one of the receiver's elements."
	aCollection do: [:elem | (self includes: elem) ifTrue: [^ true]].
	^ false!
isEmpty
	"Answer whether the receiver contains any elements."

	^self size = 0!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| tally |
	tally _ 0.
	self do: [:each | anObject = each ifTrue: [tally _ tally + 1]].
	^tally! !

!Collection methodsFor: 'adding'!
add: newObject 
	"Include newObject as one of the receiver's elements. Answer newObject. 
	ArrayedCollections cannot respond to this message."

	self subclassResponsibility!
addAll: aCollection 
	"Include all the elements of aCollection as the receiver's elements. Answer 
	aCollection."

	aCollection do: [:each | self add: each].
	^aCollection! !

!Collection methodsFor: 'removing'!
remove: oldObject 
	"Remove oldObject as one of the receiver's elements. Answer oldObject 
	unless no element is equal to oldObject, in which case, create an error 
	notification."

	^self remove: oldObject ifAbsent: [self errorNotFound]!
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!
removeAll: aCollection 
	"Remove each element of aCollection from the receiver. If successful for 
	each, answer aCollection. Otherwise create an error notification."

	aCollection do: [:each | self remove: each].
	^aCollection!
removeAllFoundIn: aCollection 
	"Remove each element of aCollection which is present in the receiver from the receiver"

	aCollection do: [:each | self remove: each ifAbsent: []].
	^aCollection!
removeAllSuchThat: aBlock
	"Apply the condition to each element and remove it if the condition is true.  Use a copy to enumerate collections whose order changes when an element is removed (Set)."
	| copy newCollection |
	newCollection _ self species new.
	copy _ self copy.
	copy do: [:element |
		(aBlock value: element) ifTrue: [
			self remove: element.
			newCollection add: element]].
	^ newCollection! !

!Collection methodsFor: 'enumerating'!
associationsDo: aBlock
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations).  If any non-association is within, the error is not caught now,
	but later, when a key or value message is sent to it."

	self do: aBlock!
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!
collect: collectBlock thenSelect: selectBlock
	^ (self collect: collectBlock) select: selectBlock!
count: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument.  Return the number that answered true."

	| sum |
	sum _ 0.
	self do: [:each | 
		(aBlock value: each) ifTrue: [sum _ sum + 1]].
	^ sum!
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]!
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!
detectMax: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the highest magnitude.
	If collection empty, return nil.  This method might also be called elect:."

	| maxElement maxValue val |
	self do: [:each | 
		maxValue == nil
			ifFalse: [
				(val _ aBlock value: each) > maxValue ifTrue: [
					maxElement _ each.
					maxValue _ val]]
			ifTrue: ["first element"
				maxElement _ each.
				maxValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ maxElement!
detectMin: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Answer the element for which aBlock evaluates to the lowest number.
	If collection empty, return nil."

	| minElement minValue val |
	self do: [:each | 
		minValue == nil
			ifFalse: [
				(val _ aBlock value: each) < minValue ifTrue: [
					minElement _ each.
					minValue _ val]]
			ifTrue: ["first element"
				minElement _ each.
				minValue _ aBlock value: each].
				"Note that there is no way to get the first element that works 
				for all kinds of Collections.  Must test every one."].
	^ minElement!
detectSum: aBlock
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Return the sum of the answers."
	| sum |
	sum _ 0.
	self do: [:each | 
		sum _ (aBlock value: each) + sum].  
	^ sum!
do: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument."

	self subclassResponsibility!
inject: thisValue into: binaryBlock 
	"Accumulate a running value associated with evaluating the argument, 
	binaryBlock, with the current value of the argument, thisValue, and the 
	receiver as block arguments. For instance, to sum the numeric elements 
	of a collection, aCollection inject: 0 into: [:subTotal :next | subTotal + 
	next]."

	| nextValue |
	nextValue _ thisValue.
	self do: [:each | nextValue _ binaryBlock value: nextValue value: each].
	^nextValue!
reject: aBlock 
	"Evaluate aBlock with each of the receiver's elements as the argument. 
	Collect into a new collection like the receiver only those elements for 
	which aBlock evaluates to false. Answer the new collection."

	^self select: [:element | (aBlock value: element) == false]!
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!
select: selectBlock thenCollect: collectBlock
	^ (self select: selectBlock) collect: collectBlock! !

!Collection methodsFor: 'converting'!
asBag
	"Answer a Bag whose elements are the elements of the receiver."

	| aBag |
	aBag _ Bag new.
	self do: [:each | aBag add: each].
	^aBag!
asOrderedCollection
	"Answer an OrderedCollection whose elements are the elements of the 
	receiver. The order in which elements are added depends on the order in 
	which the receiver enumerates its elements. In the case of unordered 
	collections, the ordering is not necessarily the same for multiple requests 
	for the conversion."

	| anOrderedCollection |
	anOrderedCollection _ OrderedCollection new: self size.
	self do: [:each | anOrderedCollection addLast: each].
	^anOrderedCollection!
asSet
	"Answer a Set whose elements are the unique elements of the receiver."

	| aSet |
	aSet _ Set new: self size.
	self do: [:each | aSet add: each].
	^aSet!
asSortedArray
	"Return a copy of the receiver in sorted order, as an Array.  6/10/96 sw"

	^ self asSortedCollection asArray!
asSortedCollection
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is the default less than or equal."

	| aSortedCollection |
	aSortedCollection _ SortedCollection new: self size.
	aSortedCollection addAll: self.
	^aSortedCollection!
asSortedCollection: aBlock 
	"Answer a SortedCollection whose elements are the elements of the 
	receiver. The sort order is defined by the argument, aBlock."

	| aSortedCollection |
	aSortedCollection _ SortedCollection new: self size.
	aSortedCollection sortBlock: aBlock.
	aSortedCollection addAll: self.
	^aSortedCollection! !

!Collection methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	| tooMany |
	tooMany _ self maxPrint.	
		"Need absolute limit, or infinite recursion will never 
		notice anything going wrong.  7/26/96 tk"
	aStream nextPutAll: self class name, ' ('.
	self do: 
		[:element | 
		aStream position > tooMany ifTrue: [aStream nextPutAll: '...etc...)'. ^self].
		element printOn: aStream.
		aStream space].
	aStream nextPut: $)!
storeOn: aStream 
	"Refer to the comment in Object|storeOn:."

	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self do: 
		[:each | 
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' add: '.
		aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!Collection methodsFor: 'private'!
emptyCheck

	self isEmpty ifTrue: [self errorEmptyCollection]!
errorEmptyCollection

	self error: 'this collection is empty'!
errorNoMatch

	self error: 'collection sizes do not match'!
errorNotFound

	self error: 'Object is not in the collection.'!
errorNotKeyed

	self error: self class name, 's do not respond to keyed accessing messages.'!
fill: numElements fromStack: aContext 
	"Fill me with numElements elements, popped in reverse order from
	 the stack of aContext.  Do not call directly: this is called indirectly by {1. 2. 3}
	 constructs.  Subclasses that support at:put: instead of add: should override
	 this and call Context<pop:toIndexable:"

	aContext pop: numElements toAddable: self!
maxPrint
	"Answer the maximum number of characters to print with printOn:."

	^5000!
maxSize
	"Answer the largest basicSize which is valid for the receiver's class."

	^65486 "for VM3 interpreter DoradoST80Aug19"!
toBraceStack: itsSize 
	"Push receiver's elements onto the stack of thisContext sender.  Error if receiver does
	 not have itsSize elements or if receiver is unordered.
	 Do not call directly: this is called by {a. b} _ ... constructs."

	self size ~= itsSize ifTrue:
		[self error: 'Trying to store ', self size printString,
					' values into ', itsSize printString, ' variables.'].
	thisContext sender push: itsSize fromIndexable: self! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Collection class
	instanceVariableNames: ''!

!Collection class methodsFor: 'instance creation'!
fromBraceStack: itsSize 
	"Answer an instance of me with itsSize elements, popped in reverse order from
	 the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
	 constructs."

	^ self newFrom: ((Array new: itsSize) fill: itsSize fromStack: thisContext sender)!
with: anObject 
	"Answer an instance of me containing anObject."

	| newCollection |
	newCollection _ self new.
	newCollection add: anObject.
	^newCollection!
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!
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!
with: firstObject with: secondObject with: thirdObject with: fourthObject 
	"Answer an instance of me, containing the four arguments as the 
	elements."

	| newCollection |
	newCollection _ self new.
	newCollection add: firstObject.
	newCollection add: secondObject.
	newCollection add: thirdObject.
	newCollection add: fourthObject.
	^newCollection! !

!Collection class methodsFor: 'private'!
initialize
	"Set up a Random number generator to be used by pickOne when the user does not feel like creating his own Random generator."
	RandomForPicking _ Random new.
	! !

Collection initialize!
Object subclass: #Color
	instanceVariableNames: 'rgb cachedDepth cachedBitPattern '
	classVariableNames: 'LightYellow RandomStream Magenta ComponentMax Cyan LightGray Depth16GreenShift PureBlue White PureYellow Depth16RedShift GrayToIndexMap Green ColorChart Depth32BlueShift LightGreen Depth16BlueShift Yellow PureCyan ColorNames HalfComponentMask DarkGray Blue Black VeryDarkGray Red BlueShift VeryLightGray LightMagenta GreenShift Depth32GreenShift Depth32RedShift RedShift PureMagenta IndexedColors ComponentMask PureGreen LightRed LightCyan HighLightBitmaps Gray LightOrange LightBrown PureRed LightBlue '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
Color comment:
'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: 'examples'!
display
	"Show a swatch of this color tracking the cursor until the next mouseClick. 6/14/96 tk"
	"Color red display"
	| f c |
	f _ Form extent: 40@20 depth: Display depth.
	c _ Bitmap with: (self pixelWordForDepth: Display depth).
	f fillColor: c.
	Cursor blank showWhile:
		[f follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]!
hsvExample
	"Shows a palette of hues, varying the saturation and brightness for each one."
	"Color new hsvExample.  Modified 6/14/96 tk"

	| d v x y c rect |
	d _ Display depth.
	c _ Color new.		"modified in loop below"
	rect _ 0@0 extent: 5@5.	"modified in loop below"
	0 to: 179 by: 15 do: [:h |
		0 to: 10 do: [:s |
			0 to: 10 do: [:v |
				c setHue: h saturation: s asFloat / 10.0 brightness: v asFloat / 10.0.
				rect left: (h*4) + (s*5); width: 5.
				rect top: (v*5); height: 5.
				Display fill: rect fillColor: (c bitPatternForDepth: d).

				c setHue: h + 180 saturation: s asFloat / 10.0 brightness: v asFloat / 10.0.
				rect top: (v*5) + 80; height: 5.
				Display fill: rect fillColor: (c bitPatternForDepth: d).
			].
		].
	].
!
showHuesAtSaturation: s brightness: v
	"Shows a palette of hues at the given (saturation, brightness) point."
	"Color new showHuesAtSaturation: 0.9 brightness: 0.9"

	| rect c |
	rect _ 0@0 extent: 5@5.	"modified in loop below"
	0 to: 179 by: 10 do: [:h |
		c _ Color hue: h saturation: s brightness: v.
		rect left: 5 + (h*4); width: 35.
		rect top: 5; height: 35.
		Display fill: rect fillColor: c.

		c setHue: h + 180 saturation: s brightness: v.
		rect top: 45; height: 35.
		Display fill: rect fillColor: c.
	].
!
showHuesInteractively
	"Shows a palette of hues at (saturation, brightness) point determined by the mouse position. Click mouse button to exit and return the selected saturation and brightness."
	"Color new showHuesInteractively"

	| baseP p s v |
	baseP _ Sensor cursorPoint.
	[Sensor anyButtonPressed] whileFalse: [
		p _ Sensor cursorPoint.
		s _ ((p x - baseP x) + 80) asFloat / 100.0.
		v _ ((p y - baseP y) + 80) asFloat / 100.0.
		self showHuesAtSaturation: s brightness: v.
	].
	^ (s min: 1.0) @ (v min: 1.0)!
showPalette
	"Show the 12x12x12 palette used in fromUser.
	Color new showPalette"

	 | c rect |
	"RGB display gives 12x12x12 cube to choose from"
	c _ Color new.		"modified in loop below"
	rect _ 0@0 extent: 5@5.	"modified in loop below"
	0 to: 11 do: [:r |
		0 to: 11 do: [:g |
			0 to: 11 do: [:b |
				c setRed: r green: g blue: b range: 11.
				rect left: (r*60) + (b*5); width: 5.
				rect top: (g*5); height: 5.
				Display fill: rect fillColor: c.
			].
		].
	].
!
test

	IndexedColors do: [ :c |
	].!
test: depth
	"Color new test: 8"

	| i c |
	1 to: (1 << depth) do: [ :i |
		c _ IndexedColors at: i.
		(Color colorFromPixelValue: (c pixelValueForDepth: depth) value depth: depth) = c
			ifFalse: [ self error: 'bad conversion' ].
	].! !

!Color methodsFor: 'access'!
blue
	"Answer my blue component, a float in the range [0.0..1.0].  

Don't confuse this with the class message (Color blue) that returns the color pure blue.  6/13/96 tk"

	^ self privateBlue asFloat / ComponentMax!
brightness
	"Return the brightness of this paint color, a float in the range [0.0..1.0]."

	^ ((self privateRed max:
	    self privateGreen) max:
	    self privateBlue) asFloat / ComponentMax!
green
	"Answer my green component, a float in the range [0.0..1.0].  

Don't confuse this with the class message (Color green) that returns the color pure green.  6/13/96 tk"

	^ self privateGreen asFloat / ComponentMax!
hue
	"Return the hue of this color, an angle in the range [0.0..360.0]."

	| r g b max min span h |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ ((r max: g) max: b).
	min _ ((r min: g) min: b).
	span _ (max - min) asFloat.
	span = 0.0 ifTrue: [ ^ 0.0 ].

	r = max ifTrue: [
		h _ ((g - b) asFloat / span) * 60.0.
	] ifFalse: [
		g = max
			ifTrue: [ h _ 120.0 + (((b - r) asFloat / span) * 60.0). ]
			ifFalse: [ h _ 240.0 + (((r - g) asFloat / span) * 60.0). ].
	].

	h < 0.0 ifTrue: [ h _ 360.0 + h ].
	^ h!
red
	"Answer my red component, a float in the range [0.0..1.0].  

Don't confuse this with the class message (Color red) that returns the color pure red.  6/13/96 tk"

	^ self privateRed asFloat / ComponentMax!
saturation
	"Return the saturation of this color, a value between 0.0 and 1.0."

	| r g b max min |
	r _ self privateRed.
	g _ self privateGreen.
	b _ self privateBlue. 

	max _ ((r max: g) max: b).
	min _ ((r min: g) min: b).
	max = 0
		ifTrue: [ ^ 0.0 ]
		ifFalse: [ ^ (max - min) asFloat / max asFloat ].
! !

!Color methodsFor: 'groups of shades'!
darkShades: thisMany
	"An array of thisMany colors from black to the receiver.  Array is of length num. Very useful for displaying color based on a variable in your program.  6/18/96 tk"

	^ self class black mix: self shades: thisMany

"| a r |  a _ (Color red darkShades: 10).  
	r _ 0@0 extent: 30@30.
	a do: [:each |
		r moveBy: 30@0.
		Display fill: r fillColor: each].
"!
lightShades: thisMany
	"An array of thisMany colors from white to self. Very useful for displaying color based on a variable in your program.  6/18/96 tk"

	^ self class white mix: self shades: thisMany

"| a r |  a _ (Color red lightShades: 10).  
	r _ 0@0 extent: 30@30.
	a do: [:each |
		r moveBy: 30@0.
		Display fill: r fillColor: each].
"!
mix: color2 shades: thisMany
	"Return an array of thisMany colors from self to color2. Very useful for displaying color based on a variable in your program.  6/18/96 tk"

	| redInc greenInc blueInc rr gg bb c out |
	thisMany = 1 ifTrue: [^ Array with: color2].
	redInc _ color2 red - self red / (thisMany-1).
	greenInc _ color2 green - self green / (thisMany-1).
	blueInc _ color2 blue - self blue / (thisMany-1).
	rr _ self red.  gg _ self green.  bb _ self blue.
	out _ (1 to: thisMany) collect: [:num |
		c _ Color r: rr g: gg b: bb.
		rr _ rr + redInc.
		gg _ gg + greenInc.
		bb _ bb + blueInc.
		c].
	out at: out size put: color2.	"hide roundoff errors"
	^ out

"| a r |  a _ (Color red mix: Color green shades: 10).  
	r _ 0@0 extent: 30@30.
	a do: [:each |
		r moveBy: 30@0.
		Display fill: r fillColor: each].
"!
wheel: thisMany
	"An array of thisMany colors around the color wheel starting at self and ending all the way around the hue space just before self.  Array is of length thisMany.  Very useful for displaying color based on a variable in your program.  6/18/96 tk"

	| sat bri hue step c |
	thisMany = 1 ifTrue: [^ Array with: self].
	sat _ self saturation.
	bri _ self brightness.
	hue _ self hue.
	step _ 360.0/thisMany.
	^ (1 to: thisMany) collect: [:num |
		c _ Color hue: hue saturation: sat brightness: bri.
		hue _ hue + step.	"it does mod 360"
		c].


"| a r |  a _ (Color blue wheel: 20).  
	r _ 0@0 extent: 30@30.
	a do: [:each |
		r moveBy: 30@0.
		Display fill: r fillColor: each].
"! !

!Color methodsFor: 'equality'!
= aColor
	^ aColor isColor and: [aColor rgb = rgb]!
hash

	^ rgb!
isColor
	^ true! !

!Color methodsFor: 'transformations'!
* aFactor
	"Answer this color with its RGB multiplied by aFactor or a vector of factors.  Try:
	((Color white) * 0.3) display		 a darkish gray.  
	((Color blue) * #(0 0 0.9)) display	slightly less than blue.  6/18/96 tk"

(aFactor isKindOf: Number) ifTrue: [
	^ Color
		red: ((self red * aFactor) min: 1.0 max: 0.0)
		green: ((self green * aFactor) min: 1.0 max: 0.0)
		blue: ((self blue * aFactor) min: 1.0 max: 0.0)].

"(aFactor isKindOf: ArrayedCollection) ifTrue: ["
	^ Color
		red: ((self red * (aFactor at: 1)) min: 1.0 max: 0.0)
		green: ((self green * (aFactor at: 2)) min: 1.0 max: 0.0)
		blue: ((self blue * (aFactor at: 3)) min: 1.0 max: 0.0).
!
+ aColor
	"Answer this color mixed with the given color. Additive color mixing.  6/18/96 tk"

	^ Color
		red: ((self red + aColor red) min: 1.0 max: 0.0)
		green: ((self green + aColor green) min: 1.0 max: 0.0)
		blue: ((self blue + aColor  blue) min: 1.0 max: 0.0)
!
- aColor
	"Answer aColor is subtracted from the given color.  Removing color in an additive color space.  6/18/96 tk"

	^ Color
		red: ((self red - aColor red) min: 1.0 max: 0.0)
		green: ((self green - aColor green) min: 1.0 max: 0.0)
		blue: ((self blue - aColor  blue) min: 1.0 max: 0.0)
!
/ aFactor
	"Answer this color with its RGB divided by aFactor or a vector of factors.  Try:
	((Color white) / 3) display		 a darkish gray.  
	((Color white) / #(1 1 2)) display	slightly less than blue.  6/18/96 tk"

(aFactor isKindOf: Number) ifTrue: [
	^ Color
		red: ((self red / aFactor) min: 1.0 max: 0.0)
		green: ((self green / aFactor) min: 1.0 max: 0.0)
		blue: ((self blue / aFactor) min: 1.0 max: 0.0)].

"(aFactor isKindOf: ArrayedCollection) ifTrue: ["
	^ Color
		red: ((self red / (aFactor at: 1)) min: 1.0 max: 0.0)
		green: ((self green / (aFactor at: 2)) min: 1.0 max: 0.0)
		blue: ((self blue / (aFactor at: 3)) min: 1.0 max: 0.0).
!
alpha: alphaValue
	^ TranslucentColor new setRgb: rgb alpha: alphaValue!
darker
	"Return a lighter shade of the same color.  1/6th towards white. 6/18/96 tk  Should this be an absolute step, instead of relative?"
	^ self mixed: 5/6 with: Color black!
hsvScaleBy: anArray
	"Scale hue, saturation, and brightness by this factor.  Useful for varying brightness under program control.  6/24/96 tk"

	^ Color
		hue: (self hue * (anArray at: 1))	"it does mod 360"
		saturation: ((self saturation * (anArray at: 2)) min: 1.0 max: 0.0)
		brightness: ((self brightness * (anArray at: 3)) min: 1.0 max: 0.0).
!
lighter
	"Return a lighter shade of the same color.  1/6th towards white. 6/18/96 tk  Should this be an absolute step, instead of relative?"
	^ self mixed: 5/6 with: Color white!
mixed: proportion with: aColor
	"Answer this color mixed with the given color. The proportion,
	 a number between 0.0 and 1.0, determines what what fraction
	 of the receiver to use in the mix. For example, 0.9 would yield
	 a color close to the receiver."
	"Details: This method uses RGB interpolation; HSV interpolation
	 can lead to surprises."

	| frac1 frac2 |
	frac1 _ proportion asFloat min: 1.0 max: 0.0.
	frac2 _ 1.0 - frac1.
	^ Color
		red: (self    red * frac1) + (aColor    red * frac2) 
		green: (self green * frac1) + (aColor green * frac2) 
		blue: (self   blue * frac1) + (aColor  blue * frac2)
! !

!Color methodsFor: 'conversions'!
bitPatternForDepth: depth
	"The raw call on BitBlt needs a Bitmap to represent this color.  Return the color at the destination Form depth as a Bitmap.  Pattern returns a longer Bitmap.  6/14/96 tk
	For the bits that are in a single pixel, use pixelValueAtDepth:.
	For a 32-bit integer of (32/depth) pixels, use pixelWordAtDepth:"

	depth == cachedDepth ifTrue: [^ cachedBitPattern].
	cachedDepth _ depth.

	depth > 1 ifTrue: [^ cachedBitPattern _ Bitmap with: (self pixelWordForDepth: depth)].

	"Spatial halftone for gray for depth 1"
	self = Black ifTrue: [^ cachedBitPattern _ Bitmap with: 16rFFFFFFFF].
	self = White ifTrue: [^ cachedBitPattern _ Bitmap with: 16r0].
	self = Gray ifTrue: [^ cachedBitPattern _ Bitmap with: 16r55555555 with: 16rAAAAAAAA].
	self = LightGray ifTrue: [^ cachedBitPattern _ Bitmap with: 16r44444444 with: 16r11111111].
	self = DarkGray ifTrue: [^ cachedBitPattern _ Bitmap with: 16rBBBBBBBB with: 16rEEEEEEEE].
	^ cachedBitPattern _ Bitmap with: 16r0.	"everything else"!
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. 6/19/96 tk"

	| p col r g b rdiff gdiff bdiff diff |
	p _ self pixelValueForDepth: d.
	col _ Color colorFromPixelValue: p depth: d.
	r _ self privateRed.  g _ self privateGreen.  b _ self privateBlue.
	rdiff _ r - col privateRed.
	gdiff _ g - col privateGreen.
	bdiff _ b - col privateBlue.
	diff _ (rdiff*rdiff) + (gdiff*gdiff) + (bdiff*bdiff).
	^ diff asFloat sqrt / 1771.89		"= (1023*1023*3) sqrt" !
mapIndexForDepth: d
	"Return the index corresponding to this color in a 512-entry color transformation map. RGB forms collapse to 3 bits per color when indexing into such a colorMap."

	| colorValue bpc r g b |
	colorValue _ self pixelValueForDepth: d.
	d <= 8 ifTrue: [ ^ colorValue + 1 ].
	d = 16
		ifTrue: [ bpc _ 5 ]  "5 bits per color"
		ifFalse: [ bpc _ 8 ].  "8 bits per color"

	r _ (colorValue bitShift: 3 - bpc - bpc - bpc) bitAnd: 7.
	g _ (colorValue bitShift: 3 - bpc - bpc) bitAnd: 7.
	b _ (colorValue bitShift: 3 - bpc) bitAnd: 7.
	^ (r bitShift: 6) + (g bitShift: 3) + b + 1
	"Is this pre or post G and B switch???"!
name
	"Look to see if this Color has a name.  Must be an exact match of color. 6/19/96 tk"
	ColorNames do: [:each | 
		(Color perform: each) = self ifTrue: [
			^ each]].
	^ nil!
originate: aPoint on: destForm
	"Answer a new Color whose bits have been wrapped around
	in represent a stipple.  We are not a stipple.  6/24/96 tk"

	^ self!
pixelValue: val toBitPatternDepth: depth
	"convert to a 32 bit quantity.  Covers 32//depth pixels. Dan's method 6/22/96 tk"

	depth = 32 ifTrue: [^ Bitmap with: val].
	^ Bitmap with: ((val bitAnd: (1 bitShift: depth) - 1) * 
		(#(16rFFFFFFFF  "replicate for every bit"
			16r55555555 -	"2 bits"
			16r11111111 - - -  "4 bits"
			16r01010101 - - - - - - -  "8 bits"
			16r00010001) at: depth))

"The above gives the same result as this explanation:
	| d word |
	d _ depth.
	word _ val.
	[d >= 32] whileFalse: [
		word _ word bitOr: (word bitShift: d).
		d _ d+d].
	^ Bitmap with: word
"!
pixelValue: val toPixelWordDepth: depth
	"convert to a 32 bit quantity.  Covers 32//depth pixels. 6/14/96 tk"
	| d word |
	d _ depth.
	word _ val.
	[d >= 32] whileFalse: [
		word _ word bitOr: (word bitShift: d).
		d _ d+d].
	^ word
!
pixelValueForDepth: d
	"Answer bits that appear in ONE pixel of this color in a Bitmap of the given depth. The depth must be one of 1, 2, 4, 8, 16, or 32.  Returns an integer.  Contrast with pixelWordForDepth: and bitPatternForDepth:.  Inverse is the class message colorFromPixelValue:depth:"
	"Details: For depths of 8 or less, the result is a colorMap index (zero order). For depths of 16 and 32, it is a direct color with 5 or 8 bits per color component.  6/1/96 jm, 6/14/96 tk"

	d < 8 ifTrue: [ ^ self closestPixelValueDepth: d ].
	d = 8 ifTrue: [ ^ self closestPixelValue8 ].

	d = 16 ifTrue: [
		"five bits per component; top bits ignored"
		^ (((rgb bitShift: Depth16RedShift) bitAnd: 16r7C00) bitOr:
			 ((rgb bitShift: Depth16GreenShift) bitAnd: 16r03E0)) bitOr:
			 ((rgb bitShift: Depth16BlueShift) bitAnd: 16r001F).
	].

	d = 32 ifTrue: [
		"eight bits per component; top 8 bits ignored"
		^ (((rgb bitShift: Depth32RedShift) bitAnd: 16rFF0000) bitOr:
			 ((rgb bitShift: Depth32GreenShift) bitAnd: 16r00FF00)) bitOr:
			 ((rgb bitShift: Depth32BlueShift) bitAnd: 16r0000FF).
	].

	self error: 'unknown pixel depth: ', d printString

!
pixelWordForDepth: depth
	"Answer bits that appear in a 32-bit word of a Bitmap of the given depth. This may represent between 32 and 1 pixels, depending on the depth.  The depth must be one of 1, 2, 4, 8, 16, or 32.  Returns an integer."
	| word d |
	word _ self pixelValueForDepth: depth.
	d _ depth.
	[d >= 32] whileFalse: [
		word _ word bitOr: (word bitShift: d).
		d _ d+d].
	^ word! !

!Color methodsFor: 'printing'!
printOn: aStream

	aStream
		nextPutAll: 'Color(';
		nextPutAll: (self red roundTo: 0.001) printString;
		nextPutAll: ', ';
		nextPutAll: (self green roundTo: 0.001) printString;
		nextPutAll: ', ';
		nextPutAll: (self blue roundTo: 0.001) printString;
		nextPutAll: ')'.
!
storeOn: aStream

	aStream
		nextPutAll: '(Color r:';
		nextPutAll: (self red roundTo: 0.001) printString;
		nextPutAll: ' g: ';
		nextPutAll: (self green roundTo: 0.001) printString;
		nextPutAll: ' b: ';
		nextPutAll: (self blue roundTo: 0.001) printString;
		nextPutAll: ')'.
! !

!Color methodsFor: 'private'!
closestColor1
	"Return the nearest approximation to this color for a monochrome Form.
	Should this be based on r+g+b?  Should it be L. lightness, in L*a*b* space? 6/14/96 tk"

	self halt. "old"
	self brightness > 0.5
		ifTrue: [ ^ 0 ]
		ifFalse: [ ^ 1 ].!
closestColor2
	"Return the nearest approximation to this color for a 2-bit deep Form."

	| b |
	self halt. "old"
	self = PureYellow ifTrue: [ ^ 16rFFFFFFFF ].
	b _ self brightness.
	b >= 0.75 ifTrue: [ ^ 0 ].
	b <= 0.25 ifTrue: [ ^ 16r55555555 ].
	^ 16rAAAAAAAA!
closestColor4
	"Return the nearest approximation to this color for a 4-bit deep Form."

	| bIndex |
	self halt. "old"
	self = PureYellow ifTrue: [ ^ 16r33333333 ].
	self = PureRed ifTrue: [ ^ 16r44444444 ].
	self = PureGreen ifTrue: [ ^ 16r55555555 ].
	self = PureBlue ifTrue: [ ^ 16r66666666 ].
	self = PureCyan ifTrue: [ ^ 16r77777777 ].
	self = PureMagenta ifTrue: [ ^ 16r88888888 ].

	bIndex _ (self brightness * 8.0) rounded.  "bIndex in [0..8]"
	^ #(
		16r11111111			"black"
		16r99999999			"7/8 gray"
		16rAAAAAAAA	"6/8 gray"
		16rBBBBBBBB		"5/8 gray"
		16rCCCCCCCC		"4/8 gray"
		16rDDDDDDDD		"3/8 gray"
		16rEEEEEEEE		"2/8 gray"
		16rFFFFFFFF		"1/8 gray"
		16r00000000			"white"
	) at: bIndex + 1

!
closestColor8
	"Return the nearest approximation to this color for an 8-bit deep Form."

	 ^ IndexedColors at: (self closestPixelValue8)+1!
closestColor8old
	"Return the nearest approximation to this color for an 8-bit deep Form."

	| bIndex p n |
	self isGray ifTrue: [
		"select nearest gray"
		p _ GrayToIndexMap at: (self privateBlue >> 2) + 1.
	] ifFalse: [
		"compute nearest entry in the color cube"
		p _ ((((self privateRed    * 5) + HalfComponentMask) // ComponentMask) * 36) +
			 ((((self privateBlue * 5) + HalfComponentMask) // ComponentMask) *  6) +
			 (((self privateGreen    * 5) + HalfComponentMask) // ComponentMask) + 40.
	].
	^ (p bitShift: 24) bitOr: ((p bitShift: 16) bitOr: ((p bitShift: 8) bitOr: p))!
"** 1. not used
	2. 1 to: (1 bitShift: depth) ??
"
closestColorDepth: depth
	"Return the nearest approximation to this color for this depth of Form.  Depth can be 1, 2, 4, or 8.  This method is for when we go to L*a*b* color space.  For now use the faster version. 6/14/96 tk"
	|  least r g b col rdiff gdiff bdiff diff leastIndex |
	depth > 8 ifTrue: [^ self error: 'depth must be 1, 2, 4, or 8'].
	least _ ComponentMask*ComponentMask*3.	"start with max"
	r _ self privateRed.  g _ self privateGreen.  b _ self privateBlue.
	1 to: (1 bitShift: depth) - 1 do: [:ind |
		col _ IndexedColors at: ind.
		rdiff _ r - col privateRed.
		gdiff _ g - col privateGreen.
		bdiff _ b - col privateBlue.
		diff _ (rdiff*rdiff) + (gdiff*gdiff) + (bdiff*bdiff).
		diff < least ifTrue: [
			least _ diff.
			leastIndex _ ind]].
	^ IndexedColors at: leastIndex!
closestPixelValue1
	"Return the nearest approximation to this color for a monochrome Form.
	Should this be based on r+g+b?  Should it be L. lightness, in L*a*b* space? 6/14/96 tk"

	self brightness > 0.5
		ifTrue: [ ^ 0 ]
		ifFalse: [ ^ 1 ].!
closestPixelValue8
	"Return the index in the standard 8-bit colormap for the nearest match to this color.  Find the closest color in our 6x6x6 color cube.  See if any of the grays are closer to the real color.  6/14/96 tk"
	| r g b rr gg bb diff gray val diffg diffc pvtGray rd gd bd |

	rgb = 0 ifTrue: [^ 1].	"Special case for black, very common"
	rgb = 16r3FFFFFFF ifTrue: [^ 0].
		"Special case for white, very common"
	"Find the closest color in our 6x6x6 color cube. Integers in [0..5]" 
	r _ (((self privateRed    * 5) + HalfComponentMask) // ComponentMask).
	g _ (((self privateGreen * 5) + HalfComponentMask) // ComponentMask).
	b _ (((self privateBlue    * 5) + HalfComponentMask) // ComponentMask).

	rr _ self privateRed.  gg _ self privateGreen.  bb _ self privateBlue.
	diff _ ((rr-gg)*(rr-gg)) + ((gg-bb)*(gg-bb)) + ((bb-rr)*(bb-rr)).	"least squares"
	"If diff is big, r g and b not very close, not very much like a gray.  One 6x6x6 step is 1023.0 / 5.0 = 204.6.  Squared is 204.6 * 204.6 =  41861.2
	 Return a color from our cube that starts at index 40." 
	diff >= 41861 ifTrue: [^ (r * 36) + (b * 6) + g + 40].

	"Consider using a gray"
	pvtGray _ rr+gg+bb //3.		"[0..1023]"
	gray _ (((pvtGray* 32) + HalfComponentMask) // ComponentMask).
		"33 discrete gray levels [0..32]"
	val _ pvtGray.
	"Do error comparison in 1023 space"
	diffg _ ((val - rr)*(val - rr)) + ((val - gg)*(val - gg)) + 
			((val - bb)*(val - bb)).	"error in the Gray"

	"Color in the cube [0..5], blown back up to [0..1023] with error"
	rd _ (r * ComponentMask) // 5.	
	gd _ (g * ComponentMask) // 5.
	bd _ (b * ComponentMask) // 5.
	diffc _ ((rd - rr)*(rd - rr)) + ((gd - gg)*(gd - gg)) + ((bd - bb)*(bd - bb)).
			"error in the color from the cube"
	"self halt."
	diffg < diffc
		ifTrue: ["33 grays.  eighths starting at index 9, 32nds from 16 to 39"
			^ #(1 16 17 18 9 19 20 21 10 22 23 24 11 25 26 27 12 
				 28 29 30 13 31 32 33 14 34 35 36 15 37 38 39 0) at: gray+1]
		ifFalse: [^ (r * 36) + (b * 6) + g + 40]
!
closestPixelValueDepth: depth
	"Return the nearest approximation to this color for this depth of Form.  Depth can be 1, 2, 4, or 8.  This method is for when we go to L*a*b* color space.  For now use the faster version. 6/14/96 tk"
	|  least r g b col rdiff gdiff bdiff diff leastIndex |

	depth > 256 ifTrue: [^ self error: 'depth must be 1, 2, 4, or 8'].
	least _ ComponentMask*ComponentMask*3 + 100.		"start with max"
	r _ self privateRed.  g _ self privateGreen.  b _ self privateBlue.
	0 to: (1 bitShift: depth) - 1 do: [:ind |
		col _ IndexedColors at: ind+1.
		rdiff _ r - col privateRed.
		gdiff _ g - col privateGreen.
		bdiff _ b - col privateBlue.
		diff _ (rdiff*rdiff) + (gdiff*gdiff) + (bdiff*bdiff).
		diff < least ifTrue: [
			least _ diff.
			leastIndex _ ind]].
	^ leastIndex!
closestPixelWord1
	"Return the nearest approximation to this color for a monochrome Form.  6/14/96 tk"

	self brightness > 0.5
		ifTrue: [ ^ 0 ]
		ifFalse: [ ^ 16rFFFFFFFF ].	"32 pixels by 1 bit each"!
closestPixelWord2
	"Return the nearest approximation to this color for a 2-bit deep Form."

	| b |
	self = PureYellow ifTrue: [ ^ 16rFFFFFFFF ].	"16 pixels by 2 bits each"
	b _ self brightness.
	b >= 0.75 ifTrue: [ ^ 0 ].
	b <= 0.25 ifTrue: [ ^ 16r55555555 ].
	^ 16rAAAAAAAA!
isGray
	"Find least squared distance of r, g, b from one another. 6/18/96 tk"

	| rr gg bb diff |
	rr _ self privateRed.  gg _ self privateGreen.  bb _ self privateBlue.
	diff _ ((rr-gg)*(rr-gg)) + ((gg-bb)*(gg-bb)) + ((bb-rr)*(bb-rr)). 		"least squares"
	"If diff is big, r g and b not very close, not very much like a gray.  One 6x6x6 step is 1023.0 / 5.0 = 204.6.  Squared is 204.6 * 204.6 =  41861.2
If closer than that, its more a gray than a color." 
	^ diff < 41861!
privateBlue
	"Private!! Answer the internal representation of my blue component."

	^ rgb bitAnd: ComponentMask!
privateGreen
	"Private!! Answer the internal representation of my green component."

	^ (rgb >> GreenShift) bitAnd: ComponentMask!
privateRed
	"Private!! Answer the internal representation of my red component."

	^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask!
rgb
	^ rgb!
setHue: hue saturation: saturation brightness: brightness
	"Initialize this color to the given hue, saturation, and brightness. See the comment in the instance creation method for details."

	| s v h i f p q t |
	s _ (saturation asFloat max: 0.0) min: 1.0.
	v _ (brightness asFloat max: 0.0) min: 1.0.

	"zero saturation yields gray with the given brightness"
	s = 0.0 ifTrue: [ ^ self setRed: v green: v blue: v ].

	h _ (hue \\ 360) asFloat / 60.0.
	(0.0 > h) ifTrue: [ h _ 6.0 + h ].
	i _ h asInteger.  "integer part of hue"
	f _ h - i.         "fractional part of hue"
	p _ (1.0 - s) * v.
	q _ (1.0 - (s * f)) * v.
	t _ (1.0 - (s * (1.0 - f))) * v.

	0 = i ifTrue: [ ^ self setRed: v green: t blue: p ].
	1 = i ifTrue: [ ^ self setRed: q green: v blue: p ].
	2 = i ifTrue: [ ^ self setRed: p green: v blue: t ].
	3 = i ifTrue: [ ^ self setRed: p green: q blue: v ].
	4 = i ifTrue: [ ^ self setRed: t green: p blue: v ].
	5 = i ifTrue: [ ^ self setRed: v green: p blue: q ].

	self error: 'implementation error'.
!
setRed: r green: g blue: b
	"Initialize this color's r, g, and b components to the given values in [0.0..1.0].  Encoded in a single variable as 3 integers [0..1023].
	A color is essentially immutable.  Once you set red, green, and blue, you cannot change them.  Instead, create a new Color and use it.
	6/18/96 tk"

	rgb == nil ifFalse: [^ self error: 'Can''t change a Color.  Please make a new one'].
	rgb _
		(((r * ComponentMax) rounded bitAnd: ComponentMask) bitShift: RedShift) +
		(((g * ComponentMax) rounded bitAnd: ComponentMask) bitShift: GreenShift) +
		 ((b * ComponentMax) rounded bitAnd: ComponentMask)!
setRed: r green: g blue: b range: zeroToThis
	"Initialize this color's r, g, and b components to the given values in [0.0..1.0].  Range is [0..r], a weird numbering system with size r+epsilon, min 0, max r.  6/14/96 tk"
	| range |

	range _ zeroToThis.
	rgb == nil ifFalse: [^ self error: 'Can''t write into a Color.  Make a new one'].
	rgb _
		((((r * ComponentMask) // range) bitAnd: ComponentMask) bitShift: RedShift) +
		((((g * ComponentMask) // range) bitAnd: ComponentMask) bitShift: GreenShift) +
		 (((b * ComponentMask) // range) bitAnd: ComponentMask)! !

!Color methodsFor: 'testing--to be removed'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Color class
	instanceVariableNames: ''!

!Color class methodsFor: 'colors'!
allColorsForDepth: d
	"Return the colorMap for the depth.  Use a ColorGenerator to simulate a very big Array for 16 and 32.  6/22/96 tk"

	d < 16 ifTrue: [^ IndexedColors copyFrom: 1 to: (1 bitShift: d)].
	^ ColorGenerator new depth: d!
black
	^Black!
blue
	^Blue!
cyan
	^Cyan!
darkGray
	^DarkGray!
gray
	^Gray!
green
	^Green!
lightBlue
	^LightBlue!
lightBrown
	^LightBrown!
lightCyan
	^LightCyan!
lightGray
	^LightGray!
lightGreen
	^LightGreen!
lightMagenta
	^LightMagenta!
lightOrange
	^LightOrange!
lightRed
	^LightRed!
lightYellow
	^LightYellow!
magenta
	^Magenta!
named: newName put: aColor
	"Add a new color to the list and create an access message and a class variable for it.  The name should start with a lowercase letter.  (The class variable will start with an uppercase letter.)  (Color names) gives a list of the colors.  6/13/96 tk"
	| str cap sym accessor csym |
	(aColor isKindOf: self) ifFalse: [^ self error: 'not a Color'].
	str _ newName asString.
	sym _ str asSymbol.
	cap _ str copy.
	cap at: 1 put: (cap at: 1) asUppercase.
	csym _ cap asSymbol.
	(self class canUnderstand: sym) ifFalse: [
		"define access message"
		accessor _ str, (String with: Character cr with: Character tab), 			'^', cap.
		self class compile: accessor
			classified: 'colors'].
	(self classPool includesKey: csym) ifFalse: [
		self addClassVarName: cap].
	(ColorNames includes: sym) ifFalse: [
		ColorNames add: sym].
	^ self classPool at: csym put: aColor!
names
	"Return a list of names of colors.  An OrederdCollection of symbols.  6/14/96 tk
	  Color perform: (Color names at: 1)	"
	^ ColorNames!
red
	^Red!
veryDarkGray
	^VeryDarkGray!
veryLightGray
	^VeryLightGray!
white
	^White!
yellow
	^Yellow! !

!Color class methodsFor: 'instance creation'!
colorChartForDepth: depth extent: chartExtent
	"Displays a color palette using abstract colors.  fromUser can then save it.  Different for each depth.  6/26/96 tk
	Modified to produce a form of variable size instead of being
	fixed-size and running on the display 8/20/96 di"
	"(Color colorChartForDepth: Display depth extent: 720@100) display"
	| c p f nSteps rect w h |
	f _ Form extent: chartExtent depth: depth.
	nSteps _ depth>8 ifTrue: [12] ifFalse: [6].
	w _ chartExtent x // (nSteps*nSteps).
	h _ chartExtent y - 20 // nSteps.
	0 to: nSteps-1 do: [:r |
		0 to: nSteps-1 do: [:g |
			0 to: nSteps-1 do: [:b |
				c _ self red: r green: g blue: b range: nSteps-1.
				rect _ ((r*nSteps*w) + (b*w)) @ (g*h) extent: w@(h+1).
				f fill: rect fillColor: c].
			].
		].
	p _ chartExtent x // 3 @ (chartExtent y - 20).
	w _ chartExtent x - p x - 20 / 100.
	0 to: 99 do:
		[ :v | c _ self red: v green: v blue: v range: 99.
		f fill: ((v*w)@0 + p extent: (w+1)@20) fillColor: c].
	^ f!
colorFromPixelValue: p depth: d
	"Convert a pixel value for the given display depth into a color."
	"Details: For depths of 8 or less, the pixel value is simply looked
	 up in a table. For depths of 16 and 32, the color components are
	 extracted and converted into a color."

	| r g b |
	d = 1 ifTrue: [ ^ IndexedColors at: (p bitAnd: 16r01) + 1 ].
	d = 2 ifTrue: [ ^ IndexedColors at: (p bitAnd: 16r03) + 1 ].
	d = 4 ifTrue: [ ^ IndexedColors at: (p bitAnd: 16r0F) + 1 ].
	d = 8 ifTrue: [ ^ IndexedColors at: (p bitAnd: 16rFF) + 1 ].

	d = 16 ifTrue: [
		"five bits per component; top bit ignored"
		r _ (p bitShift: -10) bitAnd: 16r1F.
		g _ (p bitShift:  -5) bitAnd: 16r1F.
		b _ p bitAnd: 16r1F.
		^ self red: r green: g blue: b range: 31
	].

	d = 32 ifTrue: [
		"eight bits per component; top 8 bits ignored"
		r _ (p bitShift: -16) bitAnd: 16rFF.
		g _ (p bitShift:  -8) bitAnd: 16rFF.
		b _ p bitAnd: 16rFF.
		^ self red: r green: g blue: b range: 255
	].

	self error: 'unknown pixel depth: ', d printString
!
fromUser
	"Displays a color palette using abstract colors, then waits for a mouse click. Try it at various display depths!!"
	"Color fromUser"
	| save d c rect old new s p |
	d _ Display depth.
	((ColorChart == nil) or: [ColorChart depth ~= Display depth]) 
		ifTrue: [ColorChart _ self colorChartForDepth: d extent: 720@100].
	save _ Form fromDisplay: (0@0 extent: ColorChart extent).
	ColorChart displayAt: 0@0.

	old _ 0.
	[Sensor anyButtonPressed] whileFalse: [
		p _ Display pixelValueAt: Sensor cursorPoint.
		c _ self colorFromPixelValue: p depth: d.
		Display fill: (0@80 extent: 60@20) fillColor: c.
		(new _ p) = old ifFalse: [
			Display fillWhite: (60@80 extent: 180@20).
			s _ c printString.
			s _ 'R,G,B = ', (s copyFrom: 7 to: s size - 1).
			s displayAt: 63@83.
			old _ new.
		].
	].
	save displayAt: 0@0.
	Sensor waitNoButton.
	^ c
!
hotColdShades: thisMany
	"An array of thisMany colors showing temperature from blue to red to white hot.  (Later improve this by swinging in hue.)  6/19/96 tk"

| n s1 s2 s3 s4 s5 |
thisMany < 5 ifTrue: [^ self error: 'must be at least 5 shades'].
n _ thisMany // 5.
s1 _ self white mix: self yellow shades: (thisMany - (n*4)).
s2 _ self yellow mix: self red shades: n+1.
s2 _ s2 copyFrom: 2 to: n+1.
s3 _ self red mix: self green darker shades: n+1.
s3 _ s3 copyFrom: 2 to: n+1.
s4 _ self green darker mix: self blue shades: n+1.
s4 _ s4 copyFrom: 2 to: n+1.
s5 _ self blue mix: self black shades: n+1.
s5 _ s5 copyFrom: 2 to: n+1.
^ s1,s2,s3,s4,s5

"| a r |  a _ (Color hotColdShades: 25).  
	r _ 0@0 extent: 30@30.
	a do: [:each |
		r moveBy: 30@0.
		Display fill: r fillColor: each].
"!
hue: hue saturation: saturation brightness: brightness
	"Create a color with the given hue, saturation, and brightness. Hue is given as the angle in degrees of the color on the color circle where red is zero degrees. Saturation and brightness are numbers in [0.0..1.0] where larger values are more saturated or brighter colors. For example:

	Color new setHue: 0 saturation: 1 brightness: 1

is pure red."

	^ self basicNew setHue: hue saturation: saturation brightness: brightness!
new

	^ self basicNew setRed: 0.0 green: 0.0 blue: 0.0!
r: r g: g b: b
	"Return a color with the given r, g, and b components."

	^ self basicNew setRed: r green: g blue: b!
r: r g: g b: b alpha: alpha
	^ (self r: r g: g b: b) alpha: alpha!
random

	^ self basicNew
		setHue: (360.0 * RandomStream next)
		saturation: (0.3 + (RandomStream next * 0.7))
		brightness: (0.4 + (RandomStream next * 0.6))!
red: r green: g blue: b
	"Return a color with the given r, g, and b components."

	^ self basicNew setRed: r green: g blue: b!
red: r green: g blue: b range: range
	"Return a color with the given r, g, and b components specified as integers in the range [0..r]. This avoids the floating point arithmetic in the red:green:blue: message and is thus a bit faster for certain applications (such as computing a sequence of colors for a palette)."

	^ self basicNew setRed: r green: g blue: b range: range! !

!Color class methodsFor: 'misc'!
makeColorMap: colorArray depth: bitsPerPixel
	"colorArray is now an Array of (256) Colors that the picture wants to use.  We have a fixed palette of 256 Colors.  Convert each to the closest of our colors and return a mapping vector.  Note we use zero-order (0-255) colors here.  6/24/96 tk"

	bitsPerPixel > 8 ifTrue: [self error: 'Unknown depth'].
		"GIFs can't come in 16, 24, or 32"
		"later deal with 3,4,5,6,7 bit deep GIFs"
	^ colorArray collect: [:color | 
		color pixelValueForDepth: bitsPerPixel].
!
quickHighLight: depth
	"Quickly return a Bitblt-ready raw colorValue for highlighting areas.  6/22/96 tk"

	^ HighLightBitmaps at: depth! !

!Color class methodsFor: 'class initialization'!
indexedColors

	^ IndexedColors!
initialize
	"Color initialize"

	"Details: Externally, the red, green, and blue components of color
	are floats in the range [0.0..1.0]. Internally, they are represented
	as integers in the range [0..ComponentMask] packing into a
	small integer to save space and to allow fast hashing and
	equality testing.

	For a general description of color representations for computer
	graphics, including the relationship between the RGB and HSV
	color models used here, see Chapter 17 of Foley and van Dam,
	Fundamentals of Interactive Computer Graphics, Addison-Wesley,
	1982."

	ComponentMask _ 1023.
	HalfComponentMask _ 512.  "used to round up in integer calculations"
	ComponentMax _ 1023.0.  "a Float used to normalize components"
	RedShift _ 20.
	GreenShift _ 10.
	BlueShift _ 0.

	Depth16RedShift		_ (5-10) * 3.	"bits"
	Depth16GreenShift	_ (5-10) * 2.
	Depth16BlueShift	_ 5-10.

	Depth32RedShift		_ (8-10) * 3.	"bits"
	Depth32GreenShift	_ (8-10) * 2.
	Depth32BlueShift	_ 8-10.

	PureRed		 _ self red: 1 green: 0 blue: 0.
	PureGreen	 _ self red: 0 green: 1 blue: 0.
	PureBlue	 _ self red: 0 green: 0 blue: 1.
	PureYellow	 _ self red: 1 green: 1 blue: 0.
	PureCyan	 _ self red: 0 green: 1 blue: 1.
	PureMagenta _ self red: 1 green: 0 blue: 1.

	RandomStream _ Random new.

	self initializeIndexedColors.
	self initializeGrayToIndexMap.
	self initializeNames.
	self initializeHighLights.!
initializeGrayToIndexMap
	"Build an array of gray values available in the fixed colormap. This array is used
	 to map from a pixel value back to its color."
	"Note: This must be called after initializeIndexedColors, since it uses IndexedColors."
	"Color initializeGrayToIndexMap"

	| grayLevels grayIndices c distToClosest dist indexOfClosest |
	"record the level and index of each gray in the 8-bit color table"
	grayLevels _ OrderedCollection new.
	grayIndices _ OrderedCollection new.
	1 to: IndexedColors size do: [ :i |
		c _ IndexedColors at: i.
		c saturation = 0.0 ifTrue: [
			grayLevels add: (c privateBlue) >> 2.
			grayIndices add: i - 1.  "hardward colormap is 0-based"
		].
	].
	grayLevels _ grayLevels asArray.
	grayIndices _ grayIndices asArray.

	"for each gray level in [0..255], select the closest match"
	GrayToIndexMap _ ByteArray new: 256.
	0 to: 255 do: [ :level |
		distToClosest _ 10000.  "greater than distance to any real gray"
		1 to: grayLevels size do: [ :i |
			dist _ (level - (grayLevels at: i)) abs.
			dist < distToClosest ifTrue: [
				distToClosest _ dist.
				indexOfClosest _ grayIndices at: i.
			].
		].
		GrayToIndexMap at: (level + 1) put: indexOfClosest.
	].

	
!
initializeHighLights
	"Special set of very fast colors (Bitmaps) for highlighting text and areas without converting colors. 6/22/96 tk
	Color initializeHighLights"

"A default color that will at least reverse most bits"
| v |
HighLightBitmaps _ Array new: 32.
#(1 2 4 8 16 32) do: [:depth |
	v _ depth <= 8
		ifTrue: [self new pixelValue: (#(1 3 0 5 0 0 0 8) at: depth)
					toBitPatternDepth: depth]
		ifFalse: [Bitmap with: 16rFFFFFFFF].
	HighLightBitmaps at: depth put: v].!
initializeIndexedColors
	"Build an array of colors corresponding to the fixed colormap used
	 for display depths of 1, 2, 4, or 8 bits."
	"Color initializeIndexedColors"

	| a index grayVal |
	a _ Array new: 256.

	"1-bit colors (monochrome)"
	a at: 1 put: (self red: 1.0 green: 1.0 blue: 1.0).  "white"
	a at: 2 put: (self red: 0.0 green: 0.0 blue: 0.0).  "black"

	"additional colors for 2-bit color"
	a at: 3 put: (self red: 0.5 green: 0.5 blue: 0.5).  "50% gray"
	a at: 4 put: (self red: 1.0 green: 1.0 blue: 0.0).  "yellow"

	"additional colors for 4-bit color"
	a at: 5 put: (self red: 1.0 green: 0.0 blue: 0.0).  "red"
	a at: 6 put: (self red: 0.0 green: 1.0 blue: 0.0).  "green"
	a at: 7 put: (self red: 0.0 green: 0.0 blue: 1.0).  "blue"
	a at: 8 put: (self red: 0.0 green: 1.0 blue: 1.0).  "cyan"
	a at: 9 put: (self red: 1.0 green: 0.0 blue: 1.0).  "magenta"

	a at: 10 put: (self red: 0.125 green: 0.125 blue: 0.125).	"1/8 gray"
	a at: 11 put: (self red: 0.25 green: 0.25 blue: 0.25).		"2/8 gray"
	a at: 12 put: (self red: 0.375 green: 0.375 blue: 0.375).	"3/8 gray"
	a at: 13 put: (self red: 0.50 green: 0.50 blue: 0.50).		"4/8 gray"
	a at: 14 put: (self red: 0.625 green: 0.625 blue: 0.625).	"5/8 gray"
	a at: 15 put: (self red: 0.75 green: 0.75 blue: 0.75).		"6/8 gray"
	a at: 16 put: (self red: 0.875 green: 0.875 blue: 0.875).	"7/8 gray"

	"additional colors for 8-bit color"
	"24 more shades of gray (1/32 increments but not repeating 1/8 increments)"
	index _ 17.
	1 to: 31 do: [ :v |
		(v \\ 4) = 0 ifFalse: [
			grayVal _ v / 32.0.
			a at: index put: (self red: grayVal green: grayVal blue: grayVal).
			index _ index + 1.
		].
	].

	"The remainder of color table defines a color cube with six steps
	 for each primary color. Note that the corners of this cube repeat
	 previous colors, but this simplifies the mapping between RGB colors
	 and color map indices. This color cube spans indices 40 through 255
	 (indices 41-256 in this 1-based array)."

	0 to: 5 do: [ :r |
		0 to: 5 do: [ :g |
			0 to: 5 do: [ :b |
				index _ 41 + ((36 * r) + (6 * b) + g).
				index > 256 ifTrue: [
					self error: 'index out of range in color table compuation'.
				].
				a at: index put:
					(self red: r green: g blue: b range: 5).
			].
		].
	].

	IndexedColors _ a.!
initializeNames
	"Set values of the named colors. 6/13/96 tk
	Color initializeNames"

	ColorNames _ OrderedCollection new.
	#(white black gray yellow red green blue cyan
		magenta - veryDarkGray darkGray - lightGray 
		veryLightGray - )
		doWithIndex:
		[:colorPut :i | colorPut == #- ifFalse:
			[self named: colorPut put: (IndexedColors at: i)]].

	#(lightBlue lightBrown lightCyan lightGray lightGreen lightMagenta lightOrange lightRed lightYellow)
			with:  "Color fromUser first bitAnd: 255"
		#( 219 206 147 37 207 254 236 248 249)
			do: [:colorPut :i | 
				self named: colorPut put: (IndexedColors at: i+1)].
! !

Color initialize!
Object subclass: #ColorGenerator
	instanceVariableNames: 'depth '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
ColorGenerator comment:
'This class behaves like an array holding a very large number of colors.  It responds to at: by looking up the Nth Color, making an instance of it and returning it.  For the colorMap of 16-bit and 32-bit colors as given by Color allColorsForDepth: d.

	at: index		Returns a Color by calling (Color colorForPixelValue: index depth: d) which unpacks the bits in the pixelValue.
	size			the maximum index that is a color.
'!

!ColorGenerator methodsFor: 'as yet unclassified'!
at: index
	"Return the Nth color at this depth, as if this were a very big array. Index is 1-order, pixelValues are 0-order.  6/22/96 tk"

	 ^ Color colorFromPixelValue: index-1 depth: depth!
depth
	^ depth!
depth: d
	"Set the depth.  6/22/96 tk"

	(d = 16) | (d = 32) ifFalse: [
		^ self error: 'Use an Array for other depths'].
	depth _ d!
size
	depth = 16 ifTrue: [^ 32768].
	depth = 32 ifTrue: [^ 256*256*256].	"really 24 bit"
	^ 0! !StandardSystemView subclass: #ColorSystemView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!

!ColorSystemView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !ByteArray variableByteSubclass: #CompiledMethod
	instanceVariableNames: ''
	classVariableNames: 'LargeFrame TempNameCache SpecialConstants SmallFrame '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
CompiledMethod comment:
'I represent a method suitable for interpretation by the virtual machine. My instances have pointer fields, including a header and some literals, followed by non-pointer fields comprising the byte encoded instructions for the method. The header encodes the number of arguments, the number of literals, and the amount of temporary space needed (for context allocation).
	
An extra three bytes are added after the executable code. These contain an external file address to the source code for the method.'!

!CompiledMethod methodsFor: 'initialize-release'!
needsFrameSize: newFrameSize
	"Set the largeFrameBit to accomodate the newFrameSize.
	NOTE: I think the >= below is overly cautious.
	Recompile the system with just > some day - DI 2/26/96"
	| largeFrameBit header |
	largeFrameBit _ 16r20000.
	(self numTemps + newFrameSize) >= LargeFrame
		ifTrue: [^self error: 'Cannot compile--stack including temps is too deep'].
	header _ self objectAt: 1.
	(header bitAnd: largeFrameBit) ~= 0
		ifTrue: [header _ header - largeFrameBit].
	self objectAt: 1 put: header
			+ ((self numTemps + newFrameSize) >= SmallFrame
					ifTrue: [largeFrameBit]
					ifFalse: [0])! !

!CompiledMethod methodsFor: 'accessing'!
bePrimitive: primitiveIndex 
	"Used in conjunction with simulator only"
	self objectAt: 1
		put: ((self objectAt: 1) bitAnd: 16rFFFFFE00) + primitiveIndex!
endPC
	"Answer the index of the last bytecode."

	(self last between: 120 and: 124) ifTrue: [^self size].
	^self size - 3!
frameSize
	"Answer the size of temporary frame needed to run the receiver."

	(self header noMask: 16r20000)
		ifTrue: [^ SmallFrame]
		ifFalse: [^ LargeFrame]!
initialPC
	"Answer the program counter for the receiver's first bytecode."

	^ (self numLiterals + 1) * 4 + 1!
numArgs
	"Answer the number of arguments the receiver takes."

	^ (self header bitShift: -24) bitAnd: 16r1F!
numLiterals
	"Answer the number of literals used by the receiver."
	
	^ (self header bitShift: -9) bitAnd: 16rFF!
numTemps
	"Answer the number of temporary variables used by the receiver."
	
	^ (self header bitShift: -18) bitAnd: 16r3F!
primitive
	"Answer the primitive index associated with the receiver. Zero indicates 
	that there is either no primitive or just a quick primitive."
	
	^ self header bitAnd: 16r1FF!
returnField
	"Answer the index of the instance variable returned by a quick return 
	method."
	| prim |
	prim _ self primitive.
	prim < 264
		ifTrue: [self error: 'only meaningful for quick-return']
		ifFalse: [^ prim - 264]! !

!CompiledMethod methodsFor: 'comparing'!
= method
	"Answer whether the receiver implements the same code as the 
	argument, method."
	(method isKindOf: CompiledMethod) ifFalse: [^false].
	self size = method size ifFalse: [^false].
	self header = method header ifFalse: [^false].
	self literals = method literals ifFalse: [^false].
	self initialPC to: self endPC do:
		[:i | (self at: i) = (method at: i) ifFalse: [^false]].
	^true! !

!CompiledMethod methodsFor: 'testing'!
isQuick
	"Answer whether the receiver is a quick return (of self or of an instance 
	variable)."
	^ self primitive >= 256!
isReturnField
	"Answer whether the receiver is a quick return of an instance variable."
	^ self primitive >= 264!
isReturnSelf
	"Answer whether the receiver is a quick return of self."

	^ self primitive = 256!
isReturnSpecial
	"Answer whether the receiver is a quick return of self or constant."

	^ self primitive between: 256 and: 263! !

!CompiledMethod methodsFor: 'printing'!
decompileString
	| clAndSel cl sel |
	clAndSel _ self who.
	cl _ clAndSel first.
	sel _ clAndSel last.
	^ (cl decompilerClass new
			decompile: sel in: cl method: self) decompileString!
printOn: aStream 
	"Overrides method inherited from the byte arrayed collection."

	aStream nextPutAll: 'a CompiledMethod'!
storeLiteralsOn: aStream forClass: aBehavior
	"Store the literals referenced by the receiver on aStream, each terminated by a space."

	| literal |
	2 to: self numLiterals + 1 do:
		[:index |
		 aBehavior storeLiteral: (self objectAt: index) on: aStream.
		 aStream space]!
storeOn: aStream

	| noneYet index |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' newMethod: '.
	aStream store: self size - self initialPC + 1.
	aStream nextPutAll: ' header: '.
	aStream store: self header.
	aStream nextPut: $).
	noneYet _ self storeElementsFrom: self initialPC to: self endPC on: aStream.
	1 to: self numLiterals do:
		[:index |
		noneYet
			ifTrue: [noneYet _ false]
			ifFalse: [aStream nextPut: $;].
		aStream nextPutAll: ' literalAt: '.
		aStream store: index.
		aStream nextPutAll: ' put: '.
		aStream store: (self literalAt: index)].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)!
symbolic
	"Answer a String that contains a list of all the byte codes in a method 
	with a short description of each." 
	| aStream |
	self isQuick ifTrue: 
		[self isReturnSpecial ifTrue: [^ 'Quick return ' ,
				(#('self' 'true' 'false' 'nil' '-1' '0' '1' '2')
						at: self primitive - 255)].
		^ 'Quick return field ' , self returnField printString , ' (0-based)'].
	aStream _ WriteStream on: (String new: 1000).
	self primitive > 0 
		ifTrue: 
			[aStream nextPutAll: '<primitive: '.
			aStream print: self primitive.
			aStream nextPut: $>.
			aStream cr].
	(InstructionPrinter on: self) printInstructionsOn: aStream.
	^aStream contents!
who 
	"Answer an Array of the class in which the receiver is defined and the 
	selector to which it corresponds."

	Smalltalk allBehaviorsDo:
		[:class |
		class selectorsDo:
			[:sel |
			(class compiledMethodAt: sel) == self 
				ifTrue: [^Array with: class with: sel]]]! !

!CompiledMethod methodsFor: 'literals'!
hasLiteral: literal 
	"Answer whether the receiver references the argument, literal."
	2 to: self numLiterals + 1 do:
		[:index |
		literal == (self objectAt: index) ifTrue: [^ true]].
	^false!
header
	"Answer the word containing the information about the form of the 
	receiver and the form of the context needed to run the receiver."

	^self objectAt: 1!
literalAt: index 
	"Answer the literal indexed by the argument."

	^self objectAt: index + 1!
literalAt: index put: value 
	"Replace the literal indexed by the first argument with the second 
	argument. Answer the second argument."

	^self objectAt: index + 1 put: value!
literals
	"Answer an Array of the literals referenced by the receiver."
	| literals numberLiterals |
	literals _ Array new: (numberLiterals _ self numLiterals).
	1 to: numberLiterals do:
		[:index |
		literals at: index put: (self objectAt: index + 1)].
	^literals!
literalStrings
	| lits litStrs |
	lits _ self literals.
	litStrs _ OrderedCollection new: lits size * 3.
	self literals do:
		[:lit | 
		(lit isMemberOf: Association)
			ifTrue: [litStrs addLast: lit key]
			ifFalse: [(lit isMemberOf: Symbol)
				ifTrue: [litStrs addAll: lit keywords]
				ifFalse: [litStrs addLast: lit printString]]].
	^ litStrs!
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!
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! !

!CompiledMethod methodsFor: 'scanning'!
messages
	"Answer a Set of all the message selectors sent by this method."

	| scanner aSet |
	aSet _ Set new.
	scanner _ InstructionStream on: self.
	scanner	
		scanFor: 
			[:x | 
			scanner addSelectorTo: aSet.
			false	"keep scanning"].
	^aSet!
readsField: varIndex 
	"Answer whether the receiver loads the instance variable indexed by the 
	argument."

	self isReturnField ifTrue: [^self returnField + 1 = varIndex].
	varIndex <= 16 ifTrue: [^self scanFor: varIndex - 1].
	^self scanLongLoad: varIndex - 1!
readsRef: literalAssociation 
	"Answer whether the receiver loads the argument."

	| lit |
	lit _ self literals indexOf: literalAssociation ifAbsent: [^false].
	lit <= 32 ifTrue: [^self scanFor: 64 + lit - 1].
	^self scanLongLoad: 192 + lit - 1!
scanFor: byte 
	"Answer whether the receiver contains the argument as a bytecode."
	| instr |
	^ (InstructionStream on: self) scanFor: [:instr | instr = byte]
"
Smalltalk browseAllSelect: [:m | m scanFor: 134]
"!
scanLongLoad: extension 
	"Answer whether the receiver contains a long load whose extension is the 
	argument."

	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]!
scanLongStore: extension 
	"Answer whether the receiver contains a long store whose extension is 
	the argument."

	| scanner |
	scanner _ InstructionStream on: self.
	^scanner scanFor: 
		[:instr | 
		(instr between: 129 and: 130) and: [scanner followingByte = extension]]!
sendsToSuper
	"Answer whether the receiver sends any message to super."

	^ (self scanFor: 16r85) or: [self scanFor: 16r86]!
writesField: field 
	"Answer whether the receiver stores into the instance variable indexed 
	by the argument."

	self isQuick ifTrue: [^false].
	(field <= 8 and: [self scanFor: 96 + field - 1])
		ifTrue: [^true]
		ifFalse: [^self scanLongStore: field - 1]!
writesRef: ref 
	"Answer whether the receiver stores the argument."

	| lit |
	lit _ self literals indexOf: ref ifAbsent: [^false].
	^self scanLongStore: 192 + lit - 1! !

!CompiledMethod methodsFor: 'source code management'!
cacheTempNames: names

	TempNameCache _ Association key: self value: names!
copySourceTo: aFileStream
	"Copy the source code for the receiver to aFileStream. Answer true if there are no 
	problems, false if no files specified in the global SourceFiles or position is zero."
	| position |
	(SourceFiles at: self fileIndex) == nil ifTrue: [^false].
	Cursor read
		showWhile: 
			[position _ self filePosition.
			position ~= 0
				ifTrue: [(SourceFiles at: self fileIndex) position: position;
							copyChunkTo: aFileStream]].
	^position ~= 0!
fileIndex
	"Answer 1 if the source code of the receiver is on the *.sources file and 2 
	if it is on the *.changes file."

	(self last between: 120 and: 124)
		ifTrue: [self error: 'Somehow a method does not have a file index.'].
	^self last // 64 + 1!
filePosition
	"Answer the file position of this method's source code."
	| end |
	end _ self size.
	^ ((self at: end) bitAnd: 63) * 256 + (self at: end - 1) * 256 + (self at: end - 2)!
getSource
	"Answer the source code for the receiver. Answer nil if there are no 
	source files specified in the global SourceFiles."
	| source position |
	(SourceFiles at: self fileIndex) == nil ifTrue: [^nil].
	Cursor read
		showWhile: 
			[position _ self filePosition.
			position = 0
				ifTrue: [source _ nil]
				ifFalse: [source _ (RemoteString newFileNumber: self fileIndex
												position: position) string]].
	^source!
putSource: sourceStr class: class category: catName
	inFile: fileIndex priorMethod: priorMethod 
	"Print an expression that is a message to the argument, class, asking the 
	class to accept the source code, sourceStr, as a method in category, 
	catName. This is part of the format for writing descriptions of methods 
	on files. If no sources are specified, i.e., SourceFile iEs nil, then do 
	nothing. If the fileIndex is 1, print on *.sources; if it is 2, print on 
	*.canges.  If priorMethod is not nil, then link this source to the prior
	method and supply the time and date for this definition."
	| file remoteString |
	file _ SourceFiles at: fileIndex.
	file == nil ifTrue: [^self].
	file setToEnd.
	class printCategoryChunk: catName on: file priorMethod: priorMethod.
	file cr.
	remoteString _ 
		RemoteString
			newString: sourceStr
			onFileNumber: fileIndex
			toFile: file.
	file nextChunkPut: ' '; flush.
	self setSourcePosition: remoteString position inFile: fileIndex!
putSource: sourceStr inFile: fileIndex 
	"Store the source code for the receiver on an external file.
	If no sources are specified, i.e., SourceFile is nil, then do nothing.
	If the fileIndex is 1, print on *.sources;  if it is 2, print on *.changes."

	| file remoteString |
	file _ SourceFiles at: fileIndex.
	file == nil ifTrue: [^self].
	file setToEnd; readWriteShorten.
	file cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr.
	remoteString _ 
		RemoteString
			newString: sourceStr
			onFileNumber: fileIndex
			toFile: file.
	file nextChunkPut: ' '; readOnly.
	self setSourcePosition: remoteString position inFile: fileIndex!
setSourcePosition: position inFile: fileIndex 
	"Store the location of the source code for the receiver in the receiver. The 
	location consists of which source file (*.sources or *.changes) and the 
	position in that file."

	| index hiByte middleByte lowByte |
	"set last three bytes to be position in file (1-4)"
	fileIndex > 4 ifTrue: [^self error: 'invalid file number'].
	index _ self size - 2.
	middleByte _ position bitShift: -8.
	hiByte _ middleByte bitShift: -8.
	middleByte _ middleByte bitAnd: 255.
	lowByte _ position bitAnd: 255.
	hiByte > 62 ifTrue: [Transcript show: 'Source file is getting full!!!!'; cr].
	self at: index + 2 put: fileIndex - 1 * 64 + hiByte.
	self at: index + 1 put: middleByte.
	self at: index put: lowByte!
setTempNamesIfCached: aBlock

	TempNameCache == nil ifTrue: [^self].
	TempNameCache key == self
		ifTrue: [aBlock value: TempNameCache value]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

CompiledMethod class
	instanceVariableNames: ''!

!CompiledMethod class methodsFor: 'class initialization'!
initialize
	"Initialize class variables specifying the size of the temporary frame
	needed to run instances of me."

	SmallFrame _ 12.	"Context range for temps+stack"
	LargeFrame _ 32

	"CompiledMethod initialize"! !

!CompiledMethod class methodsFor: 'instance creation'!
newBytes: numberOfBytes nArgs: nArgs nTemps: nTemps nStack: stackSize nLits: nLits primitive: primitiveIndex
	"Answer an instance of me. The header is specified by the message 
	arguments. The remaining parts are not as yet determined."
	| largeBit |
	largeBit _ (nTemps + stackSize) > SmallFrame ifTrue: [1] ifFalse: [0].
	^ self 
		newMethod: numberOfBytes + 3 	"+3 to store source code ptr" 
		header: (nArgs bitShift: 24) +
				(nTemps bitShift: 18) +
				(largeBit bitShift: 17) +
				(nLits bitShift: 9) +
				primitiveIndex!
newMethod: numberOfBytes header: headerWord 
	"Primitive. Answer an instance of me. The number of literals (and other 
	information) is specified the headerWord. The first argument specifies 
	the number of fields for bytecodes in the method. Fail if either 
	argument is not a SmallInteger, or if numberOfBytes is negative. Once 
	the header of a method is set by this primitive, it cannot be changed in 
	any way. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 79>
	(numberOfBytes isInteger and:
	 [headerWord isInteger and:
	 [numberOfBytes >= 0]]) ifTrue: [
		"args okay; space must be low"
		Smalltalk signalLowSpace.
		"retry if user proceeds"
		^ self newMethod: numberOfBytes header: headerWord
	].
	^self primitiveFailed!
toReturnConst: constCode
	"Answer an instance of me that is a quick return of a constant
	constCode = 1...7  ->  true, false, nil, -1, 0, 1, 2."

	^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + constCode!
toReturnConstant: index 
	"Answer an instance of me that is a quick return of the constant
	indexed in (true false nil -1 0 1 2)."

	^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256 + index
!
toReturnField: field 
	"Answer an instance of me that is a quick return of the instance variable 
	indexed by the argument, field."

	^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 264 + field
!
toReturnSelf
	"Answer an instance of me that is a quick return of the instance (^self)."

	^ self newBytes: 0 nArgs: 0 nTemps: 0 nStack: 0 nLits: 0 primitive: 256
! !

CompiledMethod initialize!
Object subclass: #Compiler
	instanceVariableNames: 'sourceStream requestor class context '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
Compiler comment:
'The compiler accepts Smalltalk source code and compiles it with respect to a given class. The user of the compiler supplies a context so that temporary variables are accessible during compilation. If there is an error, a requestor (usually a kind of StringHolderController) is sent the message notify:at:in: so that the error message can be displayed. If there is no error, then the result of compilation is a MethodNode, which is the root of a parse tree whose nodes are kinds of ParseNodes. The parse tree can be sent messages to (1) generate code for a CompiledMethod (this is done for compiling methods or evaluating expressions); (2) pretty-print the code (for formatting); or (3) produce a map from object code back to source code (used by debugger program-counter selection). See also Parser, Encoder, ParseNode.'!

!Compiler methodsFor: 'error handling'!
interactive 
	"Answer whether there is a requestor of the compiler who should be 
	informed that an error occurred."

	^ (requestor == nil or: [requestor isKindOf: SyntaxError]) not!
notify: aString 
	"Refer to the comment in Object|notify:."

	^self notify: aString at: sourceStream position + 1!
notify: aString at: location
	"Refer to the comment in Object|notify:."

	requestor == nil
		ifTrue: [^SyntaxError 
					errorInClass: class
					withCode: 
						(sourceStream contents
							copyReplaceFrom: location
							to: location - 1
							with: aString)]
		ifFalse: [^requestor
					notify: aString
					at: location
					in: sourceStream]! !

!Compiler methodsFor: 'public access'!
compile: textOrStream in: aClass notifying: aRequestor ifFail: failBlock 
	"Answer a MethodNode for the argument, textOrStream. If the 
	MethodNode can not be created, notify the argument, aRequestor; if 
	aRequestor is nil, evaluate failBlock instead. The MethodNode is the root 
	of a parse tree. It can be told to generate a CompiledMethod to be 
	installed in the method dictionary of the argument, aClass."

	self from: textOrStream
		class: aClass
		context: nil
		notifying: aRequestor.
	^self
		translate: sourceStream
		noPattern: false
		ifFail: failBlock!
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).
	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]!
format: textOrStream in: aClass notifying: aRequestor
	"Compile a parse tree from the argument, textOrStream. Answer a string 
	containing the original code, formatted nicely."

	| aNode |
	self from: textOrStream
		class: aClass
		context: nil
		notifying: aRequestor.
	aNode _ self format: sourceStream noPattern: false ifFail: [^nil].
	^aNode decompileString!
parse: textOrStream in: aClass notifying: req
	"Compile the argument, textOrStream, with respect to the class, aClass, 
	and answer the MethodNode that is the root of the resulting parse tree. 
	Notify the argument, req, if an error occurs. The failBlock is defaulted to 
	an empty block."

	self from: textOrStream class: aClass context: nil notifying: req.
	^self translate: sourceStream noPattern: false ifFail: []! !

!Compiler methodsFor: 'private'!
format: aStream noPattern: noPattern ifFail: failBlock

	| tree |
	tree _ 
		Parser new
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^failBlock value].
	^tree!
from: textOrStream class: aClass context: aContext notifying: req

	(textOrStream isKindOf: PositionableStream)
		ifTrue: [sourceStream _ textOrStream]
		ifFalse: [sourceStream _ ReadStream on: textOrStream asString].
	class _ aClass.
	context _ aContext.
	requestor _ req!
translate: aStream noPattern: noPattern ifFail: failBlock

	| tree |
	tree _ 
		Parser new
			parse: aStream
			class: class
			noPattern: noPattern
			context: context
			notifying: requestor
			ifFail: [^failBlock value].
	^tree!
translate: aStream withLocals: localDict noPattern: noPattern ifFail: failBlock

	| tree |
	tree _ 
		Parser new
			parse: aStream
			class: class
			noPattern: noPattern
			locals: localDict
			notifying: requestor
			ifFail: [^failBlock value].
	^tree! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Compiler class
	instanceVariableNames: ''!

!Compiler class methodsFor: 'accessing'!
parserClass
	"Return a parser class to use for parsing method headers."

	^Parser! !

!Compiler class methodsFor: 'evaluating'!
evaluate: textOrString 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object, and the 
	invocation is not logged."

	^self evaluate: textOrString for: nil logged: false!
evaluate: textOrString for: anObject logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor."

	^self evaluate: textOrString for: anObject notifying: nil logged: logFlag!
evaluate: textOrString for: anObject notifying: aController logged: logFlag
	"Compile and execute the argument, textOrString with respect to the class 
	of anObject. If a compilation error occurs, notify aController. If both 
	compilation and execution are successful then, if logFlag is true, log 
	(write) the text onto a system changes file so that it can be replayed if 
	necessary."

	| val |
	val _ self new
				evaluate: textOrString
				in: nil
				to: anObject
				notifying: aController
				ifFail: [^nil].
	logFlag ifTrue: [Smalltalk logChange: textOrString].
	^val!
evaluate: textOrString logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. If a compilation error occurs, 
	a Syntax Error view is created rather than notifying any requestor. 
	Compilation is carried out with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil logged: logFlag!
evaluate: textOrString notifying: aController logged: logFlag 
	"See Compiler|evaluate:for:notifying:logged:. Compilation is carried out 
	with respect to nil, i.e., no object."

	^self evaluate: textOrString for: nil notifying: aController logged: logFlag! !CharacterScanner subclass: #CompositionScanner
	instanceVariableNames: 'spaceX spaceIndex '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Support'!
CompositionScanner comment:
'CompositionScanners are used to measure text and determine where line breaks and space padding should occur.'!

!CompositionScanner methodsFor: 'initialize-release'!
in: aParagraph 
	"Initialize the paragraph to be scanned as the argument, aParagraph. Set 
	the composition frame for the paragraph."

	super initializeFromParagraph: aParagraph clippedBy: aParagraph clippingRectangle! !

!CompositionScanner methodsFor: 'accessing'!
rightX
	"Meaningful only when a line has just been composed -- refers to the 
	line most recently composed. This is a subtrefuge to allow for easy 
	resizing of a composition rectangle to the width of the maximum line. 
	Useful only when there is only one line in the form or when each line 
	is terminated by a carriage return. Handy for sizing menus and lists."

	^spaceX! !

!CompositionScanner methodsFor: 'scanning'!
composeLine: lineIndex fromCharacterIndex: startIndex inParagraph: aParagraph 
	"Answer an instance of TextLineInterval that represents the next line in the paragraph. "
	
	| runLengtrh done stopCondition |
	spaceX _ destX _ leftMargin _ aParagraph leftMarginForCompositionForLine: lineIndex.
	destY _ 0.
	rightMargin _ aParagraph rightMarginForComposition.
	leftMargin >= rightMargin ifTrue: [self error: 'No room between margins to compose'].
	lastIndex _ startIndex.	"scanning sets last index"
	self setStopConditions.	"also sets font"
	runLengtrh _ text runLengthFor: startIndex.
	runStopIndex _ (lastIndex _ startIndex) + (runLengtrh - 1).
	line _ TextLineInterval
		start: lastIndex
		stop: 0
		internalSpaces: 0
		paddingWidth: 0.
	spaceCount _ 0.
	done _ false.
	[done]
		whileFalse: 
			[stopCondition _ super
				scanCharactersFrom: lastIndex
				to: runStopIndex
				in: text string
				rightX: rightMargin
				stopConditions: stopConditions
				displaying: false.
			"See setStopConditions for stopping conditions for composing."
			(self perform: stopCondition)
				ifTrue: [^line]]! !

!CompositionScanner methodsFor: 'stop conditions'!
cr
	"Answer true. Set up values for the text line interval currently being 
	composed."

	line stop: lastIndex.
	spaceX _ destX.
	line paddingWidth: rightMargin - destX.
	^true!
crossedX
	"There is a word that has fallen across the right edge of the composition 
	rectangle. This signals the need for wrapping which is done to the last 
	space that was encountered, as recorded by the space stop condition."

	line stop: spaceIndex.
	spaceCount > 1	
		ifTrue:	["The common case. First back off the space at which we wrap."
				spaceCount _ spaceCount - 1.
				spaceIndex _ spaceIndex - 1.
				["Check to see if any spaces preceding the one at which we wrap.
					Double space after a period, most likely."
				(spaceCount > 1 and: [(text at: spaceIndex) = Space])]
					whileTrue:
						[spaceCount _ spaceCount - 1.
						"Account for backing over a run which might
							change width of space."
						font _ textStyle fontAt:
								(text emphasisAt: spaceIndex).
						spaceIndex _ spaceIndex - 1.
						spaceX _ spaceX - (font widthOf: Space)].
						line paddingWidth: rightMargin - spaceX.
						line internalSpaces: spaceCount]
		ifFalse:	[spaceCount = 1
					ifTrue:	["wrap at space, but no internal spaces"
							line internalSpaces: 0.
							line paddingWidth: rightMargin - spaceX]
					ifFalse:	["Neither internal nor trailing spaces, almost never happen,
								she says confidently."
							lastIndex _ lastIndex - 1.
							[destX <= rightMargin]
							whileFalse:
								[destX _ destX - (font widthOf:
													(text at: lastIndex)).
										"bug --doesn't account for backing over
										 run and changing actual width of
										characters. Also doesn't account for
										backing over a tab.  Happens only
										when no spaces in line, presumably rare."
								lastIndex _ lastIndex - 1].
							spaceX _ destX.
							line paddingWidth: rightMargin - destX.
							lastIndex < line first
								ifTrue:	[line stop: line first]
								ifFalse:	[line stop: lastIndex]]].
	^true!
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]
!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont!
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.
	lastIndex _ (spaceIndex _ lastIndex) + 1.
	spaceCount _ spaceCount + 1.
	destX > rightMargin ifTrue: 	[^self crossedX].
	^false
!
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
! !InstructionStream subclass: #ContextPart
	instanceVariableNames: 'stackp '
	classVariableNames: 'TryPrimitiveMethods TryPrimitiveSelectors '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
ContextPart comment:
'To the instruction parsing ability of InstructionStream I add the actual semantics for execution. The execution state is stored in the indexable fields of my subclasses. This includes temporary variables and a stack of values used in evaluating expressions. The actual semantics of execution can be found in my category "system simulation" and "instruction decode". These methods exactly parallel the operation of the Smalltalk machine itself.
	
The simulator is a group of my methods that do what the Smalltalk interpreter does: execute Smalltalk bytecodes. By adding code to the simulator, you may take statistics on the running of Smalltalk methods. For example,
	Transcript show: (ContextPart runSimulated: [3 factorial]) printString.'!

!ContextPart methodsFor: 'accessing'!
client
	"Answer the client, that is, the object that sent the message that created this context."

	^sender receiver!
failureCatcher: exceptMethod
	"Answer a context in the sender chain that is executing BlockContext ifFail:
	 Skip such that are matched by contexts above them executing
	 exceptMethod.  Answer nil if none found.  Called only by Failure propagate."

	| stackFrame failureCatcher count |
	failureCatcher _ BlockContext compiledMethodAt: #ifFail:.
	stackFrame _ sender.
	count _ 1.
	[stackFrame ~~ nil and:
		[stackFrame method == failureCatcher ifTrue: [count _ count - 1].
		 stackFrame method == exceptMethod ifTrue: [count _ count + 1].
		 count > 0]] whileTrue:
			[stackFrame _ stackFrame sender].
	^stackFrame!
home
	"Answer the context in which the receiver was defined."

	self subclassResponsibility!
method
	"Answer the method of this context."

	self subclassResponsibility!
receiver
	"Answer the receiver of the message that created this context."

	self subclassResponsibility!
tempAt: index
	"Answer the value of the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility!
tempAt: index put: value 
	"Store the argument, value, as the temporary variable whose index is the 
	argument, index."

	self subclassResponsibility! !

!ContextPart methodsFor: 'instruction decoding'!
doDup
	"Simulate the action of a 'duplicate top of stack' bytecode."

	self push: self top!
doPop
	"Simulate the action of a 'remove top of stack' bytecode."

	self pop!
jump: distance 
	"Simulate the action of a 'unconditional jump' bytecode whose offset is 
	the argument, distance."

	pc _ pc + distance!
jump: distance if: condition 
	"Simulate the action of a 'conditional jump' bytecode whose offset is the 
	argument, distance, and whose condition is the argument, condition."

	(self pop eqv: condition) ifTrue: [self jump: distance]!
methodReturnConstant: value 
	"Simulate the action of a 'return constant' bytecode whose value is the 
	argument, value. This corresponds to a source expression like '^0'."

	^self return: value to: self home sender!
methodReturnReceiver
	"Simulate the action of a 'return receiver' bytecode. This corresponds to 
	the source expression '^self'."

	^self return: self receiver to: self home sender!
methodReturnTop
	"Simulate the action of a 'return top of stack' bytecode. This corresponds 
	to source expressions like '^something'."

	^self return: self pop to: self home sender!
popIntoLiteralVariable: value 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into a literal variable of my method."

	value value: self pop!
popIntoReceiverVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into an instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self pop!
popIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that removes the top of the stack and 
	stores it into one of my temporary variables."

	self home at: offset + 1 put: self pop!
pushActiveContext
	"Simulate the action of bytecode that pushes the the active context on the 
	top of its own stack."

	self push: self!
pushConstant: value 
	"Simulate the action of bytecode that pushes the constant, value, on the 
	top of the stack."

	self push: value!
pushLiteralVariable: value 
	"Simulate the action of bytecode that pushes the contents of the literal 
	variable whose index is the argument, index, on the top of the stack."

	self push: value value!
pushReceiver
	"Simulate the action of bytecode that pushes the active context's receiver 
	on the top of the stack."

	self push: self receiver!
pushReceiverVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the receiver's 
	instance variable whose index is the argument, index, on the top of the 
	stack."

	self push: (self receiver instVarAt: offset + 1)!
pushTemporaryVariable: offset 
	"Simulate the action of bytecode that pushes the contents of the 
	temporary variable whose index is the argument, index, on the top of 
	the stack."

	self push: (self home at: offset + 1)!
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 |
	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].
	^self send: selector to: receiver with: arguments super: superFlag!
storeIntoLiteralVariable: value 
	"Simulate the action of bytecode that stores the top of the stack into a 
	literal variable of my method."

	value value: self top!
storeIntoReceiverVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into an 
	instance variable of my receiver."

	self receiver instVarAt: offset + 1 put: self top!
storeIntoTemporaryVariable: offset 
	"Simulate the action of bytecode that stores the top of the stack into one 
	of my temporary variables."

	self home at: offset + 1 put: self top! !

!ContextPart methodsFor: 'debugger access'!
depthBelow: aContext
	"Answer how many calls there are between this and aContext."

	| this depth |
	this _ self.
	depth _ 0.
	[this == aContext or: [this == nil]]
		whileFalse:
			[this _ this sender.
			depth _ depth + 1].
	^depth!
mclass 
	"Answer the class in which the receiver's method was found."

	| mclass |
	self receiver class selectorAtMethod: self method setClass: [:mclass].
	^mclass!
pc
	"Answer the index of the next bytecode to be executed."

	^pc!
release
	"Remove information from the receiver and all of the contexts on its 
	sender chain in order to break circularities."

	self releaseTo: nil!
releaseTo: caller 
	"Remove information from the receiver and the contexts on its sender 
	chain up to caller in order to break circularities."

	| c s |
	c _ self.
	[c == nil or: [c == caller]]
		whileFalse: 
			[s _ c sender.
			c singleRelease.
			c _ s]!
selector
	"Answer the selector of the method that created the receiver."

	^self receiver class 
		selectorAtMethod: self method 
		setClass: [:ignored]!
sender
	"Answer the context that sent the message that created the receiver."

	^sender!
shortStack
	"Answer a String showing the top four contexts on my sender chain."
	| shortStackStream |
	shortStackStream _ WriteStream on: (String new: 400).
	(self stackOfSize: 5) do: 
		[:item | shortStackStream print: item; cr].
	^shortStackStream contents!
singleRelease
	"Remove information from the receiver in order to break circularities."

	stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]].
	sender _ nil!
sourceCode
	| mclass code |
	Sensor leftShiftDown ifFalse:
		[code _ self method getSource.
		code isNil ifFalse: [^ code]].
	mclass _ self receiver class selectorAtMethod: self method setClass: [:c | c].
	^ (self receiver class decompilerClass new
		decompile: mclass
		in: self receiver class
		method: self method) decompileString!
stack 
	"Answer an Array of the contexts on the receiver's sender chain."

	^self stackOfSize: 9999!
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!
swapSender: coroutine 
	"Replace the receiver's sender with coroutine and answer the receiver's 
	previous sender. For use in coroutining."

	| oldSender |
	oldSender _ sender.
	sender _ coroutine.
	^oldSender!
tempNames
	"Answer an OrderedCollection of the names of the receiver's temporary 
	variables, which are strings."

	| names |
	self method setTempNamesIfCached: [:names | ^names].
	names _ (self mclass compilerClass new
			parse: self sourceCode
			in: self mclass
			notifying: nil) tempNames.
	self method cacheTempNames: names.
	^names!
tempsAndValues
	"Return a string of the temporary variabls and their current values"
	| aStream |
	aStream _ WriteStream on: (String new: 100).
	self tempNames
		doWithIndex: [:title :index |
			aStream nextPutAll: title; nextPut: $:; space; tab.
			(self tempAt: index) printOn: aStream.
			aStream cr].
	^aStream contents! !

!ContextPart methodsFor: 'controlling'!
activateMethod: newMethod withArgs: args receiver: rcvr class: class 
	"Answer a ContextPart initialized with the arguments."

	^MethodContext 
		sender: self
		receiver: rcvr
		method: newMethod
		arguments: args!
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>
	^(BlockContext new: self size)
		home: self home
		startpc: pc + 2
		nargs: numArgs!
hasSender: context 
	"Answer whether the receiver is strictly above context on the stack."

	| s |
	self == context ifTrue: [^false].
	s _ sender.
	[s == nil]
		whileFalse: 
			[s == context ifTrue: [^true].
			s _ s sender].
	^false!
pop
	"Answer the top of the receiver's stack and remove the top of the stack."

	| val |
	val _ self at: stackp.
	self at: stackp put: nil.
	stackp _ stackp - 1.
	^val!
push: val 
	"Push val on the receiver's stack."

	self at: (stackp _ stackp + 1) put: val!
return: value to: sendr 
	"Simulate the return of value to sendr."

	self releaseTo: sendr.
	^sendr push: value!
send: selector to: rcvr with: args super: superFlag 
	"Simulate the action of sending a message with selector, selector, and 
	arguments, args, to receiver. The argument, superFlag, tells whether the 
	receiver of the message was specified with 'super' in the source method."

	| class meth val |
	class _ 
		superFlag
			ifTrue: [(self method literalAt: self method numLiterals) value superclass]
			ifFalse: [rcvr class].
	[class == nil]
		whileFalse: 
			[(class includesSelector: selector)
				ifTrue: 
					[meth _ class compiledMethodAt: selector.
					val _ 
						self tryPrimitiveFor: meth
							receiver: rcvr
							args: args.
					val == #simulatorFail ifFalse: [^val].
					(selector == #doesNotUnderstand: and: [class == Object]) ifTrue:
						[ ^ self error: 'Simulated message ' , (args at: 1) selector , ' not understood' ].
					^self
						activateMethod: meth
						withArgs: args
						receiver: rcvr
						class: class].
			class _ class superclass].
	^self send: #doesNotUnderstand:
		to: rcvr
		with: (Array with: (Message selector: selector arguments: args))
		super: superFlag!
top
	"Answer the top of the receiver's stack."

	^self at: stackp! !

!ContextPart methodsFor: 'printing'!
printOn: aStream 
	| mclass selector class |
	selector _ 
		(class _ self receiver class) 
			selectorAtMethod: self method 
			setClass: [:mclass].
	selector == #?
		ifTrue: 
			[aStream nextPut: $?; print: self method who.
			^self].
	aStream nextPutAll: class name.
	mclass == class 
		ifFalse: 
			[aStream nextPut: $(.
			aStream nextPutAll: mclass name.
			aStream nextPut: $)].
	aStream nextPutAll: '>>'.
	aStream nextPutAll: selector! !

!ContextPart methodsFor: 'system simulation'!
completeCallee: aContext
	"Simulate the execution of bytecodes until a return to the receiver."

	| ctxt current |
	self class initPrimitives.
	ctxt _ aContext.
	[ctxt == current or: [ctxt hasSender: self]]
		whileTrue: 
			[current _ ctxt.
			ctxt _ ctxt step].
	self stepToSendOrReturn!
runSimulated: aBlock contextAtEachStep: block2
	"Simulate the execution of the argument, aBlock, until it ends. aBlock 
	MUST NOT contain an '^'. Evaluate block2 with the current context 
	prior to each instruction executed. Answer the simulated value of aBlock."

	| current |
	aBlock hasMethodReturn
		ifTrue: [self error: 'simulation of blocks with ^ can run loose'].
	self class initPrimitives.
	current _ aBlock.
	current pushArgs: Array new from: self.
	[current == self]
		whileFalse:
			[block2 value: current.
			current _ current step].
	^self pop!
step
	"Simulate the execution of the receiver's next bytecode. Answer the 
	context that would be the active context after this bytecode."

	^self interpretNextInstructionFor: self!
stepToSendOrReturn
	"Simulate the execution of bytecodes until either sending a message or 
	returning a value to the receiver (that is, until switching contexts)."

	[self willSend | self willReturn]
		whileFalse: [self step]! !

!ContextPart methodsFor: 'private'!
doPrimitive: primitiveIndex receiver: receiver args: arguments 
	"Simulate a primitive method whose index is primitiveIndex.  The
	simulated receiver and arguments are given as arguments to this message."
	| primitiveMethod value |
	"If successful, push result and return resuming context,
		else ^ #simulatorFail"
	(primitiveIndex = 80 and: [receiver isKindOf: ContextPart])
		ifTrue: [^self push: 
					((BlockContext new: receiver size)
						home: receiver home
						startpc: pc + 2
						nargs: (arguments at: 1))].
	(primitiveIndex = 81 and: [receiver isMemberOf: BlockContext])
		ifTrue: [^receiver pushArgs: arguments from: self].
	primitiveIndex = 83 
		ifTrue: [^self send: (arguments at: 1) to: receiver
					with: (arguments copyFrom: 2 to: arguments size)
					super: false].
	arguments size > 6 ifTrue: [^#simulatorFail].
	primitiveMethod _ TryPrimitiveMethods at: arguments size + 1.
	"slam num into primitive instead of 100 such messages in Object"
	primitiveMethod bePrimitive: primitiveIndex.
	"Class flushCache."  "in case interp caches primitive #"
	value _ receiver perform: (TryPrimitiveSelectors at: arguments size+1)
				withArguments: arguments.
	value == #simulatorFail
		ifTrue: [^ #simulatorFail]
		ifFalse: [^ self push: value]!
pop: numObjects toAddable: anAddableCollection
	"Pop the top numObjects elements from the stack, and store them in
	 anAddableCollection, topmost element last.
	 Do not call directly.  Called indirectly by {1. 2. 3} constructs."

	| oldTop i |
	i _ stackp _ (oldTop _ stackp) - numObjects.
	[(i _ i + 1) <= oldTop] whileTrue:
		[anAddableCollection add: (self at: i).
		 self at: i put: nil]!
pop: numObjects toIndexable: anIndexableCollection
	"Pop the top numObjects elements from the stack, and store them in
	 anIndexableCollection, topmost element last.
	 Do not call directly.  Called indirectly by {1. 2. 3} constructs."

	| oldTop i |
	i _ stackp _ (oldTop _ stackp) - numObjects.
	[(i _ i + 1) <= oldTop] whileTrue:
		[anIndexableCollection at: i-stackp put: (self at: i).
		 self at: i put: nil]!
push: numObjects fromIndexable: anIndexableCollection
	"Push the elements of anIndexableCollection onto the receiver's stack.
	 Do not call directly.  Called indirectly by {1. 2. 3} constructs."

	| i |
	i _ 0.
	[(i _ i + 1) <= numObjects] whileTrue:
		[self at: (stackp _ stackp + 1) put: (anIndexableCollection at: i)]!
stackPtr  "For use only by the SystemTracer"
	^ stackp!
tryPrimitiveFor: method receiver: receiver args: arguments 
	"Simulate a primitive method, method for the receiver and arguments given
	as arguments to this message.  Answer resuming the context if successful, else
	answer the symbol, #simulatorFail."
	| flag primIndex |
	(primIndex _ method primitive) = 0 ifTrue: [^#simulatorFail].
	^ self doPrimitive: primIndex receiver: receiver args: arguments! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ContextPart class
	instanceVariableNames: ''!

!ContextPart class methodsFor: 'class initialization'!
initPrimitives   "ContextPart initPrimitives"
	"The methods (from class Object) that are cached in tryPrimitiveMethods 
	are used by the simulator to catch failures when simulating primitives."
	TryPrimitiveSelectors _
#(tryPrimitive
tryPrimitiveWith:
tryPrimitiveWith:with:
tryPrimitiveWith:with:with:
tryPrimitiveWith:with:with:with:
tryPrimitiveWith:with:with:with:with:
tryPrimitiveWith:with:with:with:with:with:).
	TryPrimitiveMethods _
		TryPrimitiveSelectors collect:  [:sel | Object compiledMethodAt: sel]! !

!ContextPart class methodsFor: 'examples'!
tallyInstructions: aBlock
	"This method uses the simulator to count the number of occurrences of
	each of the Smalltalk instructions executed during evaluation of aBlock.
	Results appear in order of the byteCode set."

	| current tallies |
	tallies _ Bag new.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current | tallies add: current nextByte].
	^tallies sortedElements

	"ContextPart tallyInstructions: [3.14159 printString]"!
tallyMethods: aBlock
	"This method uses the simulator to count the number of calls on each method
	invoked in evaluating aBlock. Results are given in order of decreasing counts."

	| prev current tallies |
	tallies _ Bag new.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			current == prev ifFalse: "call or return"
				[prev sender == nil ifFalse: "call only"
					[tallies add: current printString].
				prev _ current]].
	^tallies sortedCounts

	"ContextPart tallyMethods: [3.14159 printString]"!
trace: aBlock		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls and returned values in the Transcript."
	| prev current |
	Transcript clear.
	prev _ aBlock.
	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			Sensor anyButtonPressed ifTrue: [^ nil].
			current == prev
				ifFalse:
					[prev sender == nil ifTrue:  "returning"
						[Transcript space; nextPut: $^; print: current top].
					Transcript cr;
						nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );
						print: current receiver; space; nextPutAll: current selector; endEntry.
					prev _ current]]!
trace: aBlock onFileNamed: fileName		"ContextPart trace: [3 factorial]"
	"This method uses the simulator to print calls to a file."
	| prev current f sel |
	f _ FileStream fileNamed: fileName.
	prev _ aBlock.
	thisContext sender
		runSimulated: aBlock
		contextAtEachStep:
			[:current |
			Sensor anyButtonPressed ifTrue: [^ nil].
			current == prev
				ifFalse:
					[f cr;
						nextPutAll: (String new: (current depthBelow: aBlock) withAll: $ );
						print: current receiver class; space; nextPutAll: (sel _ current selector); flush.
					prev _ current.
					sel == #error: ifTrue: [self halt]]].
	f close! !

!ContextPart class methodsFor: 'simulation'!
runSimulated: aBlock
	"Simulate the execution of the argument, current. Answer the result it 
	returns."

	^ thisContext sender
		runSimulated: aBlock
		contextAtEachStep: [:ignored]

	"ContextPart runSimulated: [Pen new defaultNib: 5; go: 100]"! !BrowserCodeController subclass: #ContextStackCodeController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
ContextStackCodeController comment:
'I am a BrowserCodeController but the doIt command is redefined. The result of the evaluation is stored as the proceed value for the interrupted (selected) method.'!

!ContextStackCodeController methodsFor: 'menu messages'!
doIt

	| result |
	result _ super doIt.
	result ~~ #failedDoit ifTrue: [model proceedValue: result].
	^result! !

!ContextStackCodeController methodsFor: 'displaying'!
display
	"By selecting here, debugger windows will select when they redisplay."

	super display.
	self select! !

!ContextStackCodeController methodsFor: 'selecting'!
initializeSelection

	self selectionInterval last = 0
		ifFalse: [super initializeSelection]!
selectAndScrollFrom: start to: stop

	"Select the characters from character position start to position stop. Then 
	move the window so that this selection is visible."

	self deselect.
	startBlock _ paragraph characterBlockForIndex: start.
	stopBlock _ paragraph characterBlockForIndex: stop + 1.
	self selectAndScroll! !StringHolderView subclass: #ContextStackCodeView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
ContextStackCodeView comment:
'I am a StringHolderView of the source code retrieved in a Debugger. ContextStackCodeController is my default controller.'!

!ContextStackCodeView methodsFor: 'updating'!
update: aSymbol
	(aSymbol == #contextStackList) | (aSymbol == #contextStackIndex)
		ifTrue: [^ self].
	aSymbol == #pc ifTrue: [^ self highlightPC].
	aSymbol == #contents ifTrue: [^ self updateDisplayContents].
	super update: aSymbol!
updateDisplayContents 
	"Refer to the comment in StringHolderView|updateDisplayContents."

	| contents |
	contents _ model contents.
	displayContents string ~= contents
		ifTrue: 
			[displayContents _
				(contents asText makeSelectorBoldIn: model selectedClassOrMetaClass) asParagraph.
			self positionDisplayContents.
			self controller changeParagraph: displayContents.
			self displayView.
			self highlightPC]! !

!ContextStackCodeView methodsFor: 'private'!
highlightPC

	| range |
	range _ model pcRange.
	self controller selectAndScrollFrom: range first to: range last! !MessageListController subclass: #ContextStackListController
	instanceVariableNames: ''
	classVariableNames: 'ContextStackListYellowButtonMenu ContextStackListYellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-Debugger'!
ContextStackListController comment:
'I am a kind of LockedListController for the upper subView of a DebuggerView that creates a yellow button menu so that messages can be sent to the list selection (a message) to:
	fullStack	change from displaying the minimal stack to a full one
	proceed	proceed evaluation from the interrupted expression
	restart	restart evaluation from the beginning of the method
	send	execute the next message that a step would invoke
	spawn	create a browser for the code of the model''s selected message
	step	execute the next expression in the selected method
	where	toggle the flag that indicates whether to show the pc selection'!

!ContextStackListController methodsFor: 'initialize-release'!
initialize

	super initialize.
	self initializeYellowButtonMenu! !

!ContextStackListController methodsFor: 'menu messages'!
fullStack
	"Change from displaying the minimal stack to a full one."

	model contextStackList size > 7
		ifTrue:
			[view flash]
		ifFalse:
			[model contextStackIndex = 0
				ifFalse: [model toggleContextStackIndex: model contextStackIndex].
			self controlTerminate.
			model fullyExpandStack.
			self controlInitialize]!
proceed
	"Proceed execution of the receiver's model, starting after the expression at 
	which an interruption occurred."

	self controlTerminate.
	model proceed: view topView controller.
	self controlInitialize!
restart
	"Proceed execution of the receiver's model, starting at the beginning of 
	the currently selected method."

	self controlTerminate.
	model restart: view topView controller.
	self controlInitialize!
send
	"Evaluate the next expression in the receiver's model's currently selected 
	method, after the point at which interruption occurred."

	self controlTerminate.
	model send.
	self controlInitialize!
spawn
	"Create and schedule a message browser for the code of the model's 
	selected message. Retain any edits that have not yet been accepted."

	self controlTerminate.
	model spawn.
	self controlInitialize!
step
	"Evaluate the next message of the sequence that is initiated by evaluating 
	the next expression in the receiver's model's currently selected method, 
	after the point at which interruption occurred."

	self controlTerminate.
	model step.
	self controlInitialize!
where
	"Select the expression whose evaluation was interrupted."

	model selectPC! !

!ContextStackListController methodsFor: 'private'!
changeModelSelection: anInteger 
	Cursor execute showWhile:
		[model toggleContextStackIndex: anInteger]!
initializeYellowButtonMenu

	self yellowButtonMenu: ContextStackListYellowButtonMenu
		yellowButtonMessages: ContextStackListYellowButtonMessages! !

!ContextStackListController methodsFor: 'selecting '!
initializeSelection

	^self! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ContextStackListController class
	instanceVariableNames: ''!

!ContextStackListController class methodsFor: 'class initialization'!
initialize
	"Modified 1/12/96 sw"

	ContextStackListYellowButtonMenu _ 
		PopUpMenu labels: 'fullStack
restart
proceed
step
send
where
senders
implementors
senders of...
implementors of...
browse full'
	lines: #(6 11).
	ContextStackListYellowButtonMessages _ #(fullStack restart proceed step send where senders implementors sendersOf messages browseFull)

	"ContextStackListController initialize"! !

ContextStackListController initialize!
ListView subclass: #ContextStackListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
ContextStackListView comment:
'I am a ListView whose items are the methods (interrupted message-sends) of the Debugger that I view. ContextStackListController is my default controller.'!

!ContextStackListView methodsFor: 'model access'!
model: aDebugger

	super model: aDebugger.
	self list: model contextStackList! !

!ContextStackListView methodsFor: 'updating'!
update: aSymbol

	aSymbol == #contextStackIndex
		ifTrue: [self moveSelectionBox: model contextStackIndex].
	aSymbol == #contextStackList
		ifTrue: 
			[self list: model contextStackList.
			self displayView].
	aSymbol == #notChanged ifTrue: [self flash]! !

!ContextStackListView methodsFor: 'controller access'!
defaultControllerClass

	^ContextStackListController! !Inspector subclass: #ContextVariablesInspector
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
ContextVariablesInspector comment:
'I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.'!

!ContextVariablesInspector methodsFor: 'accessing'!
fieldList 
	"Refer to the comment in Inspector|fieldList."

	object == nil ifTrue: [^Array with: 'thisContext'].
	^(Array with: 'thisContext' with: 'all temp vars') , object tempNames! !

!ContextVariablesInspector methodsFor: 'selecting'!
replaceSelectionValue: anObject 
	"Refer to the comment in Inspector|replaceSelectionValue:."

	selectionIndex = 1
		ifTrue: [^object]
		ifFalse: [^object tempAt: selectionIndex - 1 put: anObject]!
selection 
	"Refer to the comment in Inspector|selection."

	selectionIndex = 1 ifTrue: [^object].
	selectionIndex = 2
		ifTrue: [^object tempsAndValues]
		ifFalse: [^object tempAt: selectionIndex - 2]! !

!ContextVariablesInspector methodsFor: 'code'!
doItContext

	^object!
doItReceiver

	^object receiver! !Object subclass: #Controller
	instanceVariableNames: 'model view sensor '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Framework'!
Controller comment:
'A Controller coordinates a View, its model, and user actions. It provides scheduling (control) behavior to determine when the user wants to communicate with the model or view.'!

!Controller methodsFor: 'initialize-release'!
initialize
	"Initialize the state of the receiver. Subclasses should include 'super 
	initialize' when redefining this message to insure proper initialization."

	sensor _ InputSensor default!
release
	"Breaks the cycle between the receiver and its view. It is usually not 
	necessary to send release provided the receiver's view has been properly 
	released independently."

	model _ nil.
	view ~~ nil
		ifTrue: 
			[view controller: nil.
			view _ nil]! !

!Controller methodsFor: 'model access'!
model
	"Answer the receiver's model which is the same as the model of the 
	receiver's view."

	^model!
model: aModel 
	"Controller|model: and Controller|view: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: so that the receiver's model and view links can be set 
	up by the view."

	model _ aModel! !

!Controller methodsFor: 'view access'!
inspectView
	view notNil ifTrue: [^ view inspect]!
view
	"Answer the receiver's view."

	^view!
view: aView 
	"Controller|view: and Controller|model: are sent by View|controller: in 
	order to coordinate the links between the model, view, and controller. In 
	ordinary usage, the receiver is created and passed as the parameter to 
	View|controller: and the receiver's model and view links are set up 
	automatically by the view."

	view _ aView! !

!Controller methodsFor: 'sensor access'!
sensor
	"Answer the receiver's sensor. Subclasses may use other objects that are 
	not instances of Sensor or its subclasses if more general kinds of 
	input/output functions are required."

	^sensor!
sensor: aSensor
	"Set the receiver's sensor to aSensor."

	sensor _ aSensor! !

!Controller methodsFor: 'basic control sequence'!
controlInitialize
	"Sent by Controller|startUp as part of the standard control sequence, it 
	provides a place in the standard control sequence for initializing the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self!
controlLoop 
	"Sent by Controller|startUp as part of the standard control sequence. 
	Controller|controlLoop sends the message Controller|isControlActive to test 
	for loop termination. As long as true is returned, the loop continues. 
	When false is returned, the loop ends. Each time through the loop, the 
	message Controller|controlActivity is sent."

	[self isControlActive] whileTrue: [self controlActivity. Processor yield]!
controlTerminate
	"Provide a place in the standard control sequence for terminating the 
	receiver (taking into account the current state of its model and view). It 
	should be redefined in subclasses to perform some specific action."

	^self!
startUp
	"Give control to the receiver. The default control sequence is to initialize 
	(see Controller|controlInitialize), to loop (see Controller|controlLoop), and 
	then to terminate (see Controller|controlTerminate). After this sequence, 
	control is returned to the sender of Control|startUp. The receiver's control 
	sequence is used to coordinate the interaction of its view and model. In 
	general, this consists of polling the sensor for user input, testing the 
	input with respect to the current display of the view, and updating the 
	model to reflect intended changes."

	self controlInitialize.
	self controlLoop.
	self controlTerminate!
terminateAndInitializeAround: aBlock
	"1/12/96 sw"
	self controlTerminate.
	aBlock value.
	self controlInitialize! !

!Controller methodsFor: 'control defaults'!
controlActivity
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. It is sent by 
	Controller|controlLoop each time through the main control loop. It should 
	be redefined in a subclass if some other action is needed."

	self controlToNextLevel!
controlToNextLevel
	"Pass control to the next control level (that is, to the Controller of a 
	subView of the receiver's view) if possible. The receiver finds the 
	subView (if any) of its view whose inset display box (see 
	View|insetDisplayBox) contains the sensor's cursor point. The Controller 
	of this subView is then given control if it answers true in response to 
	the message Controller|isControlWanted."

	| aView |
	aView _ view subViewWantingControl.
	aView ~~ nil ifTrue: [aView controller startUp]!
isControlActive
	"Answer whether receiver wishes to continue evaluating its controlLoop 
	method. It is sent by Controller|controlLoop in order to determine when 
	the receiver's control loop should terminate, and should be redefined in 
	a subclass if some special condition for terminating the main control loop 
	is needed."

	^ self viewHasCursor
		& sensor blueButtonPressed not
		& sensor yellowButtonPressed not
		"& sensor cmdKeyPressed not"!
isControlWanted
	"Answer whether the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view. It is sent by 
	Controller|controlNextLevel in order to determine whether or not control 
	should be passed to this receiver from the Controller of the superView of 
	this receiver's view."

	^self viewHasCursor!
yellowButtonPushed
	| message superView menu |
	"Supports several controllers whose only common ancestor is Controller"
	menu _  Sensor leftShiftDown
		ifTrue: [self class debuggingMenu]
		ifFalse: [self class editingMenu].
	message _ menu startUpWithCaption: model class name.
	((superView _ view superView) respondsTo: message)
		ifTrue: [superView perform: message]
		ifFalse: [(view respondsTo: message)
			ifTrue: [view perform: message]
			ifFalse: [self perform: message]]! !

!Controller methodsFor: 'cursor'!
centerCursorInView
	"Position sensor's mousePoint (which is assumed to be connected to the 
	cursor) to the center of its view's inset display box (see 
	Sensor|mousePoint: and View|insetDisplayBox)."

	^sensor cursorPoint: view insetDisplayBox center!
viewHasCursor
	"Answer whether the cursor point of the receiver's sensor lies within the 
	inset display box of the receiver's view (see View|insetDisplayBox). 
	Controller|viewHasCursor is normally used in internal methods."

	^view containsPoint: sensor cursorPoint! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Controller class
	instanceVariableNames: ''!

!Controller class methodsFor: 'instance creation'!
hasEditingMenu
	^ false!
new

	^super new initialize! !Object subclass: #ControlManager
	instanceVariableNames: 'scheduledControllers activeController activeControllerProcess screenController newTopClicked '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Framework'!
ControlManager comment:
'I represent the top level control over scheduling which controller of a view on the screen the user is actively using. ScheduledControllers is the global reference to an instance of me, the one attached to the Project currently being used.'!

!ControlManager methodsFor: 'initialize-release'!
initialize
	"Initialize the receiver to refer to only the background controller."
	| screenView |
	screenController _ ScreenController new.
	screenView _ FormView new.
	screenView model: (InfiniteForm with: Color gray) controller: screenController.
	screenView window: Display boundingBox.
	scheduledControllers _ OrderedCollection with: screenController!
release 
	"Refer to the comment in Object|release."

	scheduledControllers == nil
		ifFalse: 
			[scheduledControllers 
				do: [:controller | (controller isKindOf: Controller)
								ifTrue: [controller view release]
								ifFalse: [controller release]].
			scheduledControllers _ nil]! !

!ControlManager methodsFor: 'accessing'!
activeController
	"Answer the currently active controller."

	^activeController!
activeController: aController 
	"Set aController to be the currently active controller. Give the user 
	control in it."

	activeController _ aController.
	(activeController == screenController)
		ifFalse: [self promote: activeController].
	activeControllerProcess _ 
			[activeController startUp.
			self searchForActiveController] newProcess.
	activeControllerProcess priority: Processor userSchedulingPriority.
	activeControllerProcess resume!
activeControllerNoTerminate: aController andProcess: aProcess
	"Set aController to be the currently active controller and aProcess to be 
	the the process that handles controller scheduling activities in the 
	system. This message differs from activeController:andProcess: in that it 
	does not send controlTerminate to the currently active controller."

	self inActiveControllerProcess
		ifTrue: 
			[aController~~nil
				ifTrue: [(scheduledControllers includes: aController)
							ifTrue: [self promote: aController]
							ifFalse: [self error: 'Old controller not scheduled']].
			activeController _ aController.
			activeController == nil
				ifFalse: [activeController controlInitialize].
			activeControllerProcess _ aProcess.
			activeControllerProcess resume]
		ifFalse: 
			[self error: 'New active controller process must be set from old one'] !
activeControllerProcess
	"Answer the process that is currently handling controller scheduling 
	activities in the system."

	^activeControllerProcess!
controllerSatisfying: aBlock
	"Return the first scheduled controller which satisfies the 1-argument boolean-valued block, or nil if none.  7/25/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController) == true ifTrue: [^ aController]].
	^ nil!
controllerWhoseModelSatisfies: aBlock
	"Return the first scheduled controller whose model satisfies the 1-argument boolean-valued block, or nil if none.  5/6/96 sw"

	scheduledControllers do:
		[:aController | (aBlock value: aController model) == true ifTrue: [^ aController]].
	^ nil!
includes: aController
	^ scheduledControllers includes: aController!
noteNewTop
	newTopClicked _ true!
scheduledControllers
	"Answer a copy of the ordered collection of scheduled controllers."

	^scheduledControllers copy!
scheduledWindowControllers
	"Same as scheduled controllers, but without ScreenController.  1/13/96 sw"

	^ scheduledControllers copyWithout: screenController!
screenController
	^ screenController!
topmostInactiveTextController
	"Answer the controller of the window just below the topmost window.  1/31/96 sw"

	| aView |
	scheduledControllers doWithIndex: [:ctrlr :i |
		( i > 1 & ctrlr isKindOf: StandardSystemController)
			ifTrue:
				[(aView _ ctrlr view textEditorView) ~~ nil
					ifTrue:
						[^ aView controller]]].
	^ nil!
windowOriginsInUse
	"Answer a collection of the origins of windows currently on the screen in the current project.  5/21/96 sw"

	^ self scheduledWindowControllers collect: [:aController | aController view displayBox origin].! !

!ControlManager methodsFor: 'scheduling'!
activateController: aController
	"Make aController, which must already be a scheduled controller, the active window.  5/8/96 sw"

	self activeController: aController.
	(activeController view labelDisplayBox
		intersect: Display boundingBox) area < 200
			ifTrue: [activeController move].
	Processor terminateActive!
activateTranscript
	"There is known to be a Transcript open in the current project; activate it.  2/5/96 sw"

	| itsController |
	itsController _ scheduledControllers detect:
			[:controller | controller model == Transcript]
		ifNone:
			[^ self].

	self activeController: itsController.
	(activeController view labelDisplayBox
			intersect: Display boundingBox) area < 200
				ifTrue: [activeController move].
	Processor terminateActive!
findWindow
	"Present a menu of window titles, and activate the one that gets chosen.
	5/8/96 sw: use activateController:"

	| controllers labels index |
	controllers _ OrderedCollection new.
	labels _ String streamContents:
		[:strm |
		scheduledControllers do:
			[:controller | controller == screenController ifFalse:
				[controllers addLast: controller.
				strm nextPutAll: (controller view label contractTo: 40); cr]].
		strm skip: -1  "drop last cr"].
	index _ (PopUpMenu labels: labels) startUp.
	index > 0 ifTrue:
		[self activateController: (controllers at: index)]!
findWindowSatisfying: aBlock
	"Present a menu of window titles, and activate the one that gets chosen
	 1/18/96 sw: Created this version with an argument for more general use, and also, as per Dan's request, modified so that windows whose topleft corners are beyond the lower-right screen corner get picked up by the window-rescue piece.
	 5/8/96 sw: use activateController:"

	| controllers labels index |
	controllers _ OrderedCollection new.
	labels _ String streamContents:
		[:strm |
		scheduledControllers do:
			[:controller | controller == screenController ifFalse:
				[(aBlock value: controller) ifTrue:
					[controllers addLast: controller.
					strm nextPutAll: (controller view label contractTo: 40); cr]]].
		strm position == 0 ifTrue: [^ self].  "Nothing satisfies"
		strm skip: -1  "drop last cr"].

	index _ (PopUpMenu labels: labels) startUp.
	index > 0 ifTrue:
		[self activateController: (controllers at: index)]!
inActiveControllerProcess
	"Answer whether the active scheduling process is the actual active 
	process in the system."

	^activeControllerProcess == Processor activeProcess!
interruptName: title
	"Create a Notifier on the active scheduling process whose label is title 
	Make the Notifier the active controller."

	| newActiveController suspendingList |
	suspendingList _ activeControllerProcess suspendingList.
	suspendingList isNil
		ifTrue: [activeControllerProcess==Processor activeProcess
						ifTrue: [activeControllerProcess suspend]]
		ifFalse: [suspendingList remove: activeControllerProcess.
				 activeControllerProcess offList].
	newActiveController _ 
		(DebuggerView openInterrupt: title
					  onProcess: activeControllerProcess)
							controller.
	activeController ~~ nil
			ifTrue: [activeController controlTerminate].
	newActiveController centerCursorInView.
	self activeController: newActiveController
!
potentialController
	"Answer the controller of the window directly under the cursor.  Answer nil if the cursor is not over a window or the window is collapsed."

	| pt |
	pt _ Sensor cursorPoint.
	^scheduledControllers detect: [:controller |
		(controller view insetDisplayBox containsPoint: pt)
		& (controller isKindOf: StandardSystemController)
		and: [controller view isCollapsed not]] ifNone: [screenController]!
promote: aController
	"Make aController be the first scheduled controller in the ordered 
	collection."
	
	scheduledControllers remove: aController.
	scheduledControllers addFirst: aController!
scheduleActive: aController 
	"Make aController be scheduled as the active controller. Presumably the 
	active scheduling process asked to schedule this controller and that a 
	new process associated this controller takes control. So this is the last act 
	of the active scheduling process."

	self scheduleActiveNoTerminate: aController.
	Processor terminateActive!
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!
scheduleOnBottom: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the end of the ordered collection of controllers."

	scheduledControllers addLast: aController!
schedulePassive: aController 
	"Make aController be scheduled as a scheduled controller, but not the 
	active one. Put it at the beginning of the ordered collection of 
	controllers."

	scheduledControllers addFirst: aController!
searchForActiveController
	"Find a scheduled controller that wants control and give control to it. If 
	none wants control, then see if the System Menu has been requested."
	| aController |
	activeController _ nil.
	activeControllerProcess _ Processor activeProcess.
	self activeController: self nextActiveController.
	Processor terminateActive!
unschedule: aController
	"Remove the view, aController, from the collection of scheduled 
	controllers."

	scheduledControllers remove: aController ifAbsent: []!
windowFromUser
	"Present a menu of window titles, and returns the StandardSystemController belonging to the one that gets chosen, or nil if none"
	| controllers labels index |
	controllers _ OrderedCollection new.
	labels _ String streamContents:
		[:strm |
		scheduledControllers do:
			[:controller | controller == screenController ifFalse:
				[controllers addLast: controller.
				strm nextPutAll: (controller view label contractTo: 40); cr]].
		strm skip: -1  "drop last cr"].
	index _ (PopUpMenu labels: labels) startUp.
	^ index > 0
		ifTrue:
			[controllers at: index]
		ifFalse:
			[nil]! !

!ControlManager methodsFor: 'displaying'!
backgroundForm: aForm
	screenController view model: aForm.
	ScheduledControllers restore
"
	QDPen new mandala: 30 diameter: 640.
	ScheduledControllers backgroundForm:
		(Form fromDisplay: Display boundingBox).

	ScheduledControllers backgroundForm:
		(InfiniteForm with: Form gray).
"!
bring: aController nextToTopFor: actionBlock
	"Allows transcript to display reasonably.  The transcript will
	appear on top during display.  Then by promoting it
	next to top, it will remain on top if at all possible - ie if it isnt
	under the active window.  If it is under the active window, it will
	still come to the top during display, and then drop back to second.
	Actually, it is promoted to top if necessary for the duration of the 
	action block so that things like label updating will work properly."
	| position value aPort aPortRect |
	position _ scheduledControllers indexOf: aController.
	position <= 1 ifTrue: [^ actionBlock value].
	self promote: aController.
	activeController == screenController ifFalse:
		[activeController view cacheBitsAsIs].
	aController controlInitialize.
	aPortRect _ aController view displayBox
					merge: aController view labelDisplayBox.
	value _ actionBlock value.
	aController controlTerminate.
	self promote: (scheduledControllers at: 2).
	activeController == screenController ifFalse:
		[aPort _ (BitBlt toForm: Display) clipRect: aPortRect.
		activeController view displayOn: aPort]!
restore
	"Clear the screen to gray and then redisplay all the scheduled views.  Try to be a bit intelligent about the view that wants control and not display it twice if possible..
	1/24/96 sw: uncache bits of top view"

	scheduledControllers first view uncacheBits.  "assure refresh"
	self unschedule: screenController; scheduleOnBottom: screenController.
	screenController view window: Display boundingBox.
	scheduledControllers reverseDo:
		[:aController | aController view displayDeEmphasized].
!
restore: aRectangle
	"Restore all windows visible in aRectangle"
	^ self restore: aRectangle below: 1 without: nil!
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]!
restore: aRectangle without: aView
	"Restore all windows visible in aRectangle"
	^ self restore: aRectangle below: 1 without: aView!
updateGray
	(screenController view model isMemberOf: InfiniteForm)
		ifTrue: [screenController view model: (InfiniteForm with: Color gray)]! !

!ControlManager methodsFor: 'private'!
deactivate
	activeController _ nil.
	activeControllerProcess _ nil.	
	self unCacheWindows!
nextActiveController
	"Answer the controller that would like control.  
	If there was a click outside the active window, it's the top window
	that now has the mouse, otherwise it's just the top window."

	(newTopClicked notNil and: [newTopClicked])
		ifTrue: [newTopClicked _ false.
				^ scheduledControllers 
					detect: [:aController | aController isControlWanted]
					ifNone: [scheduledControllers first]]
		ifFalse: [^ scheduledControllers first]!
scheduled: aController from: aProcess

	activeControllerProcess==aProcess
		ifTrue: 
			[activeController ~~ nil
					ifTrue: [activeController controlTerminate].
			aController centerCursorInView.
			self activeController: aController]!
unCacheWindows
	scheduledControllers do:
		[:aController | aController view uncacheBits]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ControlManager class
	instanceVariableNames: ''!

!ControlManager class methodsFor: 'instance creation'!
new
	^super new initialize! !

!ControlManager class methodsFor: 'exchange'!
newScheduler: controlManager
	"When switching projects, the control scheduler has to be exchanged. The 
	active one is the one associated with the current project."

	ScheduledControllers deactivate.
	Smalltalk at: #ScheduledControllers put: controlManager.
	ScheduledControllers restore.
	controlManager searchForActiveController! !

!ControlManager class methodsFor: 'snapshots'!
shutDown  "Saves space in snapshots"
	ScheduledControllers deactivate!
startUp
	ScheduledControllers restore! !FillInTheBlankController subclass: #CRFillInTheBlankController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
CRFillInTheBlankController comment:
'I am a FillInTheBlankController that eliminates the yellow button menu options for paragraph editing and causes termination on a carriage return.'!

!CRFillInTheBlankController methodsFor: 'basic control sequence'!
controlInitialize

	startBlock _ paragraph characterBlockForIndex: startBlock stringIndex.
	stopBlock _ paragraph characterBlockForIndex: stopBlock stringIndex.
	self initializeSelection.
	beginTypeInBlock _ nil!
controlTerminate

	"self closeTypeIn ifTrue: [startBlock _ stopBlock copy]."
	"so leaving and entering window won't select last type-in"
	super controlTerminate! !

!CRFillInTheBlankController methodsFor: 'sensor access'!
dispatchOnCharacter: char with: typeAheadStream
	"Check for CR and cause an ACCEPT"

	(char = Character cr) | (char = Character enter)
		ifTrue: [sensor keyboard. 	"gobble cr"
				self replaceSelectionWith:
					(Text string: typeAheadStream contents
						emphasis: emphasisHere).
				self accept.
				^ true]
		ifFalse: [^ super dispatchOnCharacter: char with: typeAheadStream]!
processYellowButton

	^self! !Form subclass: #Cursor
	instanceVariableNames: ''
	classVariableNames: 'SquareCursor NormalCursor OriginCursor ReadCursor BlankCursor MenuCursor WaitCursor MoveCursor CurrentCursor XeqCursor WriteCursor MarkerCursor DownCursor RightArrowCursor CrossHairCursor UpCursor CornerCursor '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
Cursor comment:
'I am a 16 x 16 dot matrix suitable for use as the Alto hardware cursor.'!

!Cursor methodsFor: 'updating'!
changed: aParameter

	self == CurrentCursor ifTrue: [self beCursor].
	super changed: aParameter! !

!Cursor methodsFor: 'displaying'!
beCursor
	"Primitive. Tell the interpreter to use the receiver as the current cursor 
	image. Fail if the receiver does not match the size expected by the 
	hardware. Essential. See Object documentation whatIsAPrimitive."

	<primitive: 101>
	self primitiveFailed!
show
	"Make the current cursor shape be the receiver."

	Sensor currentCursor: self!
showGridded: gridPoint 
	"Make the current cursor shape be the receiver, forcing the location of the cursor to the point nearest gridPoint."
	
	Sensor cursorPoint: (Sensor cursorPoint grid: gridPoint).
	Sensor currentCursor: self!
showWhile: aBlock 
	"While evaluating the argument, aBlock, make the receiver be the cursor 
	shape."

	| oldcursor value |
	oldcursor _ Sensor currentCursor.
	self show.
	value _ aBlock value.
	oldcursor show.
	^value! !

!Cursor methodsFor: 'printing'!
printOn: aStream

	self storeOn: aStream base: 2! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Cursor class
	instanceVariableNames: ''!

!Cursor class methodsFor: 'class initialization'!
initCorner

	CornerCursor _ 
		(Cursor 
			extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
!
initCrossHair

	CrossHairCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r1111111111111110
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0000000100000000
		2r0)
			offset: -7@-7).
	
	!
initDown

	DownCursor  _
		     (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r1111110000000000
		2r111100000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
!
initialize
	"Create all the standard cursors
		Cursor origin
		Cursor rightArrow
		Cursor menu
		Cursor corner
		Cursor read
		Cursor write
		Cursor wait
		Cursor blank
		Cursor xeq
		Cursor square
		Cursor normal
		Cursor crossHair
		Cursor marker
		Cursor up
		Cursor down
		Cursor move"

		self initOrigin.
		self initRightArrow.
		self initMenu.
		self initCorner.
		self initRead.
		self initWrite.
		self initWait.
		BlankCursor _ Cursor new.
		self initXeq.
		self initSquare.
		self initNormal.
		self initCrossHair.
		self initMarker.
		self initUp.
		self initDown.
		self initMove.

		"Cursor initialize"
!
initMarker

	MarkerCursor _ 
		Cursor
			extent: 16@16
			fromArray: #(
		2r0111000000000000
		2r1111100000000000
		2r1111100000000000
		2r0111000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
			offset: 0@0.
!
initMenu 

	MenuCursor  _
		        (Cursor
	extent: 16@16
	fromArray: #(
		2r1111111111100000
		2r1000000000100000
		2r1010011000100000
		2r1000000000100000
		2r1011001010100000
		2r1000000000100000
		2r1010110010100000
		2r1000000000100000
		2r1010010100100000
		2r1000000000100000
		2r1111111111100000
		2r1101001101100000
		2r1111111111100000
		2r1000000000100000
		2r1010101100100000
		2r1111111111100000)
	offset: 0@0).
!
initMove

	MoveCursor _ 
		Cursor 
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1111111111111111
		2r1111111111111111
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1100000110000011
		2r1111111111111111
		2r1111111111111111)
			offset: 0@0.
!
initNormal

	NormalCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000000000
		2r1100000000000000
		2r1110000000000000
		2r1111000000000000
		2r1111100000000000
		2r1111110000000000
		2r1111111000000000
		2r1111100000000000
		2r1111100000000000
		2r1001100000000000
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).

	
	!
initOrigin

	OriginCursor _   
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
!
initRead

	ReadCursor _  
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0000110000000110
		2r0001001000001001
		2r0001001000001001
		2r0010000000010000
		2r0100000000100000
		2r1111101111100000
		2r1000010000100000
		2r1000010000100000
		2r1011010110100000
		2r0111101111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
!
initRightArrow 

	RightArrowCursor  _
		      (Cursor
	extent: 16@16
	fromArray: #(
		2r100000000000
		2r111000000000
		2r1111111110000000
		2r111000000000
		2r100000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
	
	"Cursor initRightArrow"!
initSquare

	SquareCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0000001111000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: -8@-8).

	!
initUp

	UpCursor _ 
		    (Cursor
	extent: 16@16
	fromArray: #(
		2r11000000000000
		2r111100000000000
		2r1111110000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r11000000000000
		2r0
		2r0
		2r0
		2r0
		2r0
		2r0)
	offset: 0@0).
!
initWait

	WaitCursor _ 
		  (Cursor
			extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1000000000000001
		2r0100000000000010
		2r0010000000000100
		2r0001110000111000
		2r0000111101110000
		2r0000011011100000
		2r0000001111000000
		2r0000001111000000
		2r0000010110100000
		2r0000100010010000
		2r0001000110001000
		2r0010001101000100
		2r0100111111110010
		2r1011111111111101
		2r1111111111111111)
			offset: 0@0).
!
initWrite

	WriteCursor _ (Cursor
	extent: 16@16
	fromArray: #(
		2r0000000000000110
		2r0000000000001111
		2r0000000000010110
		2r0000000000100100
		2r0000000001001000
		2r0000000010010000
		2r0000000100100000
		2r0000001001000011
		2r0000010010000010
		2r0000100100000110
		2r0001001000001000
		2r0010010000001000
		2r0111100001001000
		2r0101000010111000
		2r0110000110000000
		2r1111111100000000)
	offset: 0@0).
!
initXeq

	XeqCursor _ 
		(Cursor
			extent: 16@16
			fromArray: #(
		2r1000000000010000
		2r1100000000010000
		2r1110000000111000
		2r1111000111111111
		2r1111100011000110
		2r1111110001000100
		2r1111111001111100
		2r1111000001101100
		2r1101100011000110
		2r1001100010000010
		2r0000110000000000
		2r0000110000000000
		2r0000011000000000
		2r0000011000000000
		2r0000001100000000
		2r0000001100000000)
	offset: 0@0).
!
startUp
	self currentCursor: self currentCursor! !

!Cursor class methodsFor: 'instance creation'!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer a new instance of me with width and height specified by
	extentPoint, offset by offsetPoint, and bits from anArray.
	NOTE: This has been kluged to take an array of 16-bit constants,
	and shift them over so they are left-justified in a 32-bit bitmap"

	extentPoint = (16 @ 16)
		ifTrue: 
			[^ super
				extent: extentPoint
				fromArray: (anArray collect: [:bits | bits bitShift: 16])
				offset: offsetPoint]
		ifFalse: [self error: 'cursors must be 16@16']!
new

	^self
		extent: 16 @ 16
		fromArray: Array new
		offset: 0 @ 0

	"Cursor new bitEdit show"! !

!Cursor class methodsFor: 'current cursor'!
currentCursor
	"Answer the instance of Cursor that is the one currently displayed."

	^CurrentCursor!
currentCursor: aCursor 
	"Make the instance of cursor, aCursor, be the current cursor. Display it. 
	Create an error if the argument is not a Cursor."

	aCursor class == self
		ifTrue: 
			[CurrentCursor _ aCursor.
			aCursor beCursor]
		ifFalse: [self error: 'The new cursor must be an instance of class Cursor']! !

!Cursor class methodsFor: 'constants'!
blank
	"Answer the instance of me that is all white."

	^BlankCursor!
bottomLeft
	"Cursor bottomLeft showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1111111111111111
		2r1111111111111111)
			offset: 0@-16).
!
bottomRight
	"Cursor bottomRight showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r1111111111111111
		2r1111111111111111)
			offset: -16@-16).
!
corner
	"Answer the instance of me that is the shape of the bottom right corner 
	of a rectangle."

	^CornerCursor!
crossHair
	"Answer the instance of me that is the shape of a cross."

	^CrossHairCursor!
down
	"Answer the instance of me that is the shape of an arrow facing 
	downward."

	^DownCursor!
execute
	"Answer the instance of me that is the shape of an arrow slanted left 
	with a star next to it."

	^XeqCursor!
marker
	"Answer the instance of me that is the shape of a small ball."

	^MarkerCursor!
menu 
	"Answer the instance of me that is the shape of a menu."

	^MenuCursor!
move
	"Answer the instance of me that is the shape of a cross inside a square."

	^MoveCursor!
normal
	"Answer the instance of me that is the shape of an arrow slanted left."

	^NormalCursor!
origin
	"Answer the instance of me that is the shape of the top left corner of a 
	rectangle."

	^OriginCursor!
read
	"Answer the instance of me that is the shape of eyeglasses."

	^ReadCursor!
rightArrow 
	"Answer the instance of me that is the shape of an arrow pointing to the right."

	^RightArrowCursor!
square
	"Answer the instance of me that is the shape of a square."

	^SquareCursor!
topLeft
	"Cursor topLeft showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000
		2r1100000000000000)
			offset: 0@0).
!
topRight
	"Cursor topRight showWhile: [Sensor waitButton]"
	^ (Cursor extent: 16@16
			fromArray: #(
		2r1111111111111111
		2r1111111111111111
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011
		2r0000000000000011)
			offset: -16@0).
!
up
	"Answer the instance of me that is the shape of an arrow facing upward."

	^UpCursor!
wait
	"Answer the instance of me that is the shape of an Hourglass (was in the 
	shape of three small balls)."

	^WaitCursor!
write
	"Answer the instance of me that is the shape of a pen writing."

	^WriteCursor! !

Cursor initialize!
Path subclass: #Curve
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
Curve comment:
'I represent a conic section determined by three points p1,p2 and p3. I interpolate p1 and p3 and am tangent to line p1,p2 at p1 and line p3,p2 at p3.'!

!Curve methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm

	| pa pb k s p1 p2 p3 line |
	line _ Line new.
	line form: self form.
	collectionOfPoints size < 3 ifTrue: [self error: 'Curve must have three points'].
	p1 _ self firstPoint.
	p2 _ self secondPoint.
	p3 _ self thirdPoint.
	s _ Path new.
	s add: p1.
	pa _ p2 - p1.
	pb _ p3 - p2.
	k _ 5 max: pa x abs + pa y abs + pb x abs + pb y abs // 20.
	"k is a guess as to how many line segments to use to approximate 
	the curve."
	1 to: k do: 
		[:i | 
		s add: pa * i // k + p1 * (k - i) + (pb * (i - 1) // k + p2 * (i - 1)) // (k - 1)].
	s add: p3.
	1 to: s size - 1 do: 
		[:i | 
		line beginPoint: (s at: i).
		line endPoint: (s at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| transformedPath newCurve |
	transformedPath _ aTransformation applyTo: self.
	newCurve _ Curve new.
	newCurve firstPoint: transformedPath firstPoint.
	newCurve secondPoint: transformedPath secondPoint.
	newCurve thirdPoint: transformedPath thirdPoint.
	newCurve form: self form.
	newCurve
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Curve class
	instanceVariableNames: ''!

!Curve class methodsFor: 'instance creation'!
new

	| newSelf | 
	newSelf _ super new: 3.
	newSelf add: 0@0.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !

!Curve class methodsFor: 'examples'!
example
	"Designate three locations on the screen by clicking any button. The
	curve determined by the points will be displayed with a long black form."

	| aCurve aForm |  
	aForm _ Form extent: 1@30.			"make a long thin Form for display "
	aForm fillBlack.							"turn it black"
	aCurve _ Curve new.
	aCurve form: aForm.						"set the form for display"
				"collect three Points and show them on the dispaly"
	aCurve firstPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurve firstPoint.
	aCurve secondPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurve secondPoint.
	aCurve thirdPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aCurve thirdPoint.

	aCurve displayOn: Display					"display the Curve"

	"Curve example"! !Stream subclass: #DataStream
	instanceVariableNames: 'byteStream '
	classVariableNames: 'TypeMap '
	poolDictionaries: ''
	category: 'Object Storage'!
DataStream comment:
'This is an interim save-to-disk facility. A DataStream can store one
or more objects in a persistent form.

To handle objects with sharing and cycles, you must use a
ReferenceStream instead of a DataStream. ReferenceStream is typically
faster and produces smaller files because it doesn''t repeatedly write
the same class Symbols.

Here is the way to use DataStream and ReferenceStream:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	rr nextPut: <your object>.
	rr close.

To get it back:
	rr _ ReferenceStream fileNamed: ''test.obj''.
	<your object> _ rr next.
	rr close.

Each object to be stored has two opportunities to control what gets stored. The high level, more useful hook is objectToStoreOnDataStream [externalize]. The low level hook is storeDataOn:. The read-in counterparts to these messages are comeFullyUpOnReload [internalize] and (class) readDataFrom:size:. See these methods, the class DiskProxy, and the class IOWeakArray for more information about externalizing and internalizing.

Public messages:
    (class) on:
    (class) fileNamed:
    (class) fileTypeCode
    atEnd
    beginInstance:size: (for use by storeDataOn: methods)
    beginReference: (for use by readDataFrom:size: methods)
    close
    next
    next:
    nextPut:
    nextPutAll:
    reset
    setType:
    size

NOTE: A DataStream should be treated as a read-stream *or* as a
write-stream, *not* as a read/write-stream.

[TBD] We should be able to make this much faster via tight-loop
byte-string I/O. It looks like FileStream (and WriteStream)
nextPutAll: do a reasonable job *if* it doesn''t have to push the
writeLimit, in which case it iterates with nextPut:. It could in many
cases set the writeLimit and then use the fast case
(replaceFrom:to:with:startingAt:), or fill a buffer at at time via
the fast case working on a substring.
    This approach would handle Strings, ByteArrays, and all other
variable-byte classes. If(nextPutAll: aCollection) in some cases
still reverts to (aCollection do: [:e | self nextPut: e]), then we''d
want to make Obj respond to do:. Then we could speed up inner
loop activities like nextPutInt32:.

[TBD] Every DataStream should begin with 4 signature bytes.
"on:" should emit or check the signature. But the current mechanism doesn''t always
know when the stream is started or ended.

[TBD] Cf. notes in DataStream>>beginInstance:size: and
Object>>readDataFrom:size:.

[TBD] We could save disk space & I/O time by using short, 1-byte size
fields whenever possible. E.g. almost all Symbols are shorter than
256 chars. We could do this either by (1) using different typeID codes
to indicate when a 1-byte length follows, a scheme which could still
read all the old files but would take more code, or (2) a
variable-length code for sizes.
    -- 11/15/92 jhm'!

!DataStream methodsFor: 'as yet unclassified'!
atEnd
    "Answer true if the stream is at the end."

    ^ byteStream atEnd!
beginInstance: aClass size: anInteger
	"This is for use by storeDataOn: methods.
	 Cf. Object>>storeDataOn:."

		"Addition of 1 seems to make extra work, since readInstance
		has to compensate.  Here for historical reasons dating back
		to Kent Beck's original implementation in late 1988.

		Also, we could save 5 bytes per instance by putting a Str255
		on byteStream instead of putting a Symbol on self (which
		entails a 1-byte type tag and a 4-byte length count).

		Also, we could be more robust by emitting info indicating
		whether aClass is fixed or variable, pointer or bytes, and
		how many instance vars it has."

	byteStream nextNumber: 4 put: anInteger + 1.

	self nextPut: aClass name!
beginReference: anObject
    "WeÕre starting to read anObject. Remember it and its reference
     position (if we care; ReferenceStream cares). Answer the
     reference position."

    ^ 0!
errorWriteReference: anInteger
    "PRIVATE -- Raise an error because this case of nextPut:Õs perform:
     shouldn't be called. -- 11/15/92 jhm"

    self error: 'This should never be called'!
flush
    "Guarantee that any writes to me are actually recorded on disk. -- 11/17/92 jhm"

    ^ byteStream flush!
getCurrentReference
    "PRIVATE -- Return the currentReference posn.
     Overridden by ReferenceStream."

    ^ 0!
internalize: externalObject
    "PRIVATE -- We just read externalObject. Give it a chance to
        internalize. Return the internalized object."

    ^ externalObject comeFullyUpOnReload!
next: anInteger
    "Answer an Array of the next anInteger objects in the stream."
    | array |

    array _ Array new: anInteger.
    1 to: anInteger do: [:i |
        array at: i put: self next].
    ^ array!
nextPutAll: aCollection
    "Write each of the objects in aCollection to the
     receiver stream. Answer aCollection."

    ^ aCollection do: [:each | self nextPut: each]!
noteCurrentReference: typeID
    "PRIVATE -- If we support references for type typeID, remember
     the current byteStream position so we can add the next object to
     the ÔobjectsÕ dictionary, and return true. Else return false.
     This method is here to be overridden by ReferenceStream"

    ^ false!
objectAt: anInteger
    "PRIVATE -- Read & return the object at a given stream position.
     11/16/92 jhm: Renamed local variable to not clash with an instance variable."
    | savedPosn anObject refPosn |

    savedPosn _ byteStream position.
    refPosn _ self getCurrentReference.

    byteStream position: anInteger.
    anObject _ self next.

    self setCurrentReference: refPosn.
    byteStream position: savedPosn.
    ^ anObject!
outputReference: referencePosn
	"PRIVATE -- Output a reference to the object at integer stream position
	 referencePosn. To output a weak reference to an object not yet written, supply
	 (self vacantRef) for referencePosn. -- 11/15/92 jhm"

	byteStream nextPut: 10. "reference typeID"
	byteStream nextNumber: 4 put: referencePosn!
readArray
	"PRIVATE -- Read the contents of an Array.
	 We must do beginReference: here after instantiating the Array
	 but before reading its contents, in case the contents reference
	 the Array. beginReference: will be sent again when we return to
	 next, but thatÕs ok as long as we save and restore the current
	 reference position over recursive calls to next."
	| count array refPosn |

	count _ byteStream nextNumber: 4.

	refPosn _ self beginReference: (array _ Array new: count).
	1 to: count do: [:i |
		array at: i put: self next].
	self setCurrentReference: refPosn.
	^ array!
readBitmap
	"PRIVATE -- Read the contents of a Bitmap."

	^ Bitmap newFromStream: byteStream
	"Note that the reader knows that the size is in long words, but the data is in bytes."!
readBoolean
	"PRIVATE -- Read the contents of a Boolean.
	 This is here only for compatibility with old data files."

	^ byteStream next ~= 0!
readByteArray
	"PRIVATE -- Read the contents of a ByteArray."
	| count buffer |

	count _ byteStream nextNumber: 4.
	^ (ByteArray new: count)
		replaceFrom: 1 to: count with: (byteStream next: count)!
readFalse
    "PRIVATE -- Read the contents of a False."

    ^ false!
readFloat
	"PRIVATE -- Read the contents of a Float.
	 This is the fast way to read a Float.
	 We support 8-byte Floats here.  Non-IEEE"

	| new |
	new _ Float new: 2.		"To get an instance"
	new at: 1 put: (byteStream nextNumber: 4).
	new at: 2 put: (byteStream nextNumber: 4).
	^ new!
readFloatString
	"PRIVATE -- Read the contents of a Float string.
	 This is the slow way to read a Float--via its string repÕn.
	 It's here for compatibility with old data files."

	^ Float readFrom: (byteStream next: (byteStream nextNumber: 4))!
readInteger
    "PRIVATE -- Read the contents of a SmallInteger."

    ^ byteStream nextInt32	"signed!!!!!!"!
readNil
    "PRIVATE -- Read the contents of an UndefinedObject."

    ^ nil!
readReference
	"PRIVATE -- Read the contents of an object reference. Cf. outputReference:.
	 11/15/92 jhm: Support weak references."
	| referencePosition |

	^ (referencePosition _ (byteStream nextNumber: 4)) = self vacantRef
		ifTrue:  [nil]
		ifFalse: [self objectAt: referencePosition]!
readString
    "PRIVATE -- Read the contents of a String."

    ^ byteStream nextString!
readSymbol
    "PRIVATE -- Read the contents of a Symbol."

    ^ self readString asSymbol!
readTrue
    "PRIVATE -- Read the contents of a True."

    ^ true!
reset
    "Reset the stream."

    byteStream reset!
setCurrentReference: refPosn
    "PRIVATE -- Set currentReference to refPosn.
     Noop here. Cf. ReferenceStream."!
setStream: aStream
    "PRIVATE -- Initialization method."

    byteStream _ aStream!
setType
    "Set my backing stream's file type code to my default file type code.
     ASSUMES: My backing stream is a file stream. -- 11/13/92 jhm
	For now, we do not control the Mac type and creator of the file  7/26/96 tk"

   " self setType: self class fileTypeCode"!
setType: typeString
    "Set my backing stream's file type code.
     ASSUMES: My backing stream is a file stream. -- 11/13/92 jhm"

    byteStream setType: typeString!
size
    "Answer the stream's size."

    ^ byteStream size!
tryToPutReference: anObject typeID: typeID
    "PRIVATE -- If we support references for type typeID, and if
       anObject already appears in my output stream, then put a
       reference to the place where anObject already appears. If we
       support references for typeID but didnÕt already put anObject,
       then associate the current stream position with anObject in
       case one wants to nextPut: it again.
     Return true after putting a reference; false if the object still
       needs to be put.
     For DataStream this is trivial. ReferenceStream overrides this."

    ^ false!
vacantRef
    "Answer the magic 32-bit constant we use ***ON DISK*** as a stream Òreference
     positionÓ to identify a reference thatÕs not yet filled in. This must be a
     value that wonÕt be used as an ordinary reference. Cf. outputReference: and
     readReference. -- 11/15/92 jhm
     NOTE: We could use a different type ID for vacant-refs rather than writing
        object-references with a magic value. (The type ID and value are
        overwritten by ordinary object-references when weak refs are fullfilled.)
        The current approach is convenient but wouldn't work if we changed object-
        references to relative positions."

    ^ -1!
writeArray: anArray
	"PRIVATE -- Write the contents of an Array."

	byteStream nextNumber: 4 put: anArray size.
	self nextPutAll: anArray.!
writeBitmap: aBitmap
	"PRIVATE -- Write the contents of a Bitmap."

	aBitmap writeOn: byteStream
	"Note that this calls (byteStream nextPutAll: aBitmap) which knows enough to put 4-byte quantities on the stream!!  Reader must know that size is in long words."!
writeBoolean: aBoolean
    "PRIVATE -- Write the contents of a Boolean.
     This method is now obsolete."

    byteStream nextPut: (aBoolean ifTrue: [1] ifFalse: [0])!
writeByteArray: aByteArray
	"PRIVATE -- Write the contents of a ByteArray."

	byteStream nextNumber: 4 put: aByteArray size.
	"May have to convert types here..."
	byteStream nextPutAll: aByteArray.!
writeFalse: aFalse
    "PRIVATE -- Write the contents of a False."!
writeFloat: aFloat
	"PRIVATE -- Write the contents of a Float.
	  We support 8-byte Floats here."

	byteStream nextNumber: 4 put: (aFloat at: 1).
	byteStream nextNumber: 4 put: (aFloat at: 2).
!
writeFloatString: aFloat
    "PRIVATE -- Write the contents of a Float string.
     This is the slow way to write a Float--via its string repÕn."

    self writeByteArray: (aFloat printString)!
writeInstance: anObject
    "PRIVATE -- Write the contents of an arbitrary instance."

    ^ anObject storeDataOn: self!
writeInteger: anInteger
	"PRIVATE -- Write the contents of a SmallInteger."

	byteStream nextInt32Put: anInteger	"signed!!!!!!!!!!"!
writeNil: anUndefinedObject
    "PRIVATE -- Write the contents of an UndefinedObject."!
writeString: aString
	"PRIVATE -- Write the contents of a String."

	aString size < 16384 
		ifTrue: [byteStream nextStringPut: aString]
		ifFalse: [self writeByteArray: aString].	"takes more space"!
writeSymbol: aSymbol
    "PRIVATE -- Write the contents of a Symbol."

    self writeString: aSymbol!
writeTrue: aTrue
    "PRIVATE -- Write the contents of a True."! !

!DataStream methodsFor: 'imported from V'!
checkForPaths: anObject
	"After an object is fully internalized, it should have no PathFromHome in it.	The only exceptiuon in Array, as pointed to by an IncomingObjects.  8/16/96 tk"

	1 to: anObject class instSize do:
		[:i | (anObject instVarAt: i) class == PathFromHome ifTrue: [
			self error: 'Unresolved Path']].
!
close
	"Close the stream."

	| bytes |
	bytes _ byteStream position.
	byteStream close.
	^ bytes!
next
	"Answer the next object in the stream."
	| type selector anObject isARefType |

	type _ byteStream next.
	isARefType _ self noteCurrentReference: type.
	selector _ #(readNil readTrue readFalse readInteger
			readString readSymbol readByteArray
			readArray readInstance readReference readBitmap
			readClass readUser readFloat) at: type.
	anObject _ self perform: selector. "A method that recursively
		calls next (readArray, readInstance, objectAt:) must save &
		restore the current reference position."
	isARefType ifTrue: [self beginReference: anObject].

	"After reading the externalObject, internalize it.
	 #readReference is a special case. Either:
	   (1) We actually have to read the object, recursively calling
		   next, which internalizes the object.
	   (2) We just read a reference to an object already read and
		   thus already interalized.
	 Either way, we must not re-internalize the object here."
	selector == #readReference ifFalse:
		[anObject _ self internalize: anObject.
		self checkForPaths: anObject].
	^ anObject!
nextPut: anObject
	"Write anObject to the receiver stream. Answer anObject.
	 NOTE: If anObject is a reference type (one that we write cross-references to) but its externalized form (result of objectToStoreOnDataStream) isnÕt (e.g. CompiledMethod and ViewState), then we should remember its externalized form
 but not add to ÔreferencesÕ. Putting that object again should just put its
 external form again. ThatÕs more compact and avoids seeks when reading.
 But we just do the simple thing here, allowing backward-references for
 non-reference types like nil. So objectAt: has to compensate. Objects that
 externalize nicely wonÕt contain the likes of ViewStates, so this shouldnÕt
 hurt much.
	 11/15/92 jhm: writeReference: -> errorWriteReference:."
	| typeID selector objectToStore |

	typeID _ self typeIDFor: anObject.
	(self tryToPutReference: anObject typeID: typeID)
		ifTrue: [^ anObject].

	(objectToStore _ anObject objectToStoreOnDataStream) == anObject
		ifFalse: [typeID _ self typeIDFor: objectToStore].

	byteStream nextPut: typeID.
	selector _ #(writeNil: writeTrue: writeFalse: writeInteger: 
		writeString: writeSymbol: writeByteArray:
		writeArray: writeInstance: errorWriteReference: writeBitmap:
		writeClass: writeUser: writeFloat:) at: typeID.
	self perform: selector with: objectToStore.

	^ anObject!
readClass
	"PRIVATE -- For now, no classes may be written.  HyperSqueak user unique classes have not state other than methods and should be reconstructed.  Could read standard fileOut code here if necessary.  7/29/96 tk."

	"do nothing"!
readInstance
	"PRIVATE -- Read the contents of an arbitrary instance.
	 ASSUMES: readDataFrom:size: sends me beginReference: after it
	   instantiates the new object but before reading nested objects.
	 NOTE: We must restore the current reference position after
	   recursive calls to next."
	| instSize aSymbol refPosn anObject |

	instSize _ (byteStream nextNumber: 4) - 1.
	refPosn _ self getCurrentReference.
	aSymbol _ self next.
	self setCurrentReference: refPosn.  "before readDataFrom:size:"
	aSymbol endsWithDigit ifTrue: [
		self flag: #hot.
		"Remove this once we know no Alias123 are written"
		aSymbol _ aSymbol stemAndNumericSuffix at: 1].
	anObject _ (Smalltalk at: aSymbol asSymbol)
		readDataFrom: self size: instSize.
	self setCurrentReference: refPosn.  "before returning to next"
	^ anObject!
readUser
	"Reconstruct both the private class and the instance.  7/29/96 tk"
	| instSize aSymbol refPosn anObject |

	anObject _ self readInstance.		"Will create new unique class"
	^ anObject!
typeIDFor: anObject
	"Return the typeID for anObject's class."

	| tt |
	tt _ anObject ioType.
	tt == #User ifTrue: [^ 13].	"User Object whose class must be reconstructed"
	(anObject isKindOf: View) ifTrue: [^ 1 "nil"].	"blocked"
	(anObject isKindOf: Controller) ifTrue: [^ 1 "nil"].
	(anObject isKindOf: CompiledMethod) ifTrue: [self halt.  ^ 1 "nil"].
	
	^ TypeMap at: anObject class ifAbsent: [9 "instance"]!
writeClass: aClass
	"PRIVATE -- For now, no classes may be written.  HyperSqueak user unique classes have not state other than methods and should be reconstructed.  Could put standard fileOut code here is necessary.  7/29/96 tk."

	Obj classPool at: #ErrorHolder put: aClass.
	Transcript cr; show: 'The class ', aClass printString,' is trying to be written out.  See Obj class variable ErrorHolder.'.
	"do nothing"!
writeUser: anObject
    "Write the contents of an arbitrary User instance (and its devoted class)."
    " 7/29/96 tk"

	"If anObject is an instance of a unique user class, will lie and say it has a generic class"
    ^ anObject storeDataOn: self! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DataStream class
	instanceVariableNames: ''!
DataStream class comment:
'See comment in DataStream itself'!

!DataStream class methodsFor: 'imported from V'!
example
    "An example and test of DataStream/ReferenceStream.
     11/19/92 jhm: Use self testWith:."
    "DataStream example"
    "ReferenceStream example"
    | input sharedPoint |

    "Construct the test data."
    input _ Array new: 9.
    input at: 1 put: nil.
    input at: 2 put: true.
    input at: 3 put: (Form extent: 63 @ 50 depth: 8).
		(input at: 3) fillWithColor: Color lightBlue.
    input at: 4 put: #(3 3.0 'three').
    input at: 5 put: false.
    input at: 6 put: 1024 @ -2048.
    input at: 7 put: #x.
    input at: 8 put: (Array with: (sharedPoint _ 0 @ -30000)).
    input at: 9 put: sharedPoint.

    "Write it out, read it back, and return it for inspection."
    ^ self testWith: input!
exampleWithPictures
	"DataStream exampleWithPictures"
	| file result |
	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	(DataStream on: file) nextPut: (Form fromUser).
	file close.

	file _ FileStream fileNamed: 'Test-Picture'.
	file binary.
	result _ (DataStream on: file) next.
	file close.
	result display.
	^ result!
fileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	^ self on: ((FileStream fileNamed: aString) binary)!
fileTypeCode
    "Answer a default file type code to use for DataStream files. -- 11/13/92 jhm"

    ^ 'DatS'!
incomingObjectsClass
	"Rather HyperSqueak-specific:  Answer class that handles Incoming Objects, if present, else answer nil.  9/19/96 sw"

	| aClass |
	^ ((aClass _ Smalltalk at: #IncomingObjects ifAbsent: [nil]) isKindOf: Class)
		ifTrue:
			[aClass]
		ifFalse:
			[nil]!
initialize
	"TypeMap maps Smalltalk classes to type ID numbers which identify the data stream primitive formats.  nextPut: writes these IDs to the data stream.  NOTE: Changing these type ID numbers will invalidate all extant data stream files.  Adding new ones is OK.
	 See nextPut:, next, typeIDFor:, & ReferenceStream>>isAReferenceType:"
	"DataStream initialize"

	| refTypes t |
	refTypes _ OrderedCollection new.
	t _ TypeMap _ Dictionary new: 30. "sparse for fast hashing"

	t at: UndefinedObject put: 1.   refTypes add: 0.
	t at: True put: 2.   refTypes add: 0.
	t at: False put: 3.   refTypes add: 0.
	t at: SmallInteger put: 4.	 refTypes add: 0.
	t at: String put: 5.   refTypes add: 1.
	t at: Symbol put: 6.   refTypes add: 1.
	t at: ByteArray put: 7.   refTypes add: 1.
		"Does anything use this?"
	t at: Array put: 8.   refTypes add: 1.
	"(type ID 9 is for arbitrary instances, cf. typeIDFor:)"
		refTypes add: 1.
	"(type ID 10 is for references, cf. ReferenceStream>>tryToPutReference:)"
		refTypes add: 0.
	t at: Bitmap put: 11.   refTypes add: 1.
	t at: Metaclass put: 12.   refTypes add: 0.
	"Type ID 13 is used for HyperSqueak User classes that must be reconstructed."
		refTypes add: 1.
	t at: Float put: 14.  refTypes add: 1.
	"t at:  put: 15.  refTypes add: 0."
	ReferenceStream refTypes: refTypes.	"save it"!
newFileNamed: aString
	"Here is the way to use DataStream and ReferenceStream:
rr _ ReferenceStream fileNamed: 'test.obj'.
rr nextPut: <your object>.
rr close.
"

	^ self on: ((FileStream newFileNamed: aString) binary)!
on: aStream
    "Open a new DataStream onto a low-level I/O stream.
     11/19/92 jhm: Use new, not basicNew."

	| aClass |
	(aClass _ Smalltalk hyperSqueakSupportClass) == nil
		ifFalse:
			[aClass initSysLib].	"Get current sys globals"
	aStream binary.
    ^ self basicNew setStream: aStream!
testWith: anObject
	"As a test of DataStream/ReferenceStream, write out anObject and read it back.
	11/19/92 jhm: Set the file type. More informative file name."
	"DataStream testWith: 'hi'"
	"ReferenceStream testWith: 'hi'"
	| file result |

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	(self on: file) nextPut: anObject; setType.
	file close.

	file _ FileStream fileNamed: (self name, ' test').
	file binary.
	result _ (self on: file) next.
	file close.
	^ result! !

DataStream initialize!
Magnitude subclass: #Date
	instanceVariableNames: 'day year '
	classVariableNames: 'SecondsInDay MonthNames FirstDayOfMonth DaysInMonth WeekDayNames '
	poolDictionaries: ''
	category: 'Numeric-Magnitudes'!
Date comment:
'I represent a date. My printing format consists of an array of six elements.
	
The first three elements contain the numbers 1, 2, 3, in any order. 1 indicates that the day appears in this position, 2 indicates that the month appears in this position, and 3 indicates that the year appears in this position.
	
The fourth element is the ascii value of the character separator or the character itself.
	
The fifth element is the month format, where 1 indicates print as a number, 2 indicates print the first three characters, and 3 indicates print the entire name.
	
The six element is the year format, where 1 indicates print as a number, and 2 indicates print the number modulo 100.
	
Examples:
	#(1 2 3 32 2 1) prints as 12 Dec 1981
	#(2 1 3 $/ 1 2) prints as 12/12/81'!

!Date methodsFor: 'accessing'!
day
	"Answer the day of the year represented by the receiver."

	^day!
leap
	"Answer whether the receiver's year is a leap year."

	^Date leapYear: year!
monthIndex
	"Answer the index of the month in which the receiver falls."

	| leap firstDay |
	leap _ self leap.
	12 to: 1 by: -1 do: 
		[ :monthIndex | 
			firstDay _ (FirstDayOfMonth at: monthIndex)
							+ (monthIndex > 2 ifTrue: [leap] ifFalse: [0]).
			firstDay<= day
				ifTrue: [^monthIndex]].
	self error: 'illegal month'!
monthName
	"Answer the name of the month in which the receiver falls."

	^MonthNames at: self monthIndex!
weekday
	"Answer the name of the day of the week on which the receiver falls."

	^WeekDayNames at: self weekdayIndex!
year
	"Answer the year in which the receiver falls."

	^year! !

!Date methodsFor: 'arithmetic'!
addDays: dayCount 
	"Answer a Date that is dayCount days after the receiver."

	^Date newDay: day + dayCount
		  year: year!
subtractDate: aDate 
	"Answer the number of days between the receiver and aDate."

	year = aDate year
		ifTrue: [^day - aDate day]
		ifFalse: [^year - 1 // 4 - (aDate year // 4) + day 
						+ aDate daysLeftInYear + (year - 1 - aDate year * 365)]!
subtractDays: dayCount 
	"Answer a Date that is dayCount days before the receiver."

	^Date newDay: day - dayCount year: year! !

!Date methodsFor: 'comparing'!
< aDate 
	"Answer whether aDate precedes the date of the receiver." 

	year = aDate year
		ifTrue: [^day < aDate day]
		ifFalse: [^year < aDate year]!
= aDate 
	"Answer whether aDate is the same day as the receiver."

	self species = aDate species
		ifTrue: [^day = aDate day & (year = aDate year)]
		ifFalse: [^false]!
hash
	"Hash is reimplemented because = is implemented."

	^(year hash bitShift: 3) bitXor: day! !

!Date methodsFor: 'inquiries'!
dayOfMonth
	"Answer which day of the month is represented by the receiver."

	^day - (self firstDayOfMonthIndex: self monthIndex) + 1!
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])!
daysInYear
	"Answer the number of days in the year represented by the receiver."

	^Date daysInYear: self year!
daysLeftInYear
	"Answer the number of days in the year after the date of the receiver."

	^self daysInYear - self day!
firstDayOfMonth
	"Answer the index of the day of the year that is the first day of the 
	receiver's month."

	^self firstDayOfMonthIndex: self monthIndex!
previous: dayName 
	"Answer the previous date whose weekday name is dayName."

	^self subtractDays: 7 + self weekdayIndex - (Date dayOfWeek: dayName) \\ 7! !

!Date methodsFor: 'converting'!
asSeconds
	"Answer the seconds between a time on 1 January 1901 and the same 
	time in the receiver's day."

	^SecondsInDay * (self subtractDate: (Date newDay: 1 year: 1901))! !

!Date methodsFor: 'printing'!
mmddyy
	"Answer the receiver rendered in standard fmt mm/dd/yy. 1/17/96 sw.  2/1/96 sw Fixed to show day of month, not day.  Note that the name here is slightly misleading -- the month and day numbers don't show leading zeros, so that for example feb 1 1996 is 2/1/96"

	"Date today mmddyy"

	^ self printFormat: #(2 1 3 $/ 1 99)!
printFormat: formatArray 
	"Answer a String describing the receiver using the format denoted by the 
	argument, formatArray."

	| aStream |
	aStream _ WriteStream on: (String new: 16).
	self printOn: aStream format: formatArray.
	^aStream contents!
printOn: aStream

	self printOn: aStream format: #(1 2 3 $  3 1 )!
printOn: aStream format: formatArray 
	"Print a description of the receiver on aStream using the format denoted 
	by the argument, formatArray:
		#(item item item sep monthfmt yearfmt twoDigits)
		items:  1=day  2=month  3=year  will appear in the order given,
		separated by sep which is eaither an ascii code or character.
		monthFmt:  1=09  2=Sep  3=September
		yearFmt:  1=1996  2=96
		digits:  (missing or)1=9  2=09.
	See the examples in printOn: and mmddyy"
	| monthIndex element monthFormat twoDigits monthDay |
	twoDigits _ formatArray size > 6 and: [(formatArray at: 7) > 1].
	monthIndex _ self monthIndex.
	1 to: 3 do: 
		[:elementIndex | 
		element _ formatArray at: elementIndex.
		element = 1 ifTrue:
			[monthDay _ day - self firstDayOfMonth + 1.
			twoDigits & (monthDay < 10) ifTrue: [aStream nextPutAll: '0'].
				monthDay printOn: aStream].
		element = 2 ifTrue: 
			[monthFormat _ formatArray at: 5.
			monthFormat = 1 ifTrue:
				[twoDigits & (monthIndex < 10) ifTrue: [aStream nextPutAll: '0'].
				monthIndex printOn: aStream].
			monthFormat = 2 ifTrue:
				[aStream nextPutAll: ((MonthNames at: monthIndex)
												copyFrom: 1 to: 3)].
			monthFormat = 3 ifTrue:
				[aStream nextPutAll: (MonthNames at: monthIndex)]].
		element = 3 ifTrue: 
			[(formatArray at: 6) = 1
				ifTrue: [year printOn: aStream]
				ifFalse: [twoDigits & ((year \\ 100) < 10)
							ifTrue: [aStream nextPutAll: '0'].
						(year \\ 100) printOn: aStream]].
		elementIndex < 3 ifTrue: 
			[(formatArray at: 4) ~= 0 
				ifTrue: [aStream nextPut: (formatArray at: 4) asCharacter]]]!
storeOn: aStream

	aStream nextPutAll: '(', self class name, ' readFromString: ';
		print: self printString;
		nextPut: $)! !

!Date methodsFor: 'private'!
day: dayInteger year: yearInteger

	day _ dayInteger.
	year _ yearInteger!
firstDayOfMonthIndex: monthIndex 
	"Answer the day of the year (an Integer) that is the first day of my month"

	^(FirstDayOfMonth at: monthIndex)
		+ (monthIndex > 2
				ifTrue: [self leap]
				ifFalse: [0])!
weekdayIndex
	"Sunday=1, ... , Saturday=7"

	| yearIndex dayIndex |  
	day < (self firstDayOfMonthIndex: 3)
		ifTrue: 
			[yearIndex _ year - 1.
			dayIndex _ 307]
		ifFalse: 
			[yearIndex _ year.
			dayIndex _ -58 - self leap].  
	
	^dayIndex + day + yearIndex + (yearIndex // 4) 
				+ (yearIndex // 400) - (yearIndex // 100) \\ 7 + 1! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Date class
	instanceVariableNames: ''!

!Date class methodsFor: 'class initialization'!
initialize
	"Initialize class variables representing the names of the months and days and
	the number of seconds, days in each month, and first day of each month."

	MonthNames _ 
		#(January February March April May June 
			July August September October November December ).
	SecondsInDay _ 24 * 60 * 60.
	DaysInMonth _ #(31 28 31 30 31 30 31 31 30 31 30 31 ).
	FirstDayOfMonth _ #(1 32 60 91 121 152 182 213 244 274 305 335 ).
	WeekDayNames _ 
		#(Monday Tuesday Wednesday Thursday Friday Saturday Sunday )

	"Date initialize."
! !

!Date class methodsFor: 'instance creation'!
fromDays: dayCount
	"Answer an instance of me which is dayCount days after January 1, 
	1901."

	^self
		newDay: 1 + (dayCount asInteger rem: 1461)
							"There are 1461 days in a 4-year cycle. 
							 2000 is a leap year, so no extra correction is necessary. "
		year: 1901 + ((dayCount asInteger quo: 1461) * 4)!
newDay: day month: monthName year: year 
	"Answer an instance of me which is the day'th day of the month named 
	monthName in the year'th year. The year may be specified as the actual 
	number of years since the beginning of the Roman calendar or the 
	number of years since the beginning of the century."

	| monthIndex daysInMonth firstDayOfMonth |
	year < 100 ifTrue: [^self
			newDay: day
			month: monthName
			year: 1900 + year].
	monthIndex _ self indexOfMonth: monthName.
	monthIndex = 2
		ifTrue: [daysInMonth _ (DaysInMonth at: monthIndex)
						+ (self leapYear: year)]
		ifFalse: [daysInMonth _ DaysInMonth at: monthIndex].
	monthIndex > 2
		ifTrue: [firstDayOfMonth _ (FirstDayOfMonth at: monthIndex)
						+ (self leapYear: year)]
		ifFalse: [firstDayOfMonth _ FirstDayOfMonth at: monthIndex].
	(day < 1 or: [day > daysInMonth])
		ifTrue: [self error: 'illegal day in month']
		ifFalse: [^self new day: day - 1 + firstDayOfMonth year: year]!
newDay: dayCount year: referenceYear 
	"Answer an instance of me which is dayCount days after the beginning 
	of the year referenceYear."

	| day year daysInYear |
	day _ dayCount.
	year _ referenceYear.
	[day > (daysInYear _ self daysInYear: year)]
		whileTrue: 
			[year _ year + 1.
			 day _ day - daysInYear].
	[day <= 0]
		whileTrue: 
			[year _ year - 1.
			 day _ day + (self daysInYear: year)].
	^self new day: day year: year!
readFrom: aStream
	"Read a Date from the stream in any of the forms:
		<day> <monthName> <year>		(5 April 1982; 5-APR-82)
		<monthName> <day> <year>		(April 5, 1982)
		<monthNumber> <day> <year>	(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')"
!
today
	"Answer an instance of me representing the day and year right now."

	^self dateAndTimeNow at: 1! !

!Date class methodsFor: 'general inquiries'!
dateAndTimeNow
	"Answer an Array whose first element is Date today and second element 
	is Time now."

	^Time dateAndTimeNow!
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'!
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!
daysInYear: yearInteger 
	"Answer the number of days in the year, yearInteger."

	^365 + (self leapYear: yearInteger)!
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!
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'!
leapYear: yearInteger 
	"Answer 1 if the year yearInteger is a leap year; answer 0 if it is not."

	(yearInteger \\ 4 ~= 0 or: [yearInteger \\ 100 = 0 and: [yearInteger \\ 400 ~= 0]])
		ifTrue: [^0]
		ifFalse: [^1]!
nameOfDay: dayIndex 
	"Answer a symbol representing the name of the day indexed by 
	dayIndex, 1-7."

	^WeekDayNames at: dayIndex!
nameOfMonth: monthIndex 
	"Answer a String representing the name of the month indexed by 
	monthIndex, 1-12."

	^MonthNames at: monthIndex! !

Date initialize!
StringHolder subclass: #Debugger
	instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC sourceMap tempNames '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
Debugger comment:
'I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. As a StringHolder, the string to be viewed is the interrupted method at some point in the sequence of message-sends that have been initiated but not completed.'!

!Debugger methodsFor: 'initialize-release'!
defaultBackgroundColor
	^ #lightRed!
expandStack
	"This initialization occurs when the interrupted context is to modelled by 
	a DebuggerView, rather than a NotifierView (which can not display 
	more than five message-sends."

	self newStack: (contextStackTop stackOfSize: 7).
	contextStackIndex _ 0.
	receiverInspector _ Inspector inspect: nil.
	contextVariablesInspector _ ContextVariablesInspector inspect: nil.
	proceedValue _ nil!
release

	interruptedProcess ~~ nil ifTrue: [interruptedProcess terminate].
	interruptedProcess _ nil.
	interruptedController _ nil.
	contextStack _ nil.
	contextStackTop _ nil.
	receiverInspector _ nil.
	contextVariablesInspector _ nil.
	Smalltalk installLowSpaceWatcher.  "restart low space handler"
	super release.! !

!Debugger methodsFor: 'accessing'!
contents 
	"Depending on the current selection, different information is retrieved.
	Answer a string description of that information.  This information is the
	method in the currently selected context."

	contents == nil ifTrue: [^''].
	^contents!
contents: aString notifying: aController 
	"The retrieved information has changed and its source must now be 
	updated. In this case, the retrieved information is the method of the 
	selected context."
	| selector classOfMethod methodNode category method priorMethod |
	contextStackIndex = 0 ifTrue: [^self].
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^self]].
	classOfMethod _ self selectedClass.
	category _ self selectedMessageCategoryName.
	Cursor execute showWhile:
		[method _ classOfMethod
		compile: aString
		notifying: aController
		trailer: #(0 0 0 )
		ifFail: [^ false]
		elseSetSelectorAndNode: 
			[:sel :methodNode | selector _ sel.
			selector == self selectedMessageName
				ifFalse: [self notify: 'can''t change selector'. ^ false].
			priorMethod _ (classOfMethod includesSelector: selector)
				ifTrue: [classOfMethod compiledMethodAt: selector]
				ifFalse: [nil].
			sourceMap _ methodNode sourceMap.
			tempNames _ methodNode tempNames].
		method cacheTempNames: tempNames].
	category isNil ifFalse: "Skip this for DoIts"
		[(SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifFalse:
			[method
				putSource: aString asString
				class: classOfMethod
				category: category
				inFile: 2 priorMethod: priorMethod].
		classOfMethod organization classify: selector under: category].
	contents _ aString copy.
	self selectedContext restartWith: method.
	contextVariablesInspector object: nil.
	self resetContext: self selectedContext.
	^true!
contextVariablesInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context."

	^contextVariablesInspector!
interruptedContext
	"Answer the suspended context of the interrupted process."

	^contextStackTop!
interruptedProcess
	"Answer the interrupted process."

	^interruptedProcess!
proceedValue
	"Answer the value to return to the selected context when the interrupted 
	process proceeds."

	^proceedValue!
proceedValue: anObject 
	"Set the value to be returned to the selected context when the interrupted 
	process proceeds."

	proceedValue _ anObject!
receiver
	"Answer the receiver of the selected context, if any. Answer nil 
	otherwise."

	contextStackIndex = 0
		ifTrue: [^nil]
		ifFalse: [^self selectedContext receiver]!
receiverInspector
	"Answer the instance of Inspector that is providing a view of the 
	variables of the selected context's receiver."

	^receiverInspector! !

!Debugger methodsFor: 'code'!
doItContext
	"Answer the context in which a text selection can be evaluated."

	contextStackIndex = 0
		ifTrue: [^super doItContext]
		ifFalse: [^self selectedContext]!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^self receiver! !

!Debugger methodsFor: 'context stack'!
contextStackIndex
	"Answer the index of the selected context."

	^contextStackIndex!
contextStackList
	"Answer the array of contexts."

	^contextStackList!
fullyExpandStack
	"Expand the stack to include all of it, rather than the first four or five
	contexts."

	self okToChange ifFalse: [^ self].
	self newStack: contextStackTop stack.
	self changed: #contextStackList!
toggleContextStackIndex: anInteger 
	"If anInteger is the same as the index of the selected context, deselect it. 
	Otherwise, the context whose index is anInteger becomes the selected 
	context."

	self contextStackIndex: 
		(contextStackIndex = anInteger
			ifTrue: [0]
			ifFalse: [anInteger])
		oldContextWas:
		(contextStackIndex = 0
			ifTrue: [nil]
			ifFalse: [contextStack at: contextStackIndex])! !

!Debugger methodsFor: 'menu messages'!
close: aScheduledController 
	"The argument is a controller on a view of the receiver.
	That view is closed."

	aScheduledController close
!
proceed: aScheduledController 
	"Proceed from the interrupted state of the currently selected context. The 
	argument is a controller on a view of the receiver. That view is closed."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	contextStackIndex > 1 | externalInterrupt not 
		ifTrue: [self selectedContext push: proceedValue].
	self resumeProcess: aScheduledController!
restart: aScheduledController 
	"Proceed from the initial state of the currently selected context. The 
	argument is a controller on a view of the receiver. That view is closed."

	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	(self selectedContext isKindOf: MethodContext)
		ifFalse:
			[(self confirm:
'I will have to revert to the method from
which this block originated.  Is that OK?')
				ifTrue: [self resetContext: self selectedContext home]
				ifFalse: [^self]].
	self selectedContext restart.
	self resumeProcess: aScheduledController!
selectPC
	"Toggle the flag telling whether to automatically select the expression 
	currently being executed by the selected context."

	selectingPC _ selectingPC not! !

!Debugger methodsFor: 'message list'!
messageListIndex
	"Answer the index of the currently selected context."

	^contextStackIndex!
selectedMessage
	"Answer the source code of the currently selected context."

	contents == nil ifTrue: [contents _ self selectedContext sourceCode].
	^contents!
selectedMessageName
	"Answer the message selector of the currently selected context."

	^self selectedContext selector!
spawn: aString 
	"Create and schedule a message browser on the message, aString. Any 
	edits already made are retained."

	self messageListIndex > 0
		ifTrue: 
			[^BrowserView
				openMessageBrowserForClass: self selectedClass
				selector: self selectedMessageName
				editString: aString]! !

!Debugger methodsFor: 'message category list'!
selectedMessageCategoryName
	"Answer the name of the message category of the message of the 
	currently selected context."

	^self selectedClass organization categoryOfElement: self selectedMessageName! !

!Debugger methodsFor: 'message functions'!
browseImplementors
	"Create and schedule a message set browser on all implementors of the
	currently selected message selector. Do nothing if no message is selected."

	contextStackIndex ~= 0 
		ifTrue: [Smalltalk browseAllImplementorsOf: self selectedMessageName]!
browseMessages
	"Show a menu of all messages sent by the currently selected message.
	Create and schedule a message set browser of all implementors of the 
	message chosen. Do nothing if no message is chosen."

	contextStackIndex = 0 ifTrue: [^self].
	Smalltalk showMenuThenBrowse:
		(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			messages asSortedCollection!
browseSenders
	"Show a menu of all messages that send the currently selected message.
	Create and schedule a message set browser of of the chosen message. Do
	nothing if no message is chosen."

	contextStackIndex ~= 0 
		ifTrue: [Smalltalk browseAllCallsOn: self selectedMessageName]!
browseSendersOf
	"Show a menu of all messages sent by the currently selected message. 
	Create and schedule a message set browser of all senders of the 
	message chosen. Do nothing if no message is chosen.  Derived from
    browseMessages, 1/8/96 sw"

	contextStackIndex = 0 ifTrue: [^self].
	Smalltalk showMenuThenBrowseSenders:
		(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			messages asSortedCollection!
browseSendersOfMessages
	"Show a menu of all messages sent by the currently selected message. 
	Create and schedule a message set browser of all senders of the 
	message chosen. Do nothing if no message is chosen.  Derived from
    browseMessages, 1/8/96 sw"

	contextStackIndex = 0 ifTrue: [^self].
	Smalltalk showMenuThenBrowseSendersOf:
		(self selectedClassOrMetaClass compiledMethodAt: self selectedMessageName)
			messages asSortedCollection! !

!Debugger methodsFor: 'class list'!
selectedClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext mclass!
selectedClassOrMetaClass
	"Answer the class in which the currently selected context's method was 
	found."

	^self selectedContext mclass! !

!Debugger methodsFor: 'dependents access'!
removeDependent: aDependent

	super removeDependent: aDependent.
	self dependents isEmpty ifTrue: [self release]!
updateInspectors 
	"Update the inspectors on the receiver's variables."

	receiverInspector update.
	contextVariablesInspector update! !

!Debugger methodsFor: 'pc selection'!
pcRange
	"Answer the indices in the source code for the method corresponding to 
	the selected context's program counter value."

	| i methodNode pc end |
	(selectingPC and: [contextStackIndex ~= 0])
		ifFalse: [^1 to: 0].
	sourceMap == nil ifTrue:
		[methodNode _ self selectedClass compilerClass new
			parse: self selectedMessage
			in: self selectedClass
			notifying: nil.
		sourceMap _ methodNode sourceMap.
		tempNames _ methodNode tempNames.
		self selectedContext method cacheTempNames: tempNames].
	sourceMap size = 0 ifTrue: [^1 to: 0].
	pc_ self selectedContext pc -
		((externalInterrupt and: [contextStackIndex=1])
			ifTrue: [1]
			ifFalse: [2]).
	i _ sourceMap indexForInserting: (Association key: pc value: nil).
	i < 1 ifTrue: [^1 to: 0].
	i > sourceMap size
		ifTrue:
			[end _ sourceMap inject: 0 into:
				[:prev :this | prev max: this value last].
			^ end+1 to: end].
	^(sourceMap at: i) value! !

!Debugger methodsFor: 'code execution'!
send
	"Send the selected message in the accessed method, and take control in 
	the method invoked to allow further step or send."

	| currentContext |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext.
	currentContext stepToSendOrReturn.
	self contextStackIndex > 1 | currentContext willReturn
		ifTrue: 
			[self changed: #notChanged]
		ifFalse: 
			[currentContext _ currentContext step.
			self resetContext: currentContext]!
step
	"Send the selected message in the accessed method, and regain control 
	after the invoked method returns."
	
	| currentContext oldMethod |
	self okToChange ifFalse: [^ self].
	self checkContextSelection.
	externalInterrupt ifFalse: [contextStackTop push: proceedValue].
	externalInterrupt _ true. "simulation leaves same state as interrupting"
	currentContext _ self selectedContext.
	self contextStackIndex > 1
		ifTrue: 
			[currentContext completeCallee: contextStackTop.
			self resetContext: currentContext]
		ifFalse: 
			[currentContext stepToSendOrReturn.
			currentContext willReturn
				ifTrue: 
					[oldMethod _ currentContext method.
					currentContext _ currentContext step.
					self resetContext: currentContext.
					oldMethod == currentContext method "didnt used to update pc here"
						ifTrue: [self changed: #pc]]
				ifFalse: 
					[currentContext completeCallee: currentContext step.
					self changed: #pc.
					self updateInspectors]]! !

!Debugger methodsFor: 'private'!
checkContextSelection

	contextStackIndex = 0 ifTrue: [contextStackIndex _ 1]!
contextStackIndex: anInteger oldContextWas: oldContext

	| newMethod |
	contextStackIndex _ anInteger.
	anInteger = 0
		ifTrue:
			[tempNames _ sourceMap _ contents _ nil.
			self changed: #contextStackIndex.
			self changed: #contents.
			contextVariablesInspector object: nil.
			receiverInspector object: self receiver.
			^self].
	(newMethod _ oldContext == nil or:
		[oldContext method ~~ self selectedContext method])
		ifTrue:
			[tempNames _ sourceMap _ nil.
			contents _ self selectedContext sourceCode.
			self changed: #contents.
			self pcRange "will compute tempNamesunless noFrills"].
	self changed: #contextStackIndex.
	tempNames == nil
		ifTrue: [tempNames _ 
					self selectedClassOrMetaClass parserClass new parseArgsAndTemps: contents notifying: nil].
	contextVariablesInspector object: self selectedContext.
	receiverInspector object: self receiver.
	newMethod ifFalse: [self changed: #pc]!
externalInterrupt: aBoolean

	externalInterrupt _ aBoolean !
newStack: stack
	| oldStack diff |
	oldStack _ contextStack.
	contextStack _ stack.
	(oldStack == nil or: [oldStack last ~~ stack last])
		ifTrue: [contextStackList _ contextStack collect: [:ctx | ctx printString].
				^ self].
	"May be able to re-use some of previous list"
	diff _ stack size - oldStack size.
	contextStackList _ diff <= 0
		ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size]
		ifFalse: [diff > 1
				ifTrue: [contextStack collect: [:ctx | ctx printString]]
				ifFalse: [(Array with: stack first printString) , contextStackList]]!
process: aProcess controller: aController context: aContext

	super initialize.
	contents _ nil. 
	interruptedProcess _ aProcess.
	interruptedController _ aController.
	contextStackTop _ aContext.
	self newStack: (contextStackTop stackOfSize: 1).
	contextStackIndex _ 1.
	externalInterrupt _ false.
	selectingPC _ true!
resetContext: aContext 
	"Used when a new context becomes top-of-stack, for instance when the
	method of the selected context is re-compiled, or the simulator steps or
	returns to a new method. There is room for much optimization here, first
	to save recomputing the whole stack list (and text), and secondly to avoid
	recomposing all that text (by editing the paragraph instead of recreating it)."

	| oldContext |
	oldContext _ self selectedContext.
	contextStackTop _ aContext.
	self newStack: contextStackTop stack.
	self changed: #contextStackList.
	self contextStackIndex: 1 oldContextWas: oldContext!
resumeProcess: aScheduledController
	aScheduledController view erase.
	interruptedProcess suspendedContext method
			== (Process compiledMethodAt: #terminate) ifFalse:
		[contextStackIndex > 1
			ifTrue: [interruptedProcess popTo: self selectedContext]
			ifFalse: [interruptedProcess install: self selectedContext].
		ScheduledControllers
						activeControllerNoTerminate: interruptedController
						andProcess: interruptedProcess].
	"if old process was terminated, just terminate current one"
	interruptedProcess _ nil. 
	aScheduledController closeAndUnscheduleNoErase.
	Processor terminateActive
!
selectedContext

	contextStackIndex = 0
		ifTrue: [^contextStackTop]
		ifFalse: [^contextStack at: contextStackIndex]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Debugger class
	instanceVariableNames: ''!

!Debugger class methodsFor: 'instance creation'!
context: aContext 
	"Answer an instance of me that models the current state of the system. 
	The active process has determined that a debugger should be set up 
	(often by the user issuing the command debug)."
	| aDebugger |
	aDebugger _ self new.
	aDebugger
		process: Processor activeProcess
		controller: (ScheduledControllers inActiveControllerProcess
					ifTrue: [ScheduledControllers activeController])
		context: aContext.
	^aDebugger!
interruptProcess: interruptedProcess 
	"Answer an instance of me that models the current state of the system. 
	The active process has decided to provide a debugger on an interrupted 
	process. This message is called if the user types the ctrl c interrupt, or a 
	low space notification occurs."

	| debugger |
	debugger _ self new.
	debugger
		process: interruptedProcess
		controller: (ScheduledControllers activeControllerProcess == interruptedProcess
						ifTrue: [ScheduledControllers activeController])
		context: interruptedProcess suspendedContext.
	debugger externalInterrupt: true.
	^debugger! !StandardSystemView subclass: #DebuggerView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Debugger'!
DebuggerView comment:
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the interface to an interrupted process, a Debugger.'!

!DebuggerView methodsFor: 'no messages'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DebuggerView class
	instanceVariableNames: ''!

!DebuggerView class methodsFor: 'instance creation'!
debugger: aDebugger 
	"Answer a DebuggerView whose model is aDebugger. It consists of three 
	subviews, a ContextStackView (the ContextStackListView and 
	ContextStackCodeView), an InspectView of aDebugger's variables, and an 
	InspectView of the variables of the currently selected method context."

	| debuggerView contextStackView contextVariablesView receiverVariablesView |
	aDebugger expandStack.
	debuggerView _ self new model: aDebugger.
	contextStackView _ self buildContextStackView: aDebugger.
	receiverVariablesView _ self buildReceiverVariablesView: aDebugger.
	contextVariablesView _ self buildContextVariablesView: aDebugger.
	debuggerView addSubView: contextStackView.
	debuggerView
		addSubView: receiverVariablesView
		align: receiverVariablesView viewport topLeft
		with: contextStackView viewport bottomLeft.
	debuggerView
		addSubView: contextVariablesView
		align: contextVariablesView viewport topLeft
		with: receiverVariablesView viewport topRight.
	^debuggerView!
openContext: aContext label: aString 
	"Create and schedule an instance of me on a Debugger for the method 
	context, aContext. The label of the standard system view is aString."

	self openDebugger: (Debugger context: aContext)
		label: aString!
openContext: haltContext label: aString contents: contentsString
	"Create and schedule a simple view on a Debugger on haltContext.
	The view is labeled with aString and shows a short sender stack."
	ErrorRecursion
		ifTrue: 
			[ErrorRecursion _ false.
			self primitiveError: aString].
	ErrorRecursion _ true.
	self openNotifier: (Debugger context: haltContext)
		contents: contentsString
		label: aString.
	ErrorRecursion _ false.
	Processor activeProcess suspend
!
openDebugger: aDebugger label: aString 
	"Create and schedule an instance of me on the model, aDebugger. The 
	label is aString."

	self openNoSuspendDebugger: aDebugger label: aString.
	Processor activeProcess suspend!
openInterrupt: aString onProcess: interruptedProcess 
	"Create and schedule a simple view with a debugger which can be opened later."

	| aDebugger |
	aDebugger _ Debugger interruptProcess: interruptedProcess.
	^ self openNotifier: aDebugger
		contents: aDebugger interruptedContext shortStack
		label: aString!
openNoSuspendDebugger: aDebugger label: aString 
	"Answer a standard system view containing an instance of me on the model, aDebugger. The label is aString. Do not terminate the current active process. "
	| debuggerView |
	debuggerView _ self debugger: aDebugger.
	debuggerView label: aString.
	debuggerView minimumSize: 300 @ 200.
	debuggerView controller openNoTerminate.
	^ debuggerView!
openNotifier: aDebugger contents: msgString label: label
	"Create and schedule a simple view with a debugger which can be opened later."
	| aStringHolderView topView displayPoint nLines |
	self flag: #developmentNote.
	Cursor normal show.
	aStringHolderView _ StringHolderView container:
		(StringHolder new contents: msgString).
	aStringHolderView controller: (NotifyStringHolderController debugger: aDebugger).
	topView _ StandardSystemView new.
	topView model: aStringHolderView model.
	topView addSubView: aStringHolderView.
	topView label: label.
	nLines _ 1 + (msgString occurrencesOf: Character cr).
	topView minimumSize: 350 @ (14*nLines + 6).
	displayPoint _ 
		ScheduledControllers activeController == nil
			ifTrue: [Display boundingBox center]
			ifFalse: [ScheduledControllers activeController view displayBox center].
	topView controller openNoTerminateDisplayAt: displayPoint.
	^ topView! !

!DebuggerView class methodsFor: 'private'!
buildContextStackView: aDebugger

	| topView bottomView contextStackView |
	topView _ ContextStackListView new.
	topView model: aDebugger.
	topView window: (0 @ 0 extent: self contextStackLeftSize).
	topView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	bottomView _ ContextStackCodeView new.
	bottomView model: aDebugger.
	bottomView controller: ContextStackCodeController new.
	bottomView window: (0 @ 0 extent: self contextStackRightSize).
	bottomView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	contextStackView _ View new.
	contextStackView addSubView: topView.
	contextStackView
		addSubView: bottomView
		align: bottomView viewport topLeft
		with: topView viewport bottomLeft.
	^contextStackView!
buildContextVariablesView: aDebugger

	| contextVariablesView leftView rightView |
	contextVariablesView _ 
		InspectorView inspector: aDebugger contextVariablesInspector.
	contextVariablesView controller: Controller new.
	leftView _ contextVariablesView firstSubView.
	rightView _ contextVariablesView lastSubView.
	leftView window: (0 @ 0 extent: self contextVariablesLeftSize).
	leftView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	rightView window: (0 @ 0 extent: self contextVariablesRightSize).
	rightView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	rightView transformation: View identityTransformation.
	rightView align: rightView viewport topLeft with: leftView viewport topRight.
	contextVariablesView window: contextVariablesView defaultWindow.
	^contextVariablesView!
buildReceiverVariablesView: aDebugger

	| receiverVariablesView leftView rightView |
	receiverVariablesView _ InspectorView inspector: aDebugger receiverInspector.
	receiverVariablesView controller: Controller new.
	leftView _ receiverVariablesView firstSubView.
	rightView _ receiverVariablesView lastSubView.
	leftView window: (0 @ 0 extent: self receiverVariablesLeftSize).
	leftView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	rightView window: (0 @ 0 extent: self receiverVariablesRightSize).
	rightView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	rightView transformation: View identityTransformation.
	rightView align: rightView viewport topLeft with: leftView viewport topRight.
	receiverVariablesView window: receiverVariablesView defaultWindow.
	^receiverVariablesView!
contextStackLeftSize

	^150 @ 50!
contextStackRightSize
	^150 @ 75!
contextVariablesLeftSize

	^25 @ 50!
contextVariablesRightSize

	^50 @ 50!
proceedValueLeftSize

	^50 @ 10!
proceedValueRightSize

	^100 @ 10!
receiverVariablesLeftSize

	^25 @ 50!
receiverVariablesRightSize

	^50 @ 50! !InstructionStream subclass: #Decompiler
	instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit lastJumpPc lastReturnPc limit hasValue blockStackBase '
	classVariableNames: 'ArgumentFlag CascadeFlag '
	poolDictionaries: ''
	category: 'System-Compiler'!
Decompiler comment:
'I decompile a method in three phases:
	Reverser: postfix byte codes -> prefix symbolic codes (nodes and atoms)
	Parser: prefix symbolic codes -> node tree (same as the compiler)
	Printer: node tree -> text (done by the nodes)'!

!Decompiler methodsFor: 'initialize-release'!
initSymbols: aClass

	| nTemps |
	constructor
		method: method
		class: aClass
		literals: method literals.
	constTable _ constructor codeConstants.
	instVars _ Array new: aClass instSize.
	"parse the header"
	nTemps _ method numTemps.
	tempVars _ Array new: nTemps.
	1 to: nTemps do: [:i | tempVars at: i put: (constructor codeTemp: i - 1)]! !

!Decompiler methodsFor: 'control'!
blockTo: end
	"Decompile a range of code as in statementsTo:, but return a block node."
	| exprs block oldBase |
	oldBase _ blockStackBase.
	blockStackBase _ stack size.
	exprs _ self statementsTo: end.
	block _ constructor codeBlock: exprs returns: lastReturnPc = lastPc.
	blockStackBase _ oldBase.
	lastReturnPc _ -1.  "So as not to mislead outer calls"
	^block!
checkForBlock: receiver
	"We just saw a blockCopy: message. Check for a following block."

	| savePc jump args argPos block |
	receiver == constructor codeThisContext ifFalse: [^false].
	savePc _ pc.
	(jump _ self interpretJump) notNil
		ifFalse:
			[pc _ savePc.  ^nil].
	"Definitely a block"
	jump _ jump + pc.
	argPos _ statements size.
	[self willStorePop]
		whileTrue:
			[stack addLast: ArgumentFlag.  "Flag for doStore:"
			self interpretNextInstructionFor: self].
	args _ Array new: statements size - argPos.
	1 to: args size do: [:i | args at: i put: statements removeLast].  "Retrieve args"
	block _ self blockTo: jump.
	stack addLast: (constructor codeArguments: args block: block).
	^true!
statementsTo: end
	"Decompile the method from pc up to end and return an array of
	expressions. If at run time this block will leave a value on the stack,
	set hasValue to true. If the block ends with a jump or return, set exit
	to the destination of the jump, or the end of the method; otherwise, set
	exit = end. Leave pc = end."

	| blockPos stackPos t |
	blockPos _ statements size.
	stackPos _ stack size.
	[pc < end]
		whileTrue:
			[lastPc _ pc.  limit _ end.  "for performs"
			self interpretNextInstructionFor: self].
	"If there is an additional item on the stack, it will be the value
	of this block."
	(hasValue _ stack size > stackPos)
		ifTrue:
			[statements addLast: stack removeLast].
	lastJumpPc = lastPc ifFalse: [exit _ pc].
	^self popTo: blockPos! !

!Decompiler methodsFor: 'instruction decoding'!
blockReturnTop
	"No action needed"!
case: dist
	"statements = keyStmts CascadeFlag keyValueBlock ... keyStmts"

	| nextCase end thenJump stmtStream elements b node cases otherBlock |
	nextCase _ pc + dist.
	end _ limit.
	"Now add CascadeFlag & keyValueBlock to statements"
	statements addLast: stack removeLast; addLast: (self blockTo: nextCase).
	stack last == CascadeFlag
		ifFalse: "Last case"
			["ensure jump is within block (in case thenExpr returns wierdly I guess)"
			thenJump _ exit <= end ifTrue: [exit] ifFalse: [nextCase].
			stmtStream _ ReadStream on: (self popTo: stack removeLast).
			elements _ OrderedCollection new.
			b _ OrderedCollection new.
			[stmtStream atEnd] whileFalse:
				[(node _ stmtStream next) == CascadeFlag
					ifTrue:
						[elements addLast: (constructor
							codeMessage: (constructor codeBlock: b returns: false)
							selector: (constructor codeSelector: #-> code: #macro)
							arguments: (Array with: stmtStream next)).
						 b _ OrderedCollection new]
					ifFalse: [b addLast: node]].
			b size > 0 ifTrue: [self error: 'Bad cases'].
			cases _ constructor codeBrace: elements.
			otherBlock _ self blockTo: thenJump.
			stack addLast:
				(constructor
					codeMessage: stack removeLast
					selector: (constructor codeSelector: #caseOf:otherwise: code: #macro)
					arguments: (Array with: cases with: otherBlock))]!
doDup

	stack last == CascadeFlag
		ifFalse:
			["Save position and mark cascade"
			stack addLast: statements size.
			stack addLast: CascadeFlag].
	stack addLast: CascadeFlag!
doPop

	statements addLast: stack removeLast!
doStore: stackOrBlock
	"Only called internally, not from InstructionStream. StackOrBlock is stack
	for store, statements for storePop."

	| var expr |
	var _ stack removeLast.
	expr _ stack removeLast.
	stackOrBlock addLast: (expr == ArgumentFlag
		ifTrue: [var]
		ifFalse: [constructor codeAssignTo: var value: expr])!
jump: dist

	exit _ pc + dist.
	lastJumpPc _ lastPc!
jump: dist if: condition

	| savePc elseDist sign elsePc elseStart end cond ifExpr thenBlock elseBlock thenJump
		elseJump condHasValue n b |
	stack last == CascadeFlag ifTrue: [^self case: dist].
	elsePc _ lastPc.
	elseStart _ pc + dist.
	end _ limit.
	"Check for bfp-jmp to invert condition.
	Don't be fooled by a loop with a null body."
	sign _ condition.
	savePc _ pc.
	((elseDist _ self interpretJump) notNil and: [elseDist >= 0 and: [elseStart = pc]])
		ifTrue: [sign _ sign not.  elseStart _ pc + elseDist]
		ifFalse: [pc _ savePc].
	ifExpr _ stack removeLast.
	thenBlock _ self blockTo: elseStart.
	condHasValue _ hasValue.
	"ensure jump is within block (in case thenExpr returns)"
	thenJump _ exit <= end ifTrue: [exit] ifFalse: [elseStart].
	"if jump goes back, then it's a loop"
	thenJump < elseStart
		ifTrue:
			["thenJump will jump to the beginning of the while expr.  In the case of
			while's with a block in the condition, the while expr
			should include more than just the last expression: find all the
			statements needed by re-decompiling."
			pc _ thenJump.
			b _ self statementsTo: elsePc.
			"discard unwanted statements from block"
			b size - 1 timesRepeat: [statements removeLast].
			statements addLast: (constructor
					codeMessage: (constructor codeBlock: b returns: false)
					selector: (constructor codeSelector: (sign ifTrue: [#whileFalse:] ifFalse: [#whileTrue:]) code: #macro)
					arguments: (Array with: thenBlock)).
			pc _ elseStart]
		ifFalse:
			[elseBlock _ self blockTo: thenJump.
			elseJump _ exit.
			"if elseJump is backwards, it is not part of the elseExpr"
			elseJump < elsePc
				ifTrue: [pc _ lastPc].
			cond _ constructor
						codeMessage: ifExpr
						selector: (constructor codeSelector: #ifTrue:ifFalse: code: #macro)
						arguments:
							(sign
								ifTrue: [Array with: elseBlock with: thenBlock]
								ifFalse: [Array with: thenBlock with: elseBlock]).
			condHasValue
				ifTrue: [stack addLast: cond]
				ifFalse: [statements addLast: cond]]!
methodReturnConstant: value

	self pushConstant: value; methodReturnTop!
methodReturnReceiver

	self pushReceiver; methodReturnTop!
methodReturnTop
	| last |
	last _ stack removeLast.
	stack size > blockStackBase  "get effect of elided pop before return"
		ifTrue: [statements addLast: stack removeLast].
	exit _ method size + 1.
	lastJumpPc _ lastReturnPc _ lastPc.
	statements addLast: last!
popIntoLiteralVariable: value

	self pushLiteralVariable: value; doStore: statements!
popIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: statements!
popIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: statements!
pushActiveContext

	stack addLast: constructor codeThisContext!
pushConstant: value

	| node |
	node _ value == true ifTrue: [constTable at: 2]
		ifFalse: [value == false ifTrue: [constTable at: 3]
		ifFalse: [value == nil ifTrue: [constTable at: 4]
		ifFalse: [constructor codeAnyLiteral: value]]].
	stack addLast: node!
pushLiteralVariable: assoc

	stack addLast: (constructor codeAnyLitInd: assoc)!
pushReceiver

	stack addLast: (constTable at: 1)!
pushReceiverVariable: offset

	| var |
	(var _ instVars at: offset + 1) == nil
		ifTrue:
			["Not set up yet"
			instVars at: offset + 1 put: (var _ constructor codeInst: offset)].
	stack addLast: var!
pushTemporaryVariable: offset

	stack addLast: (tempVars at: offset + 1)!
send: selector super: superFlag numArgs: numArgs

	| args rcvr selNode msgNode elements numElements messages |
	selector == #toBraceStack:
		ifTrue: [^self formBrace].
	args _ Array new: numArgs.
	(numArgs to: 1 by: -1) do:
		[:i | args at: i put: stack removeLast].
	rcvr _ stack removeLast.
	superFlag ifTrue: [rcvr _ constructor codeSuper].
	(selector == #blockCopy: and: [self checkForBlock: rcvr])
		ifFalse:
			[selNode _ constructor codeAnySelector: selector.
			rcvr == CascadeFlag
				ifTrue:
					[self willJumpIfFalse
						ifTrue: "= generated by a case macro"
							[selector ~= #= ifTrue: [self error: 'bad case: ', selector].
							 statements addLast: args first.
							 stack addLast: rcvr. "restore CascadeFlag"
							 ^self]
						ifFalse:
							[msgNode _ constructor codeCascadedMessage: selNode arguments: args].
					stack last == CascadeFlag
						ifFalse:
							["Last message of a cascade"
							statements addLast: msgNode.
							messages _ self popTo: stack removeLast.  "Depth saved by first dup"
							msgNode _ constructor
								codeCascade: stack removeLast
								messages: messages]]
				ifFalse:
					[msgNode _ selector == #fromBraceStack:
						ifTrue:
							[numElements _ args first literalValue.
							 elements _ Array new: numElements.
							 numElements to: 1 by: -1 do:
								[:i | elements at: i put: stack removeLast].
							 constructor codeBrace: elements as: rcvr]
						ifFalse:
							[constructor
								codeMessage: rcvr
								selector: selNode
								arguments: args]].
			stack addLast: msgNode]!
storeIntoLiteralVariable: assoc

	self pushLiteralVariable: assoc; doStore: stack!
storeIntoReceiverVariable: offset

	self pushReceiverVariable: offset; doStore: stack!
storeIntoTemporaryVariable: offset

	self pushTemporaryVariable: offset; doStore: stack! !

!Decompiler methodsFor: 'public access'!
decompile: aSelector in: aClass 
	"See Decompiler|decompile:in:method:. The method is found by looking up 
	the message, aSelector, in the method dictionary of the class, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: (aClass compiledMethodAt: aSelector)!
decompile: aSelector in: aClass method: aMethod
	"Answer a MethodNode that is the root of the parse tree for the 
	argument, aMethod, which is the CompiledMethod associated with the 
	message, aSelector. Variables are determined with respect to the 
	argument, aClass."

	^self
		decompile: aSelector
		in: aClass
		method: aMethod
		using: DecompilerConstructor new!
tempAt: offset
	"Needed by BraceConstructor<PopIntoTemporaryVariable"

	^tempVars at: offset + 1! !

!Decompiler methodsFor: 'private'!
convertToDoLoop
	"If statements contains the pattern
		var _ startConst.
		[var <= limit] whileTrue: [...statements... var _ var + incConst]
	then replace this by
		startConst to: limit by: incConst do: [:var | ...statements...]"
	| initStmt toDoStmt |
	statements size < 2 ifTrue: [^ self].
	initStmt _ statements at: statements size-1.
	(initStmt isMemberOf: AssignmentNode) ifTrue:
		[toDoStmt _ statements last whileAsToDo: initStmt.
		toDoStmt notNil ifTrue:
			[statements removeLast; removeLast; addLast: toDoStmt]]!
decompile: aSelector in: aClass method: aMethod using: aConstructor

	| block |
	constructor _ aConstructor.
	method _ aMethod.
	self initSymbols: aClass.  "create symbol tables"
	method isQuick
		ifTrue: [block _ self quickMethod]
		ifFalse: 
			[stack _ OrderedCollection new: method frameSize.
			statements _ OrderedCollection new: 20.
			super method: method pc: method initialPC.
			block _ self blockTo: method endPC + 1.
			stack isEmpty ifFalse: [self error: 'stack not empty']].
	^constructor
		codeMethod: aSelector
		block: block
		tempVars: tempVars
		primitive: method primitive
		class: aClass!
formBrace
	"A #toBraceStream: selector has been encountered as part of a sequence:
		<Literal n> <Send toBraceStream:> <Pop> <Store#n> ... <Store#1>
	 where <Store#i> is either a <StorePop> or a sequence like the above.
	 The top of the stack must therefore be a LiteralNode with the key n.
	 Beneath that is usually the right-hand side of the assignment.
	 However, there may be an intervening pair of CascadeFlags and a number
	 beneath them.

	 Create a BraceNode and let it consume the pop & stores to determine its variables.
	 Create an AssignmentNode with the BraceNode as its variable and the
	 right-hand-side as its value.  Add the AssignmentNode to statements.

	 If two CascadeFlags are encountered instead of the right-hand-side, pop them
	 and the number beneath them to find the right-hand-side, and leave the
	 Assignment node on the stack instead of adding it to statements
	 (this happens in cases like  x _ {a. b} _ ...)."

	| var expr dest |
	var _ constructor codeBrace: stack removeLast literalValue fromBytes: self.
	(expr _ stack removeLast) == CascadeFlag
		ifTrue: "multiple assignment, more to come"
			[stack removeLast; removeLast. "CascadeFlag, number"
			expr _ stack removeLast.
			dest _ stack]
		ifFalse: "store and pop"
			[dest _ statements].
	dest addLast: (constructor codeAssignTo: var value: expr)!
popTo: oldPos

	| t |
	t _ Array new: statements size - oldPos.
	(t size to: 1 by: -1) do:
		[:i | t at: i put: statements removeLast].
	^t!
quickMethod
	^ method isReturnSpecial
		ifTrue: [constructor codeBlock:
				(Array with: (constTable at: method primitive - 255)) returns: true]
		ifFalse: [method isReturnField
			ifTrue: [constructor codeBlock:
				(Array with: (constructor codeInst: method returnField)) returns: true]
			ifFalse: [self error: 'improper short method']]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Decompiler class
	instanceVariableNames: ''!

!Decompiler class methodsFor: 'class initialization'!
initialize

	CascadeFlag _ 'cascade'.  "A unique object"
	ArgumentFlag _ 'argument'.  "Ditto"

	"Decompiler initialize"! !

Decompiler initialize!
ParseNode subclass: #DecompilerConstructor
	instanceVariableNames: 'method instVars nArgs literalValues tempVars '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
DecompilerConstructor comment:
'I construct the node tree for a Decompiler.'!

!DecompilerConstructor methodsFor: 'initialize-release'!
method: aMethod class: aClass literals: literals

	method _ aMethod.
	instVars _ aClass allInstVarNames.
	nArgs _ method numArgs.
	literalValues _ literals! !

!DecompilerConstructor methodsFor: 'constructor'!
codeAnyLiteral: value

	^LiteralNode new
		key: value
		index: 0
		type: LdLitType!
codeAnyLitInd: association

	^VariableNode new
		name: association key
		key: association
		index: 0
		type: LdLitIndType!
codeAnySelector: selector

	^SelectorNode new
		key: selector
		index: 0
		type: SendType!
codeArguments: args block: block

	^block arguments: args!
codeAssignTo: variable value: expression

	^AssignmentNode new variable: variable value: expression!
codeBlock: statements returns: returns

	^BlockNode new statements: statements returns: returns!
codeBrace: elements

	^BraceNode new elements: elements!
codeBrace: elements as: receiver

	| braceNode |
	braceNode _ self codeBrace: elements.
	^(receiver isVariableReference and: [receiver key key == #Array])
		ifTrue: [braceNode]
		ifFalse:
			[self codeMessage: (braceNode collClass: receiver)
					selector: (self codeSelector: #as: code: -1)
					arguments: (Array with: receiver)]!
codeBrace: numElements fromBytes: anInstructionStream

	^BraceConstructor new
		codeBrace: numElements
		fromBytes: anInstructionStream
		withConstructor: self!
codeCascade: receiver messages: messages

	^CascadeNode new receiver: receiver messages: messages!
codeCascadedMessage: selector arguments: arguments

	^self
		codeMessage: nil
		selector: selector
		arguments: arguments!
codeConstants
	"Answer with an array of the objects representing self, true, false, nil,
	-1, 0, 1, 2."

	| i |
	^(Array with: NodeSelf with: NodeTrue with: NodeFalse with: NodeNil)
		, ((-1 to: 2) collect: [:i | LiteralNode new key: i code: LdMinus1 + i + 1])!
codeEmptyBlock

	^BlockNode withJust: NodeNil!
codeInst: index

	^VariableNode new
		name: (instVars at: index + 1)
		index: index
		type: LdInstType!
codeMessage: receiver selector: selector arguments: arguments

	| symbol |
	symbol _ selector key.
	^MessageNode new
		receiver: receiver
		selector: selector
		arguments: arguments
		precedence:
			(symbol isInfix
				ifTrue: [2]
				ifFalse: [symbol isKeyword ifTrue: [3] ifFalse: [1]])!
codeMethod: selector block: block tempVars: vars primitive: primitive class: class

	| node precedence |
	node _ self codeSelector: selector code: nil.
	precedence _ selector isInfix
				ifTrue: [2]
				ifFalse: [selector isKeyword ifTrue: [3] ifFalse: [1]].
	tempVars _ vars.
	^MethodNode new
		selector: node
		arguments: (tempVars copyFrom: 1 to: nArgs)
		precedence: precedence
		temporaries: (tempVars copyFrom: nArgs + 1 to: tempVars size)
		block: block
		encoder: (Encoder new initScopeAndLiteralTables
					nTemps: tempVars size
					literals: literalValues
					class: class)
		primitive: primitive!
codeSelector: sel code: code

	^SelectorNode new key: sel code: code!
codeSuper

	^NodeSuper!
codeTemp: index

	^VariableNode new
		name: 't' , (index + 1) printString
		index: index
		type: LdTempType!
codeThisContext

	^NodeThisContext! !Object subclass: #Delay
	instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn '
	classVariableNames: 'ActiveDelayStartTime SuspendedDelays ActiveDelay AccessProtect TimingSemaphore '
	poolDictionaries: ''
	category: 'Kernel-Processes'!

!Delay methodsFor: 'delaying'!
wait
	"Suspend the process of the caller for the amount of time specified
	 when the receiver was created."

	beingWaitedOn ifTrue: [ self error: 'A process is already waiting on this Delay' ].
	AccessProtect critical: [
		beingWaitedOn _ true.
		resumptionTime _ Time millisecondClockValue + delayDuration.
		ActiveDelay == nil
			ifTrue: [ self activate ]
			ifFalse: [
				resumptionTime < ActiveDelay resumptionTime
					ifTrue: [
						SuspendedDelays add: ActiveDelay.
						self activate ]
					ifFalse: [ SuspendedDelays add: self ].
			].
	].
	delaySemaphore wait.! !

!Delay methodsFor: 'private'!
activate
	"Make the receiver the Delay to be signalled when the next timer
	interrupt occurs. This method should only be called from a block
	protected by the AccessProtect semaphore."

	ActiveDelay _ self.
	ActiveDelayStartTime _ Time millisecondClockValue.
	TimingSemaphore initSignals.
	Processor signal: TimingSemaphore atTime: resumptionTime.!
continueAfterSnapshot
	"Continue the active delay after resuming a snapshot."
	"Note: During a snapshot, the resumptionTime variable is used to record
	the time remaining on the active duration."

	resumptionTime _ Time millisecondClockValue + resumptionTime.
	ActiveDelayStartTime _ Time millisecondClockValue.
	TimingSemaphore initSignals.
	Processor signal: TimingSemaphore atTime: resumptionTime.!
delay: millisecondCount
	"Initialize this delay for the given number of milliseconds."

	delayDuration _ millisecondCount.
	delaySemaphore _ Semaphore new.
	beingWaitedOn _ false.!
recordTimeRemaining
	"Record (in resumptionTime) the amount of time remaining for the active
	delay (the receiver) just before a snapshot. The delay will be resumed
	when the snapshot resumes."

	| timeSoFar |
	timeSoFar _ Time millisecondClockValue - ActiveDelayStartTime.
	resumptionTime _ delayDuration - timeSoFar.
!
resumptionTime
	"Answer the value of the system's millisecondClock at which the 
	receiver's suspended Process will resume."

	^ resumptionTime!
signalWaitingProcess
	"The delay time has elapsed; signal the waiting process."

	beingWaitedOn _ false.
	delaySemaphore signal.! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Delay class
	instanceVariableNames: ''!

!Delay class methodsFor: 'initialization'!
initialize
	"Initialize the class variables that keep track of active Delays."
	"Delay initialize"

	TimingSemaphore == nil ifFalse: [ TimingSemaphore terminateProcess ].
	TimingSemaphore _ Semaphore new.
	AccessProtect _ Semaphore forMutualExclusion.
	SuspendedDelays _ 
		SortedCollection sortBlock: 
			[ :d1 :d2 | d1 resumptionTime <= d2 resumptionTime].
	ActiveDelay _ nil.
	[self timerInterruptWatcher] forkAt: Processor timingPriority.!
timerInterruptWatcher
	"This loop runs in its own process. It waits for a timer interrupt and
	wakes up the active delay. Note that timer interrupts are only scheduled
	when there are active delays."

	[true] whileTrue: [
		TimingSemaphore wait.
		AccessProtect critical: [
			ActiveDelay signalWaitingProcess.
			SuspendedDelays isEmpty
				ifTrue: [
					ActiveDelay _ nil.
					ActiveDelayStartTime _ nil.
				] ifFalse: [ SuspendedDelays removeFirst activate ].
		].
	].
! !

!Delay class methodsFor: 'instance creation'!
forMilliseconds: t1 
^ self new delay: t1!
forSeconds: t1 
^ self new delay: t1 * 1000!
howToUse
	"An instance of Delay responds to the message wait by suspending the
	caller's process for a certain amount of time. The duration of the pause
	is specified when the Delay is created with the message forMilliseconds: or
	forSeconds:. A Delay can be used again when the current wait has finished.
	For example, a clock process might repeatedly wait on a one-second Delay."! !

!Delay class methodsFor: 'snapshotting'!
shutDown
	"Suspend the active delay, if any, before snapshotting. It will be reactived
	when the snapshot is resumed."
	"Details: This prevents a timer interrupt from waking up the active
	delay in the midst snapshoting, since the active delay will be
	restarted when resuming the snapshot and we don't want to process
	the delay twice."

	Processor signal: nil atTime: 0.
	AccessProtect wait.
	ActiveDelay == nil ifFalse: [ ActiveDelay recordTimeRemaining ].
!
startUp
	"Restart active delay, if any, when resuming a snapshot."

	ActiveDelay == nil ifFalse: [ ActiveDelay continueAfterSnapshot ].
	AccessProtect signal.
! !

!Delay class methodsFor: 'testing'!
test2DelayOf: delay for: testCount label: label
	"Transcript cr. 
	 Delay testDelayOf: 1000 for: 10 label: 'A'. 
	 Delay testDelayOf: 2000 for: 10 label: 'B'"

	| myDelay |
	myDelay _ Delay forMilliseconds: delay.
	[	1 to: testCount do: [ :i |
			myDelay wait.
			Transcript show: label, i printString; cr.
		].
	] forkAt: Processor userInterruptPriority.
!
test2DelayOf: delay for: testCount rect: r
	"Transcript cr. 
	 Delay test2DelayOf: 100 for: 20 rect: (10@10 extent: 10@10).
	 Delay test2DelayOf: 400 for: 20 rect: (25@10 extent: 10@10)."

	| myDelay pauseDelay |
	myDelay    _ Delay forMilliseconds: delay - 50.
	pauseDelay _ Delay forMilliseconds: 50.
	Display fillBlack: r.
	[	1 to: testCount do: [ :i |
			Display fillWhite: r.
			pauseDelay wait.
			Display reverse: r.
			myDelay wait.
		].
	] forkAt: Processor userInterruptPriority.
!
testDelayOf: delay for: testCount label: label
	"Transcript cr. 
	 Delay testDelayOf: 1000 for: 10 label: 'A'. 
	 Delay testDelayOf: 2000 for: 10 label: 'B'"

	| myDelay |
	myDelay _ Delay forMilliseconds: delay.
	[	1 to: testCount do: [ :i |
			myDelay wait.
			Transcript show: label, i printString; cr.
		].
	] forkAt: Processor userInterruptPriority.
! !

Delay initialize!
Object subclass: #DevelopmentSupport
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Support'!

!DevelopmentSupport methodsFor: 'no messages'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DevelopmentSupport class
	instanceVariableNames: ''!
DevelopmentSupport class comment:
'A place where to-do lists, notes to one another, etc., can be centralized.  1/27/96 sw'!

!DevelopmentSupport class methodsFor: 'scott's notes'!
changeSorterToDoList
	"Last changed: 2/7/96 sw"

"Need some relief for the property that when you reactivate a ChangeSorter, all unsubmitted edits in either text pane are summarily discarded (and also, it can take a long time to activate because the changesets are being updated

The menus are not necessarily up to date with other code-browsing menus.

Make sure the initial size/shape will fit okay on the current screen.

No protection against duplicate changeset names

No guarding against empty reply to changeset name.

Nice to have a single-change-sorter as well as Ted's Dual one.
"

!
filesToDo
	"2/3/96 sw

The file browser sucks in numerous ways.

One totally brain-damaged thing is that when you try to dismiss it, if there have been edits, you're asked 'is it okay to cancel changes', and when you say yes, it reads in the entire damned file again, just in time to close it.

Upgrade its menus.

Don't read in the entire damned file every time you move the window!!

"!
scottsToDoList
	"Last changed: 2/7/96 sw"

"Force popup menus onto screen.  Somehow they aren't protected from going off the bottom.
Open new windows properly stacked and never off-screen
Close all unchanged windows. (fix the sucker)
Sys browser window titles change with selected class
Dan's pane resizers
References in inspectListController.
Fix the indent/outdent
Remove Mac stuff and generally Toolbox access, or at least flag it.
When you remove a method, it shows up in change sorter as a removal, but versions doesn't work.  Might be nice to stash the version backpointer in the change token so that versions could be made to work...
Resolution about mac scrollbars
Fix weirdo behavior in scrollbars mentioned by Ted.
Ted's look back for uppercase pair at word start
"! !Set subclass: #Dictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!
NewDictionary comment:
'I represent a set of elements that can be viewed from one of two perspectives: a set of associations, or a set of values that are externally named where the name can be any object that responds to =. The external name is referred to as the key.'!

!Dictionary methodsFor: 'accessing'!
associationAt: key 
	^ self associationAt: key ifAbsent: [self errorKeyNotFound]!
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!
at: key 
	"Answer the value associated with the key."

	^ self at: key ifAbsent: [self errorKeyNotFound]!
at: key ifAbsent: aBlock 

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	nil == assoc ifTrue: [ ^ aBlock value ].
	^ assoc value!
at: key put: anObject 
	"Set the value at key to be anObject.  If key is not found, create a new
	entry for key and set is value to anObject. Answer anObject."
	| index element |
	index _ self findElementOrNil: key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: (Association key: key value: anObject)]
		ifFalse: [element value: anObject].
	^ anObject!
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]!
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!
keys
	"Answer a Set containing the receiver's keys."
	| aSet key |
	aSet _ Set new: self size.
	self keysDo: [:key | aSet add: key].
	^ aSet! !

!Dictionary methodsFor: 'testing'!
includes: anObject

	self do: [:each | anObject = each ifTrue: [^true]].
	^false!
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]!
includesKey: aKey ifTrue: trueBlock ifFalse: falseBlock
	"If the receiver includes the given key, evaluate trueBlock, else evaluate falseBlock.  6/7/96 sw"

	self noteToDan.  "After the three hundredth time I submitted a method as if this glue existed, and then had to put parentheses around the includesKey: clause, I though it might be expedient to have this crutch available.  However, perhaps one could think of it as damaging because it would tempt people to assume you could do this elsewhere?!!  What do you think?"

	^ (self includesKey: aKey)
		ifTrue:
			[trueBlock value]
		ifFalse:
			[falseBlock value]!
occurrencesOf: anObject 
	"Answer how many of the receiver's elements are equal to anObject."

	| count |
	count _ 0.
	self do: [:each | anObject = each ifTrue: [count _ count + 1]].
	^count! !

!Dictionary methodsFor: 'adding'!
add: anAssociation
	| index element |
	index _ self findElementOrNil: anAssociation key.
	element _ array at: index.
	element == nil
		ifTrue: [self atNewIndex: index put: anAssociation]
		ifFalse: [element value: anAssociation value].
	^ anAssociation!
declare: key from: aDictionary 
	"Add key to the receiver. If key already exists, do nothing. If aDictionary 
	includes key, then remove it from aDictionary and use its association as 
	the element of the receiver."

	(self includesKey: key) ifTrue: [^ self].
	(aDictionary includesKey: key)
		ifTrue: 
			[self add: (aDictionary associationAt: key).
			aDictionary removeKey: key]
		ifFalse: 
			[self add: key -> nil]! !

!Dictionary methodsFor: 'removing'!
remove: anObject

	self shouldNotImplement!
remove: anObject ifAbsent: exceptionBlock

	self shouldNotImplement!
removeKey: key 
	"Remove key from the receiver.
	If key is not in the receiver, notify an error."

	^ self removeKey: key ifAbsent: [self errorKeyNotFound]!
removeKey: key ifAbsent: aBlock 
	"Remove key (and its associated value) from the receiver. If key is not in 
	the receiver, answer the result of evaluating aBlock. Otherwise, answer 
	the value externally named by key."

	| index assoc |
	index _ self findElementOrNil: key.
	assoc _ array at: index.
	assoc == nil ifTrue: [ ^ aBlock value ].
	array at: index put: nil.
	tally _ tally - 1.
	self fixCollisionsFrom: index.
	^ assoc value! !

!Dictionary methodsFor: 'enumerating'!
associationsDo: aBlock 
	"Evaluate aBlock for each of the receiver's elements (key/value 
	associations)."

	super do: aBlock!
collect: aBlock 
	"Evaluate aBlock with each of my values as the argument.  Collect the
	resulting values into a collection that is like me. Answer with the new
	collection."
	| newCollection |
	newCollection _ OrderedCollection new: self size.
	self do: [:each | newCollection add: (aBlock value: each)].
	^ newCollection!
do: aBlock

	super do: [:assoc | aBlock value: assoc value]!
keysDo: aBlock 
	"Evaluate aBlock for each of the receiver's keys."

	self associationsDo: [:association | aBlock value: association key]!
select: aBlock 
	"Evaluate aBlock with each of my values as the argument. Collect into a
	new dictionary, only those associations for which aBlock evaluates to
	true."

	| newCollection |
	newCollection _ self species new.
	self associationsDo: 
		[:each | 
		(aBlock value: each value) ifTrue: [newCollection add: each]].
	^newCollection! !

!Dictionary methodsFor: 'printing'!
printOn: aStream
	| tooMany |
	tooMany _ self maxPrint.	
		"Need absolute limit, or infinite recursion will never 
		notice anything going wrong.  7/26/96 tk"
	aStream nextPutAll: self class name, ' ('.
	self associationsDo: 
		[:element | 
		aStream position > tooMany
			ifTrue: [aStream nextPutAll: '...etc...)'. ^ self].
		element printOn: aStream.
		aStream space].
	aStream nextPut: $)!
storeOn: aStream
	| noneYet |
	aStream nextPutAll: '(('.
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' new)'.
	noneYet _ true.
	self associationsDo: 
			[:each | 
			noneYet
				ifTrue: [noneYet _ false]
				ifFalse: [aStream nextPut: $;].
			aStream nextPutAll: ' add: '.
			aStream store: each].
	noneYet ifFalse: [aStream nextPutAll: '; yourself'].
	aStream nextPut: $)! !

!Dictionary methodsFor: 'private'!
errorKeyNotFound

	self error: 'key not found'!
errorValueNotFound

	self error: 'value not found'!
keyAt: index
	"May be overridden by subclasses so that fixCollisions will work"
	| assn |
	assn _ array at: index.
	assn == nil ifTrue: [^ nil]
				ifFalse: [^ assn key]!
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!
rehash
	"Smalltalk rehash."
	| newSelf |
	newSelf _ self species new: self size.
	self associationsDo: [:each | newSelf noCheckAdd: each].
	array _ newSelf array!
scanFor: key from: start to: finish
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."

	| element |
	"this speeds up a common case: key is in the first slot"
	((element _ array at: start) == nil or: [element key = key])
		ifTrue: [ ^ start ].

	start + 1 to: finish do: [ :index |
		((element _ array at: index) == nil or: [element key = key])
			ifTrue: [ ^ index ].
	].
	^ 0!
valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary 
	"Support for coordinating class variable and global declarations
	with variables that have been put in Undeclared so as to
	redirect all references to the undeclared variable."

	(aDictionary includesKey: aKey)
		ifTrue: 
			[self atNewIndex: index 
				put: ((aDictionary associationAt: aKey) value: anObject).
			aDictionary removeKey: aKey]
		ifFalse: 
			[self atNewIndex: index put: (Association key: aKey value: anObject)]! !

!Dictionary methodsFor: 'user interface'!
inspect
	"Open a NewDictionaryInspector on the receiver.  N.B.: this is
	an inspector without trash, since InspectorTrash doesn't do the
	obvious thing right now.  Use basicInspect to get a normal
	(less useful) type of inspector."

	InspectorView open: (InspectorView dictionaryInspector:
		(DictionaryInspector inspect: self))!
inspectFormsWithLabel: aLabel
	"Open a Form Dictionary inspector on the receiver, with the given label.  6/28/96 sw"

	InspectorView open: (InspectorView formDictionaryInspector:
		(DictionaryInspector inspect: self)) withLabel: aLabel!
inspectWithLabel: aLabel
	"Open a NewDictionaryInspector on the receiver.  N.B.: this is
	an inspector without trash, since InspectorTrash doesn't do the
	obvious thing right now.  Use basicInspect to get a normal
	(less useful) type of inspector."
	InspectorView open: (InspectorView dictionaryInspector:
		(DictionaryInspector inspect: self)) withLabel: aLabel! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Dictionary class
	instanceVariableNames: ''!

!Dictionary class methodsFor: 'instance creation'!
fromBraceStack: itsSize 
	"Answer an instance of me with itsSize elements, popped in reverse order from
	 the stack of thisContext sender.  Do not call directly: this is called by {1. 2. 3}
	 constructs."

	^ self newFrom: ((Array new: itsSize) fill: itsSize fromStack: thisContext sender)!
newFrom: aDict 
	"Answer an instance of me containing the same associations as aDict.
	 Error if any key appears twice."
	| newDictionary |
	newDictionary _ self new: aDict size.
	aDict associationsDo:
		[:x |
		(newDictionary includesKey: x key)
			ifTrue: [self error: 'Duplicate key: ', x key printString]
			ifFalse: [newDictionary add: x]].
	^ newDictionary

"	NewDictionary newFrom: {1->#a. 2->#b. 3->#c}
	{1->#a. 2->#b. 3->#c} as: NewDictionary
	NewDictionary newFrom: {1->#a. 2->#b. 1->#c}
	{1->#a. 2->#b. 1->#c} as: NewDictionary
"! !Inspector subclass: #DictionaryInspector
	instanceVariableNames: 'keyArray '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!

!DictionaryInspector methodsFor: 'accessing'!
fieldList
	^ keyArray collect: [ :key | key printString ]!
inspect: aDictionary
	"Initialize the receiver so that it is inspecting aDictionary. There is no 
	current selection."

	self initialize.
	(aDictionary isKindOf: Dictionary) ifFalse:
		[^ self error: 'DictionaryInspectors can only inspect dictionaries' ].
	object _ aDictionary.
	contents _ ''.
	self calculateKeyArray! !

!DictionaryInspector methodsFor: 'selecting'!
addEntry: aKey
	object at: aKey put: nil.
	self calculateKeyArray.
	selectionIndex _ keyArray indexOf: aKey.
	self changed: #inspectObject.
	self update!
calculateKeyArray
	"Recalculate the KeyArray from the object being inspected"

	| sortedKeys |
	sortedKeys _ SortedCollection new: object size.
	sortedKeys sortBlock: [ :x :y |
		(((x isKindOf: String) & (y isKindOf: String))
		or: [(x isKindOf: Number) & (y isKindOf: Number)])
			ifTrue: [ x < y]
			ifFalse: [ (x class = y class)
				ifTrue: [ x printString < y printString]
				ifFalse: [ x class name < y class name ] ] ].
	object keysDo:
		[ :aKey | sortedKeys add: aKey. ].
	keyArray _ sortedKeys asArray.
	selectionIndex _ 0.
!
removeSelection
	object removeKey: (keyArray at: selectionIndex).
	selectionIndex _ 0.
	contents _ ''.
	self calculateKeyArray.
	self changed: #inspectObject.
	self changed: #selection.!
replaceSelectionValue: anObject
	^ object at: (keyArray at: selectionIndex) put: anObject!
selection
	^ object at: (keyArray at: selectionIndex)!
selectionAssociation
	^ object associationAt: (keyArray at: selectionIndex)!
selectionUnmodifiable
	"For dicionary inspectors, any selection is modifiable"

	^ selectionIndex <= 0! !InspectListController subclass: #DictionaryListController
	instanceVariableNames: ''
	classVariableNames: 'DictionaryListYellowButtonMenu DictionaryListYellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-Inspector'!

!DictionaryListController methodsFor: 'menu messages'!
addEntry
	"Add a new Entry to the inspected object"

	| newKey |
	newKey _ FillInTheBlank request:
'Enter new key, then type RETURN.
(Expression will be evaluated for value.)'.
	newKey _ Compiler evaluate: newKey.
	model addEntry: newKey!
removeSelection
	"Remove the current selection from the model"

	model selectionIndex = 0
		ifTrue: [^view flash].
	^ model removeSelection!
selectionReferences
	"Create a browser on all references to the association of the current selection."

	model selectionIndex = 0
		ifTrue: [^view flash].
	self controlTerminate.
	Smalltalk browseAllCallsOn: model selectionAssociation.
	self startUp.! !

!DictionaryListController methodsFor: 'private'!
initializeYellowButtonMenu

	self 
		yellowButtonMenu: DictionaryListYellowButtonMenu
		yellowButtonMessages: DictionaryListYellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DictionaryListController class
	instanceVariableNames: ''!

!DictionaryListController class methodsFor: 'class initialization'!
initialize

	DictionaryListYellowButtonMenu _
		PopUpMenu labels:
'inspect
references
add key
remove'
		lines: #( 2 ).
	DictionaryListYellowButtonMessages _
		#(inspectSelection selectionReferences addEntry removeSelection )

	"DictionaryListController initialize"! !

DictionaryListController initialize!
Object subclass: #DiskProxy
	instanceVariableNames: 'globalObjectName constructorSelector constructorArgs '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Object Storage'!

!DiskProxy methodsFor: 'as yet unclassified'!
comeFullyUpOnReload
    "Internalize myself into a fully alive object after raw loading
     from a DataStream. (See my class comment.)
     The sender (the DataStream facility) will substitute the answer
     for myself, even if that means doing Ôme become: myAnswerÕ."
    | globalObj |

    globalObj _ Smalltalk at: globalObjectName
        ifAbsent: [^ self halt: 'canÕt internalize'].
    Symbol mustBeSymbol: constructorSelector.    

    ^ globalObj perform: constructorSelector
          withArguments: constructorArgs!
global: globalNameSymbol selector: selectorSymbol args: argArray
    "Initialize self as a DiskProxy constructor with the given
     globalNameSymbol, selectorSymbol, and argument Array.
     I will internalize by looking up the global object name in the
     SystemDictionary (Smalltalk) and sending it this message with
     these arguments."

    Symbol mustBeSymbol: (globalObjectName _ globalNameSymbol).
    Symbol mustBeSymbol: (constructorSelector _ selectorSymbol).
    constructorArgs _ argArray!
objectToStoreOnDataStream
    "A DiskProxy proxies for some object put on a DataStream. When
     loaded back, the DiskProxy internalizes (comeFullyUpOnReload)
     by turning into the original object (we hope).
     Trying to put a *DiskProxy* on a DataStream wonÕt work since the
     loaded result will internalize itself into something else.
     Hence sending objectToStoreOnDataStream to a DataStream is
     a bug (or else a request to built a ÔquoterÕ that will turn
     itself back into this DiskProxy objectÉ)."

    self halt: 'redundant objectToStoreOnDataStream message'! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DiskProxy class
	instanceVariableNames: ''!

!DiskProxy class methodsFor: 'imported from V'!
classComment
"A DiskProxy is an externalized form of an object to write on a
DataStream. It contains a ÔconstructorÕ message to regenerate
the object, in context, when sent a comeFullyUpOnReload message
(i.e. ÔinternalizeÕ).

Constructing a new object is good for any object that (1) canÕt be
externalized simply by snapshotting and reloading its instance
variables (like a CompiledMethod or a Picture), or (2) wants to be
free to evolve its internal representation without making stored
instances obsolete (and dangerous). Snapshotting and reloading an
objectÕs instance variables is a dangerous breach of encapsulation.

The idea is to define, for each kind of object that needs special
externalization, a class method that will internalize the object by
reconstructing it from its defining state. We call this a
ÔconstructorÕ method. Then externalize such an object as a frozen
message that invokes this method--a DiskProxy.

The internal structure of the class is then free to evolve. All
externalized instances will be useful as long as the
constructor methods are maintained with the same semantics.

There may be several constructor methods for a particular class. This
is useful for (1) instances with characteristically different
defining state, and (2) newer, evolved forms of an object and its
constructors, with the old constructor methods kept around so old
data can still be properly loaded.

Create one like this example from class Picture

    DiskProxy global: #Picture
            selector: #fromByteArray:
                args: (Array with: self storage asByteArray)

¥ See also subclass DiskProxyQ that will construct an object in
the above manner and then send it a sequence of messages. This may save
creating a wide variety of constructor methods. It's also useful because
the newly read-in DiskProxyQ can catch messages like #objectContainedIn:
(via #doesNotUnderstand:) and add them to the queue of messages to
send to the new object.

¥ We may also want a subclass of DiskProxy that evaluates a string
expression to compute the receiver of the constructor message.

My instance variables:
¥ globalObjectName -- the Symbol name of a global object in the
    System dictionary (usually a class).
¥ constructorSelector -- the constructor message selector Symbol to
    send to the global object (perform:withArguments:), typically a
    variation on ÔnewFrom:Õ.
¥ constructorArgs -- the Array of arguments to pass in the
    constructor message.

-- 11/9/92 jhm
"!
global: globalNameSymbol selector: selectorSymbol args: argArray
    "Create a new DiskProxy constructor with the given
     globalNameSymbol, selectorSymbol, and argument Array.
     It will internalize itself by looking up the global object name
     in the SystemDictionary (Smalltalk) and sending it this message
     with these arguments."

    ^ self new global: globalNameSymbol
             selector: selectorSymbol
                 args: argArray! !DiskProxy subclass: #DiskProxyQ
	instanceVariableNames: 'messageQueue '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Object Storage'!

!DiskProxyQ methodsFor: 'as yet unclassified'!
comeFullyUpOnReload
    "Internalize myself into a fully alive object after raw loading
     from a DataStream/ReferenceStream.
     For DiskProxyQ: Invoke the constructor message and send my queue of messages to
     the result. (See my class comment.)
     The sender (the ReferenceStream facility) will substitute the answer
     for myself, even if that means asking me to Ôbecome: myAnswerÕ. -- 11/9/92 jhm
     12/1/92 jhm: Remove the 1-element-array optimization."
    | answer |

    answer _ super comeFullyUpOnReload.

    messageQueue == nil ifFalse:
        [messageQueue do: [:msg | msg sendTo: answer]].

    ^ answer!
doesNotUnderstand: aMessage
    "Enqueue a message for the object that I will internalize to. Return self, which
     is the best I can do (sorry!!), noting that self will #become: the object I
     internalize to. See my class comment for more info and warnings. -- 11/9/92 jhm"

    self xxxQMessage: aMessage.
    ^ self!
global: globalNameSymbol selector: selectorSymbol args: argArray
    "Initialize self as a DiskProxyQ constructor with the given
     globalNameSymbol, selectorSymbol, and argument Array, and an
     empty message queue.
     I will internalize by looking up the global object name in the
     SystemDictionary (Smalltalk), sending it this message with
     these arguments, and then sending it all queued up messages.
     In the interim, I can enqueue messages. -- 11/9/92 jhm"

    messageQueue _ nil.
    ^ super global: globalNameSymbol selector: selectorSymbol args: argArray!
xxxQMessage: aMessage
    "Enqueue aMessage on the queue of messages that I will send the newly-created
     object at internalization time.
     IMPLEMENTATION: My instance variable messageQueue holds either nil or an Array
        of objects to sendTo: the object I'm internalizing to (generally of class
        Message or Symbol). -- 11/9/92 jhm
     12/1/92 jhm: Remove the 1-element-array optimization."

    messageQueue _ messageQueue == nil
        ifTrue:  [Array with: aMessage]
        ifFalse: [messageQueue,, aMessage]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DiskProxyQ class
	instanceVariableNames: ''!

!DiskProxyQ class methodsFor: 'imported from V'!
classComment
"An extended version of DiskProxy (which see) whose internalize method will
construct an object like DiskProxy does and then send it a sequence of
messages from a message queue.

Messages may be enqueued before the DiskProxyQ is saved on the
ReferenceStream. Example: Ô(TopPane new) label: w; model: x; menu: yÕ. This
saves creating a variety of highly specialized constructor methods.

Messages may also be enqueued by the DiskProxyQ between when its read from
disk and when itÕs internalized to the desired object. The newly
read-in DiskProxyQ can catch messages like #objectContainedIn: (via
doesNotUnderstand:) and add them to the queue of messages to send to the
new object at internalization time. This matters a great deal to a network
of objects being read in from a ReferenceStream, since some objects get
internalized before other objects that they know.

You create a DiskProxyQ just like a DiskProxy, and optionally send it
#xxxQMessage: messages.

WARNING: The use of doesNotUnderstand: wonÕt work if you count on the not-understood
messageÕs result!! DiskProxyQ>>doesNotUnderstand: cannot possibly return the
right result. It canÕt even return the ÔselfÕ of the object being
internalized, since the whole point is that object hasnÕt been created yet.
As a best bet, DiskProxyQ>>doesNotUnderstand: returns itself, which will
eventually be asked to #become: the object it internalizes to.

WARNING: The use of doesNotUnderstand: wonÕt work if ordinary DiskProxyQ
messages are mistaken for messages to enqueue for the proxied object, or
vice versa!! Adding methods to future implementations of DiskProxyQ may screw
up exisitng DiskProxyQ objects!! We might want to program specific DiskProxyQ
objects with message selectors to catch and enqueue when read in, but that
would be painful all around, and itÕs not clear how to do it.
    Because of this, we (a) minimize the number of messages that a DiskProxyQ
responds to, and (b) begin all DiskProxyQ message selector names with ÔxxxÕ.
Still, DiskProxyQ inherits many methods from Object and a couple from APalObject!!

My instance variables:
  ¥ messageQueue -- either nil or an Array of objects to sendTo: the object IÕm
        internalizing to (theyÕre generally of class Message or Symbol).

NOTE: The class method readDataFrom:size: anInteger deals with a subtle issue in
reading a network of objects. Recursively reading the a DiskProxyQÕs parts will
internalize them (comeFullyUpOnReload), possibly sending messages to the nascent
DiskProxyQ. I.e. the incomplete object receives (and enqueues) messages!! When it
reads the DiskProxyQÕs message queue, it must combine that with the accumulated
queue.
    Rather than hard-wire the index of the inst var ÔmessageQueueÕ, that method
ASSUMES that any non-nil inst var holds an Array to be concatenated with the filed
value.

-- 11/9/92 jhm, 12/1/92 jhm
"!
readDataFrom: aDataStream size: anInteger
    "Create an object based on the contents of aDataStream, which was
       generated by the objectÕs storeDataOn: method. Answer it.
     NOTE: This implementation for DiskProxyQ deals with a subtle issue in reading a
        network of objects. Recursively reading the a DiskProxyQÕs parts will
        internalize them (comeFullyUpOnReload), possibly sending messages to the
        nascent DiskProxyQ. I.e. the incomplete object receives (and enqueues)
        messages!! When we read the DiskProxyQÕs message queue, we must combine
        it with the accumulated queue.
     ASSUMES: Rather than hard-wire the index of the inst var ÔmessageQueueÕ, we
        assume that any non-nil inst var has an Array to be concatenated with the
        filed value.
     NOTE: This method must match its corresponding storeDataOn:
       method. Also, it must send beginReference: after instantiating
       the new object but before reading any objects from aDataStream
       that might reference it. -- 12/1/92 jhm"
    | anObject cntInstVars cntIndexedVars nextValue var |

    cntInstVars _ self instSize.
    anObject _ self isVariable
        ifTrue:  [cntIndexedVars _ anInteger - cntInstVars.
                 self basicNew: cntIndexedVars]
        ifFalse: [cntIndexedVars _ 0.
                 self basicNew].

    aDataStream beginReference: anObject.

    "Read in the instance vars, but donÕt just overwrite vars that get contents
     before we get there due to recursive work in ÔaDataStream nextÕ."
    1 to: cntInstVars do: [:i |
        nextValue _ aDataStream next.
        (var _ anObject instVarAt: i) == nil
            ifTrue:     "the normal case"
                [anObject instVarAt: i put: nextValue]
            ifFalse:    "Oops!! Recover: Concatenate nextValue and var Arrays."
                [nextValue == nil
                    ifFalse: [anObject instVarAt: i put: (nextValue,, var)]]].

    "Read in the indexed vars."
    1 to: cntIndexedVars do:
        [:i | anObject basicAt: i put: aDataStream next].

    ^ anObject! !DisplayObject subclass: #DisplayMedium
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
DisplayMedium comment:
'I am a display object which can both paint myself on a medium (displayOn: messages), and can act as a medium myself. My chief subclass is Form.'!

!DisplayMedium methodsFor: 'coloring'!
fill: aRectangle fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule over."

	self fill: aRectangle rule: Form over fillColor: aForm!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by 
	aForm according to the rule anInteger."

	self subclassResponsibility!
fillBlack
	"Set all bits in the receiver to black (ones)."

	self fill: self boundingBox fillColor: self black!
fillBlack: aRectangle 
	"Set all bits in the receiver's area defined by aRectangle to black (ones)."

	self fill: aRectangle rule: Form over fillColor: self black!
fillColor: aColor
	"Set all pixels in the receiver to the color.  Must be a correct color for this depth of medium.  TK 1 Jun 96"

	self fill: self boundingBox fillColor: aColor!
fillGray
	"Set all bits in the receiver to gray."

	self fill: self boundingBox fillColor: Color gray!
fillGray: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to the gray mask."

	self fill: aRectangle rule: Form over fillColor: Color gray!
fillShape: aShapeForm fillColor: aColor
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	^ self fillShape: aShapeForm fillColor: aColor at: 0@0!
fillShape: aShapeForm fillColor: aColor at: location
	"Fill a region corresponding to 1 bits in aShapeForm with aColor"

	((BitBlt destForm: self sourceForm: aShapeForm fillColor: aColor
		combinationRule: Form paint
		destOrigin: location + aShapeForm offset sourceOrigin: 0@0
		extent: self extent clipRect: self boundingBox)
		colorMap: (Bitmap with: 0 with: 16rFFFFFFFF))
		copyBits!
fillWhite
	"Set all bits in the form to white (zeros)."

	self fill: self boundingBox fillColor: self white!
fillWhite: aRectangle
	"Set all bits in the receiver's area defined by aRectangle to white (zeros)."

	self fill: aRectangle rule: Form over fillColor: self white!
fillWithColor: aColor
	"Fill the receiver's bounding box with the given color.  5/15/96 sw.  Subsequently fixed  by tk to be compatible with changed color definition.  7/31/96 sw: code tightened"

	self fill: self boundingBox fillColor:
		(aColor class == Symbol ifTrue: [Color perform: aColor] ifFalse: [aColor])!
reverse
	"Change all the bits in the receiver that are white to black, and the ones 
	that are black to white."

	self fill: self boundingBox rule: Form reverse fillColor: self highLight!
reverse: aRectangle
	"Change all the bits in the receiver's area that intersects with aRectangle 
	that are white to black, and the ones that are black to white."

	self fill: aRectangle rule: Form reverse fillColor: self highLight!
reverse: aRectangle fillColor: aMask	
	"Change all the bits in the receiver's area that intersects with aRectangle 
	according to the mask. Black does not necessarily turn to white, rather it 
	changes with respect to the rule and the bit in a corresponding mask 
	location. Bound to give a surprise."

	self fill: aRectangle rule: Form reverse fillColor: aMask! !

!DisplayMedium methodsFor: 'bordering'!
border: aRectangle width: borderWidth 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses Form black for 
	drawing the border."

	self border: aRectangle width: borderWidth fillColor: Color black!
border: aRectangle width: borderWidth fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: Form over
		fillColor: aHalfTone!
border: aRectangle width: borderWidth rule: combinationRule fillColor: aHalfTone 
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of the border of each side is borderWidth. Uses aHalfTone for 
	drawing the border."

	self border: aRectangle
		widthRectangle: 
			(Rectangle
				left: borderWidth
				right: borderWidth
				top: borderWidth
				bottom: borderWidth)
		rule: combinationRule
		fillColor: aHalfTone!
border: aRectangle widthRectangle: insets rule: combinationRule fillColor: aHalfTone
	"Paint a border whose rectangular area is defined by aRectangle. The 
	width of each edge of the border is determined by the four coordinates 
	of insets. Uses aHalfTone and combinationRule for drawing the border."

	(aRectangle areasOutside: (aRectangle insetBy: insets)) do:
		[:edgeStrip | self fill: edgeStrip rule: combinationRule fillColor: aHalfTone]! !

!DisplayMedium methodsFor: 'displaying'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	self subclassResponsibility!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Draw line by copying the argument, sourceForm, starting at location 
	beginPoint and ending at endPoint, clipped by the rectangle, clipRect. 
	The rule and mask for copying are the arguments anInteger and aForm."

	self subclassResponsibility! !Object subclass: #DisplayObject
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
DisplayObject comment: 'The abstract protocol for most display primitives that are used by Views for presenting information on the screen.'!

!DisplayObject methodsFor: 'accessing'!
extent
	"Answer the point that represents the width and height of the receiver's 
	bounding box."

	^self boundingBox extent!
height
	"Answer the number that represents the height of the receiver's 
	bounding box."

	^self boundingBox height!
offset
	"Answer the amount by which the receiver should be offset when it is 
	displayed or its position is tested."

	self subclassResponsibility!
offset: aPoint 
	"Set the amount by which the receiver's position is offset."

	^self!
relativeRectangle
	"Answer a Rectangle whose top left corner is the receiver's offset position 
	and whose width and height are the same as the receiver."

	^Rectangle origin: self offset extent: self extent!
width
	"Answer the number that represents the width of the receiver's bounding 
	box."

	^self boundingBox width! !

!DisplayObject methodsFor: 'truncation and round off'!
rounded
	"Convert the offset of the receiver to integer coordinates."

	self offset: self offset rounded! !

!DisplayObject methodsFor: 'transforming'!
align: alignmentPoint with: relativePoint 
	"Translate the receiver's offset such that alignmentPoint aligns with 
	relativePoint."

	self offset: (self offset translateBy: relativePoint - alignmentPoint)!
scaleBy: aPoint 
	"Scale the receiver's offset by aPoint."

	self offset: (self offset scaleBy: aPoint)!
translateBy: aPoint 
	"Translate the receiver's offset."

	self offset: (self offset translateBy: aPoint)! !

!DisplayObject methodsFor: 'display box access'!
boundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's space of information."

	^self computeBoundingBox!
center

	^ self boundingBox center!
computeBoundingBox
	"Answer the rectangular area that represents the boundaries of the 
	receiver's area for displaying information. This is the primitive for 
	computing the area if it is not already known."

	self subclassResponsibility! !

!DisplayObject methodsFor: 'displaying-generic'!
displayAt: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	the displayMedium, rule and halftone."

	self displayOn: Display
		at: aDisplayPoint
		clippingBox: Display boundingBox
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium
	"Simple default display in order to see the receiver in the upper left 
	corner of screen."

	self displayOn: aDisplayMedium at: 0 @ 0!
displayOn: aDisplayMedium at: aDisplayPoint 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle 
	"Display the receiver located at aDisplayPoint with default settings for 
	rule and halftone. Information to be displayed must be confined to the 
	area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: clipRectangle
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm
	"This is the basic display primitive for graphic display objects. Display 
	the receiver located at aDisplayPoint with rule, ruleInteger, and mask, 
	aForm. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self subclassResponsibility!
displayOn: aDisplayMedium at: aDisplayPoint rule: ruleInteger
	"Display the receiver located at aPoint with default setting for the 
	halftone and clippingBox."

	self displayOn: aDisplayMedium
		at: aDisplayPoint
		clippingBox: aDisplayMedium boundingBox
		rule: ruleInteger
		fillColor: nil!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle 
	"Display primitive for the receiver where a DisplayTransformation is 
	provided as an argument. Alignment is defaulted to the receiver's 
	rectangle. Information to be displayed must be confined to the area that 
	intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle center
		with: self relativeRectangle center
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint 
	"Display primitive where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. Information to be 
	displayed must be confined to the area that intersects with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: alignmentPoint
		with: relativePoint
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. Translate by 
	relativePoint-alignmentPoint. Information to be displayed must be 
	confined to the area that intersects with clipRectangle."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	self displayOn: aDisplayMedium
		at: (absolutePoint - alignmentPoint) 
		clippingBox: clipRectangle 
		rule: ruleInteger 
		fillColor: aForm !
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle fixedPoint: aPoint 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is over and mask is Form black. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: aPoint
		with: aPoint
		rule: Form over
		fillColor: nil!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Display the receiver where a DisplayTransformation is provided as an 
	argument, rule is ruleInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRectangle."

	self displayOn: aDisplayMedium
		transformation: displayTransformation
		clippingBox: clipRectangle
		align: self relativeRectangle origin
		with: self relativeRectangle origin
		rule: ruleInteger
		fillColor: aForm!
displayOnPort: aPort 
	self displayOnPort: aPort at: 0@0!
followCursor
	"Just show the Form following the mouse. 6/21/96 tk"
	Cursor blank showWhile:
		[self follow: [Sensor cursorPoint] while: [Sensor noButtonPressed]]
! !

!DisplayObject methodsFor: 'displaying-Display'!
display 
	"Display the receiver on the Display at location 0,0."

	self displayOn: Display!
follow: locationBlock while: durationBlock
   "Move an image around on the Display. Restore the background
   continuously without causing flashing. The argument, locationBlock,
   supplies each new location, and the argument, durationBlock, supplies
   true to continue, and then false to stop.
   8/20/96 sw: call follow:while:bitsBehind: to do the real work.  Note that th
method
   now returns the final bits behind as method value."
 
   | bitsBehind loc |
   bitsBehind _ Form fromDisplay: ((loc _ locationBlock value) extent: self extent).
   ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc!
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, and then false to stop.
   8/20/96 sw: this variant takes the bitsBehind as an input argument, and
returns the
   final saved saved bits as method value."
   | location newLoc save1 save1Blt buffer bufferBlt rect1 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 overlappin
region"
   bufferBlt _ BitBlt toForm: buffer.
   self displayOn: Display at: location.
   [durationBlock value] whileTrue:
   [newLoc _ locationBlock value.
   newLoc ~= location ifTrue:
   [rect2 _ newLoc extent: self extent.
   bothRects _ rect1 merge: rect2.
   (rect1 intersects: rect2)
   ifTrue:  "When overlap, buffer background for both rectangles"
   [bufferBlt copyFrom: bothRects in: Display to: 0@0.
   bufferBlt copyFrom: save1 boundingBox in: save1
   to: rect1 origin - bothRects origin.
   "now buffer is clean background; get new bits for save1"
   save1Blt copy: (0@0 extent: self extent)
   from: rect2 origin - bothRects origin in: buffer.
   self displayOnPort: bufferBlt at: rect2 origin - bothRects origin.
   Display copy: bothRects from: 0@0 in: buffer rule: Form over.]
   ifFalse: "If no overlap, do the simple thing (bothrects might be too big)"
   [Display copy: (location extent: save1 extent)
   from: 0@0 in: save1 rule: Form over.
   save1Blt copyFrom: rect2 in: Display to: 0@0.
   self displayOn: Display at: newLoc ].
   location _ newLoc.
   rect1 _ rect2]].
   ^ save1 displayOn: Display at: location!
slideFrom: startPoint to: stopPoint nSteps: nSteps 
	"does not display at the first point, but does at the last"
	| i p delta |
	i_0.  p_ startPoint.
	delta _ (stopPoint-startPoint) // nSteps.
	^ self follow: [p_ p+delta]
		while: [(i_i+1) < nSteps]! !

!DisplayObject methodsFor: 'fileIn/Out'!
writeOnFileNamed: fileName 
	"Saves the receiver on the file fileName in the format:
		fileCode, depth, extent, offset, bits."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	self writeOn: file.
	file close
"
 | f |
[(f _ Form fromUser) boundingBox area>25] whileTrue:
	[f writeOnFileNamed: 'test.form'.
	(Form newFromFileNamed: 'test.form') display].
"! !

!DisplayObject methodsFor: 'color'!
black
	"Caller should really ask Color for a color.  6/25/96 tk"

	^ Color black!
white
	"Caller should really ask Color for a color.  6/25/96 tk"

	^ Color white! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DisplayObject class
	instanceVariableNames: ''!

!DisplayObject class methodsFor: 'fileIn/Out'!
collectionFromFileNamed: fileName 
	"Answer a collection of Forms read from the external file 
	named fileName. The file format is: fileCode, {depth, extent, offset, bits}."
	| file fileCode coll |
	file _ FileStream oldFileNamed: fileName.
	file binary; readOnly.
	fileCode _ file next.
	fileCode = 1 ifTrue: [^ Array with: (self new readFromOldFile: file)].
	fileCode = 2 ifFalse: [self halt].
	coll _ OrderedCollection new.
	[file atEnd] whileFalse: [coll add: (self new readFrom: file)].
	file close.
	^ coll!
newFromFileNamed: fileName 
	"Answer a Form with bitmap initialized from the external file 
	named fileName. The file format is: fileCode, depth, extent, offset, bits."
	| newForm file fileCode |
	file _ FileStream oldFileNamed: fileName.
	file binary; readOnly.
	fileCode _ file next.
	fileCode = 1 ifTrue: [^ self new readFromOldFile: file].
	fileCode = 2 ifFalse: [self halt].
	newForm _ self new readFrom: file.
	file close.
	^ newForm!
writeCollection: coll onFileNamed: fileName 
	"Saves a collection of Forms on the file fileName in the format:
		fileCode, {depth, extent, offset, bits}."
	| file |
	file _ FileStream newFileNamed: fileName.
	file binary.
	file nextPut: 2.  "file code = 2"
	coll do: [:f | f writeOn: file].
	file close
"
 | f c | c _ OrderedCollection new.
[(f _ Form fromUser) boundingBox area>25] whileTrue: [c add: f].
Form writeCollection: c onFileNamed: 'test.forms'.
c _ Form collectionFromFileNamed: 'test.forms'.
1 to: c size do: [:i | (c at: i) displayAt: 0@(i*100)].
"! !

!DisplayObject class methodsFor: 'color'!
black
	"Caller should really ask Color for a color.  6/25/96 tk"

	^ Color black!
white
	"Caller should really ask Color for a color.  6/25/96 tk"

	^ Color white! !CharacterScanner subclass: #DisplayScanner
	instanceVariableNames: 'lineY runX '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Support'!
DisplayScanner comment:
'My instances are used to scan text and display it on the screen or in a hidden form.'!

!DisplayScanner methodsFor: 'scanning'!
displayLines: linesInterval in: aParagraph clippedBy: visibleRectangle 
	"The central display routine. The call on the primitive 
	(scanCharactersFrom:to:in:rightX:) will be interrupted according to an 
	array of stop conditions passed to the scanner at which time the code to 
	handle the stop condition is run and the call on the primitive continued 
	until a stop condition returns true (which means the line has 
	terminated)."

	| runLength done lineGrid lineIndex stopCondition leftInRun fore back |
	"leftInRun is the # of characters left to scan in the current run; when 0,
		it is time to call 'self setStopConditions'"
	leftInRun _ 0.
	super initializeFromParagraph: aParagraph clippedBy: visibleRectangle.
	destForm depth > 1 ifTrue:
		[fore _ aParagraph foregroundColor bitPatternForDepth: destForm depth.
		back _ aParagraph backgroundColor bitPatternForDepth: destForm depth.
		self colorMap: (Bitmap with: back first with: fore first)].
	rightMargin _ aParagraph rightMarginForDisplay.
	lineGrid _ textStyle lineGrid.
	lineY _ destY _ aParagraph topAtLineIndex: linesInterval first.
	linesInterval do: 
		[:lineIndex | 
		runX _ destX _ leftMargin _ 
			aParagraph leftMarginForDisplayForLine: lineIndex.
		line _ aParagraph lines at: lineIndex.
		lastIndex _ line first.
		leftInRun<= 0 
			ifTrue:
				[self setStopConditions.
				"also sets the font"
				leftInRun _ text runLengthFor: line first].
		runLength _ leftInRun.
		destY _ lineY + (textStyle baseline - font ascent).
		"fontAscent delta"
		(runStopIndex _ lastIndex + (runLength - 1)) > line last 
			ifTrue: [runStopIndex _ line last].
		leftInRun _ leftInRun - (runStopIndex - lastIndex + 1).
		spaceCount _ 0.
		done _ false.
		[done]
			whileFalse: 
				[stopCondition _ 
					self scanCharactersFrom: lastIndex
						to: runStopIndex
						in: text string
						rightX: rightMargin
						stopConditions: stopConditions
						displaying: true.
				"see setStopConditions for stopping conditions for displaying."
				done _ self perform: stopCondition].
		lineY _ lineY + lineGrid]! !

!DisplayScanner methodsFor: 'stop conditions'!
cr
	"When a carriage return is encountered, simply increment the pointer 
	into the paragraph."

	lastIndex_ lastIndex + 1.
	^false!
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 checkEmphasis.
	^ true !
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. A check for any emphasis 
	(underlining, for example) that may run the length of the run is done 
	here before returning to displayLines: to do the next line."

	| runLength |
	self checkEmphasis.
	lastIndex = line last ifTrue: [^true].
	runX _ destX.
	runLength _ text runLengthFor: (lastIndex _ lastIndex + 1).
	(runStopIndex _ lastIndex + (runLength - 1)) > line last 
		ifTrue: [runStopIndex _ line last].
	self setStopConditions.
	destY _ lineY + textStyle baseline - font ascent.
	"ascent delta"
	^false!
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."

	spaceCount _ spaceCount + 1.
	lastIndex _ lastIndex + 1.
	destX _ destX + spaceWidth + (line justifiedPadFor: spaceCount).
	^false!
setStopConditions
	"Set the font and the stop conditions for the current run."
	
	self setFont.
	stopConditions 
		at: Space asciiValue + 1 
		put: (textStyle alignment = Justified ifTrue: [#paddedSpace])!
tab
	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].
	lastIndex _ lastIndex + 1.
	^ false! !

!DisplayScanner methodsFor: 'private'!
checkEmphasis
	"convert mask to color 6/18/96 tk"
	| emphasis sourceRect y |
	(emphasis _ font emphasis) = 0 ifTrue: [^self].
	emphasis >= 8 ifTrue:  "struck out"
		[destForm
			fill: ((runX @ (lineY + textStyle baseline-3)) extent: (destX - runX) @ 1)
			rule: combinationRule fillColor: halftoneForm.	"color already converted to a Bitmap"
		emphasis _ emphasis - 8].
	emphasis >= 4 ifTrue:  "underlined"
		[destForm
			fill: ((runX @ (lineY + textStyle baseline)) extent: (destX - runX) @ 1)
			rule: combinationRule fillColor: halftoneForm.
		emphasis _ emphasis - 4].
	emphasis >= 2 ifTrue:  "itallic"
		[y _ lineY + textStyle lineGrid - 4.
		[y > lineY] whileTrue:
			[sourceRect _ runX @ lineY extent: (destX - runX - 1) @ (y - lineY).
			destForm
				copyBits: sourceRect from: destForm at: (runX+1) @ lineY
				clippingBox: sourceRect rule: Form over fillColor: nil.
			y _ y - 4].
		emphasis _ emphasis - 2].
	emphasis >= 1 ifTrue:  "bold face"
		[sourceRect _ runX @ lineY extent: (destX - runX - 1) @ textStyle lineGrid.
		destForm
			copyBits: sourceRect from: destForm at: (runX+1) @ lineY
			clippingBox: sourceRect rule: Form under fillColor: nil]!
doesDisplaying
	^true! !Form subclass: #DisplayScreen
	instanceVariableNames: 'clippingBox '
	classVariableNames: 'ScreenSave '
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
DisplayScreen comment:
'There is only one instance of me, Display. It is a global and is used to handle general user requests to deal with the whole display screen. 
	Although I offer no protocol, my name provides a way to distinguish this special instance from all other Forms. This is useful, for example, in dealing with saving and restoring the system.
	To change the depth of your Display...
		Display newDepth: 16.
		Display newDepth: 8.
		Display newDepth: 1.
Valid display depths are 1, 2, 4, 8, 16 and 32.  It is suggested that you run with your monitors setting the same, for better speed and color fidelity.  Note that this can add up to 4Mb for the Display form.  Finally, note that newDepth: ends by executing a ''ControlManager restore'' which currently terminates the active process, so nothing that follows in the doit will get executed.

Depths 1, 2, 4 and 8 bits go through a color map to put color on the screen, but 16 and 32-bit color use the pixel values directly for RGB color (5 and 8 bits per, respectivlely).  The color choice an be observed by executing Color fromUser in whatever depth you are using.
'!

!DisplayScreen methodsFor: 'displaying'!
boundingBox
	clippingBox == nil
		ifTrue: [clippingBox _ super boundingBox].
	^ clippingBox!
clippingTo: aRect do: aBlock
	"Display clippingTo: Rectangle fromUser do:
	[ScheduledControllers restore: Display fullBoundingBox]"
	| saveClip |
	saveClip _ clippingBox.
	clippingBox _ aRect.
	aBlock value.
	clippingBox _ saveClip!
copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf 
	(BitBlt
		destForm: self
		sourceForm: sf
		fillColor: hf
		combinationRule: cr
		destOrigin: destOrigin
		sourceOrigin: rect origin
		extent: rect extent
		clipRect: (clipRect intersect: clippingBox)) copyBits!
flash: aRectangle 
	"Complement twice the area of the screen defined by the argument, 
	aRectangle."

	2 timesRepeat:
		[self reverse: aRectangle.
		"(Delay forMilliseconds: 30) wait"]!
fullBoundingBox
	^ super boundingBox!
fullScreen   "Display fullScreen"

	ScreenSave notNil ifTrue: [Display _ ScreenSave].
	clippingBox _ super boundingBox!
height
	^ self boundingBox height!
replacedBy: aForm do: aBlock
	"Permits normal display to draw on aForm instead of the display."

	ScreenSave _ self.
	Display _ aForm.
	aBlock value.
	Display _ self.
	ScreenSave _ nil.!
restoreAfter: aBlock
	"Evaluate the block, wait for a mouse click, and then restore the screen"
	aBlock value.
	Sensor waitButton.
	ScheduledControllers  restore.
	ScheduledControllers activeController view emphasize!
usableArea
	"Answer the usable area of the receiver.  5/22/96 sw."

	^ self boundingBox deepCopy!
width
	^ self boundingBox width! !

!DisplayScreen methodsFor: 'private'!
beDisplay
	"Primitive. Tell the interpreter to use the receiver as the current display 
	image. Fail if the form is too wide to fit on the physical display. 
	Essential. See Object documentation whatIsAPrimitive."

	<primitive: 102>
	self primitiveFailed!
newDepth: pixelSize
"
	Display newDepth: 8.
	Display newDepth: 1.
"
	self newDepthNoRestore: pixelSize.
	ControlManager shutDown; startUp.!
newDepthNoRestore: pixelSize
	depth = pixelSize ifTrue: [^ self  "no change"].
	self depth: pixelSize.  self setExtent: self extent.
	ScheduledControllers updateGray.
	DisplayScreen startUp!
setExtent: aPoint  "DisplayScreen startUp"
	width _ aPoint x.
	height _ aPoint y.
	clippingBox _ nil.
	self bitsSize.  "Cause any errors before unrecoverable"
	bits _ nil.  "Free up old bitmap in case space is low"
	bits _ Bitmap new: self bitsSize.
	self boundingBox! !

!DisplayScreen methodsFor: 'disk I/O'!
objectToStoreOnDataStream
	"HyperSqueak is about to write me out.  See if I am a system object.  Write out just a name if so.  See SqueakSupport class.aComment.  8/13/96 tk"

	"Path or real thing, depending"
	^ Smalltalk hyperSqueakSupportClass sysRef: self! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DisplayScreen class
	instanceVariableNames: ''!

!DisplayScreen class methodsFor: 'display box access'!
boundingBox
	"Answer the bounding box for the form representing the current display 
	screen."

	^Display boundingBox! !

!DisplayScreen class methodsFor: 'snapshots'!
actualScreenSize
	<primitive: 106>
	^ 640@480!
shutDown 
	"Minimize Display memory saved in image"
	Display setExtent: 240@120!
startUp  "DisplayScreen startUp"
	Display setExtent: self actualScreenSize.
	Display beDisplay! !DisplayObject subclass: #DisplayText
	instanceVariableNames: 'text textStyle offset form foreColor backColor '
	classVariableNames: ''
	poolDictionaries: 'TextConstants '
	category: 'Graphics-Display Objects'!
DisplayText comment:
'I represent Text whose emphasis changes are mapped to a set of fonts. My instances have an offset used in determining screen placement for displaying. They get used two different ways in the system. In the user interface, they mainly hold onto some text which is viewed by some form of ParagraphEditor. However, as a DisplayObject, they may need to display efficiently, so my instances have a cache for the bits.'!

!DisplayText methodsFor: 'accessing'!
alignedTo: alignPointSelector
	"Return a copy with offset according to alignPointSelector which is one of...
	#(topLeft, topCenter, topRight, leftCenter, center, etc)"
	| boundingBox |
	boundingBox _ 0@0 corner: self form extent.
	^ self shallowCopy offset: (0@0) - (boundingBox perform: alignPointSelector)!
fontsUsed
	"Return a list of all fonts used currently in this text.  8/19/96 tk"

	^ text runs values asSet collect: [:each | textStyle fontAt: each]!
form 
	"Answer the form into which the receiver's display bits are cached."

	form == nil ifTrue: [self composeForm].
	^form!
lineGrid
	"Answer the relative space between lines of the receiver's text."

	^textStyle lineGrid!
numberOfLines 
	"Answer the number of lines of text in the receiver."

	^self height // text lineGrid!
offset 
	"Refer to the comment in DisplayObject|offset."

	^offset!
offset: aPoint 
	"Refer to the comment in DisplayObject|offset:."

	offset _ aPoint!
string
	"Answer the string of the characters displayed by the receiver."

	^text string!
text 
	"Answer the text displayed by the receiver."

	^text!
text: aText 
	"Set the receiver to display the argument, aText."
	
	text _ aText.
	form _ nil.
	self changed.
	!
textStyle 
	"Answer the style by which the receiver displays its text."

	^textStyle!
textStyle: aTextStyle 
	"Set the style by which the receiver should display its text."

	textStyle _ aTextStyle.
	form _ nil.
	self changed.
	! !

!DisplayText methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayObject|displayOn:at:clippingBox:rule:mask:."

	self form
		displayOn: aDisplayMedium
		at: aDisplayPoint + offset
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayObject|displayOn:transformation:clippingBox:align:with:rule:mask:."

	| absolutePoint |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	self displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm!
displayOnPort: aPort at: location
	self form displayOnPort: aPort at: location + offset! !

!DisplayText methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in DisplayObject|boundingBox."

	^self form boundingBox!
computeBoundingBox 
	"Compute minimum enclosing rectangle around characters."

	| character font width carriageReturn lineWidth lineHeight |
	carriageReturn _ Character cr.
	width _ lineWidth _ 0.
	font _ textStyle defaultFont.
	lineHeight _ textStyle lineGrid.
	1 to: text size do: 
		[:i | 
		character _ text at: i.
		character = carriageReturn
		  ifTrue: 
			[lineWidth _ lineWidth max: width.
			lineHeight _ lineHeight + textStyle lineGrid.
			width _ 0]
		  ifFalse: [width _ width + (font widthOf: character)]].
	lineWidth _ lineWidth max: width.
	^offset extent: lineWidth @ lineHeight! !

!DisplayText methodsFor: 'converting'!
asParagraph
	"Answer a Paragraph whose text and style are identical to that of the 
	receiver."

	^Paragraph withText: text style: textStyle! !

!DisplayText methodsFor: 'private'!
composeForm

	form _ self asParagraph asForm!
setText: aText textStyle: aTextStyle offset: aPoint

	text _ aText.
	textStyle _ aTextStyle.
	offset _ aPoint.
	form _ nil! !

!DisplayText methodsFor: 'color'!
backgroundColor
	backColor == nil ifTrue: [^ Display white].
	^ backColor!
foregroundColor
	foreColor == nil ifTrue: [^ Display black].
	^ foreColor!
foregroundColor: cf backgroundColor: cb
	foreColor _ cf.
	backColor _ cb! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DisplayText class
	instanceVariableNames: ''!

!DisplayText class methodsFor: 'instance creation'!
text: aText 
	"Answer an instance of me such that the text displayed is aText 
	according to the system's default text style."

	^self new
		setText: aText
		textStyle: DefaultTextStyle copy
		offset: 0 @ 0!
text: aText textStyle: aTextStyle 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: 0 @ 0!
text: aText textStyle: aTextStyle offset: aPoint 
	"Answer an instance of me such that the text displayed is aText 
	according to the style specified by aTextStyle. The display of the 
	information should be offset by the amount given as the argument, 
	aPoint."

	^self new
		setText: aText
		textStyle: aTextStyle
		offset: aPoint! !

!DisplayText class methodsFor: 'examples'!
example
	"Continually prints two lines of text wherever you point with the cursor 
	and press any mouse button.  Terminate by pressing any key on the 
	keyboard."

	| t |
	t _ 'this is a line of characters and
this is the second line.' asDisplayText.
	t alignTo: #center.
	[Sensor anyButtonPressed]
		whileFalse:
			[t displayOn: Display at: Sensor cursorPoint]

	"DisplayText example."! !View subclass: #DisplayTextView
	instanceVariableNames: 'rule mask editParagraph centered '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Views'!
DisplayTextView comment:
'I represent a view of an instance of DisplayText.'!

!DisplayTextView methodsFor: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	centered _ false! !

!DisplayTextView methodsFor: 'accessing'!
centered

	centered _ true.
	self centerText!
fillColor
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask!
fillColor: aForm 
	"Set aForm to be the mask used when displaying the receiver's model."

	mask _ aForm!
isCentered

	^centered!
mask
	"Answer an instance of class Form that is to be used as the mask when 
	displaying the receiver's model (a DisplayText)."

	^ mask!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules is to be used when copying the receiver's model (a 
	DisplayText) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]!
rule: anInteger 
	"Set anInteger to be the rule used when displaying the receiver's model."

	rule _ anInteger! !

!DisplayTextView methodsFor: 'controller access'!
defaultController 
	"Refer to the comment in View|defaultController."

	^self defaultControllerClass newParagraph: editParagraph!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ParagraphEditor! !

!DisplayTextView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^self inverseDisplayTransform: (editParagraph boundingBox expandBy: 6 @ 6)!
window: aWindow 
	"Refer to the comment in View|window:."

	super window: aWindow.
	self centerText! !

!DisplayTextView methodsFor: 'model access'!
model: aDisplayText 
	"Refer to the comment in View|model:."

	super model: aDisplayText.
	editParagraph _ model asParagraph.
	self centerText! !

!DisplayTextView methodsFor: 'displaying'!
display 
	"Refer to the comment in View|display."

	self isUnlocked ifTrue: [self positionText].
	super display!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	(self controller isKindOf: ParagraphEditor )
		ifTrue: [controller changeParagraph: editParagraph].
	editParagraph foregroundColor: self foregroundColor
				backgroundColor: self backgroundColor.
	self isCentered
		ifTrue: 
			[editParagraph displayOn: Display
				transformation: self displayTransformation
				clippingBox: self insetDisplayBox
				fixedPoint: editParagraph boundingBox center]
		ifFalse: 
			[editParagraph displayOn: Display]!
uncacheBits
	"Normally only sent to a StandardSystemView, but for casees where a DisplayTextView is used alone, without a superview, in which we make this a no-op, put in so that the Character Recognizer doesn't fail.  8/9/96 sw"! !

!DisplayTextView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."

	(self controller isKindOf: ParagraphEditor)
	 	ifTrue: [controller deselect]! !

!DisplayTextView methodsFor: 'private'!
centerText

	self isCentered
		ifTrue: 
			[editParagraph
				align: editParagraph boundingBox center
				with: self getWindow center]!
defaultRule

	^Form over!
positionText

	| box |
	box _ (self displayBox insetBy: 6@6) origin extent: editParagraph boundingBox extent.
	editParagraph wrappingBox: box clippingBox: box.
	self centerText! !

!DisplayTextView methodsFor: 'lock access'!
lock 
	"Refer to the comment in View|lock.  Must do what would be done by displaying..."

	self isUnlocked ifTrue: [self positionText].
	super lock! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DisplayTextView class
	instanceVariableNames: ''!

!DisplayTextView class methodsFor: 'examples'!
example1	
	"Create a system view with a paragraph editor in it."
	| topView aDisplayTextView |
	aDisplayTextView _ DisplayTextView new model: 'test string' asDisplayText.
	aDisplayTextView borderWidth: 2.
	topView _ StandardSystemView new.
	topView label: 'Text Editor'.
	topView addSubView: aDisplayTextView.
	topView controller open

	"DisplayTextView example1"!
example2	
	"Create a standarad system view with two parts, one editable, the other not."
	| topView aDisplayTextView |
	topView _ StandardSystemView new.
	topView label: 'Text Editor'.
	aDisplayTextView _ self new model: 'test string label' asDisplayText.
	aDisplayTextView controller: NoController new.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	topView addSubView: aDisplayTextView.

	aDisplayTextView _ self new model: 'test string' asDisplayText.
	aDisplayTextView window: (0 @ 0 extent: 100 @ 100).
	aDisplayTextView borderWidth: 2.
	topView
		addSubView: aDisplayTextView
		align: aDisplayTextView viewport topLeft
		with: topView lastSubView viewport topRight.
	topView controller open

	"DisplayTextView example2"!
example3	
	"Create a passive view of some text on the screen."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 2.
	view display.
	view release

	"DisplayTextView example3"!
example4	
	"Create four passive views of some text on the screen with fat borders."
	| view |
	view_ self new model: 'this is a test of one line
and the second line' asDisplayText.
	view translateBy: 100@100.	
	view borderWidth: 5.
	view display.
	3 timesRepeat: [view translateBy: 100@100. view display].
	view release

	"DisplayTextView example4"!
open: textOrString label: aLabel
	"Create a system view with a paragraph editor in it.  6/2/96 sw"

	| topView aDisplayTextView |
	aDisplayTextView _ DisplayTextView new model: textOrString asDisplayText.
	aDisplayTextView borderWidth: 2.
	topView _ StandardSystemView new.
	topView label: aLabel.
	topView addSubView: aDisplayTextView.
	topView controller open

	"DisplayTextView open: 'Great green gobs' label: 'Gopher Guts'"! !Model subclass: #DualChangeSorter
	instanceVariableNames: 'leftCngSorter rightCngSorter '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Changes'!

!DualChangeSorter methodsFor: 'everything'!
aReadThis
	"This class presents a view of a two change sets at once.  See ChangeSorter for the details of how each sorter works.  
	
	DualChangeSorter new open.
	DualChangeSorter allInstances inspect
	"!
defaultBackgroundColor
	^ #lightBlue!
isLeftSide: theOne
	"Which side am I?"
	^ theOne == leftCngSorter!
open
	"1991, tk.  Modified 5/16/96 sw: decrease minimum size drastically
	 6/18/96 sw: more modest minimum size, and other minor adjustments"

	| topView |
	leftCngSorter _ ChangeSorter new initialize.
	leftCngSorter parent: self.
	rightCngSorter _ ChangeSorter new initialize.
	rightCngSorter parent: self.

	topView _ StandardSystemView new.
	topView model: self.
	topView label: leftCngSorter label.
	topView minimumSize: 300 @ 200.
	self openView: topView.
	topView controller open!
openView: topView
	"Create views of dual side-by-side change sorter views"
	| leftView rightView |

	leftView _ View new.
	leftView model: leftCngSorter.
	leftView window: (0 @ 0 extent: 360 @ 360).
	leftView borderWidthLeft: 0 right: 0 top: 0 bottom: 0.
	leftCngSorter openView: leftView.


	rightView _ View new.
	rightView model: rightCngSorter.
	rightView window: (0 @ 0 extent: 360 @ 360).
	rightView borderWidthLeft: 0 right: 0 top: 0 bottom: 0.
	rightCngSorter openView: rightView.

	topView addSubView: leftView.
	topView addSubView: rightView.

	" leftView 
		align: leftView viewport topLeft 	
		with: topView viewport topLeft. "
	rightView 
		align: rightView viewport topLeft 	
		with: leftView viewport topRight.
!
other: theOne
	"Return the other side's ChangeSorter"
	^ theOne == leftCngSorter
		ifTrue: [rightCngSorter]
		ifFalse: [leftCngSorter]!
release
	leftCngSorter release.
	rightCngSorter release.! !Stream subclass: #DummyStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Objects to Disk'!

!DummyStream methodsFor: 'as yet unclassified'!
aComment
	"The purpose of this class is to absorb all steam messages and do nothing.  This is so ReferenceStream can pretend to write on it while traversing all objects it would normally write.  We need to know what those object are.  8/17/96 tk"!
binary
	"do nothing"!
nextInt32Put: arg
	"do nothing"!
nextNumber: cnt put: num
	"do nothing"!
nextStringPut: aString
	"do nothing"!
position
	"Return any random number.  Here is where the real lying begins.  We are a DummyStream afterall.  8/17/96 tk"

	^ 47 !
subclassResponsibility
	"Do nothing.  Most messages to class Stream are defined as subclassResponsibility.  Just accept them.  8/17/96 tk"

	"No error.  Just go on."! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

DummyStream class
	instanceVariableNames: ''!

!DummyStream class methodsFor: 'as yet unclassified'!
on: aFile
	"Do nothing.  8/17/96 tk"
	^ self basicNew! !ParseNode subclass: #Encoder
	instanceVariableNames: 'scopeTable nTemps supered requestor class literalStream selectorSet litIndSet litSet sourceRanges '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
Encoder comment:
'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'!
fillDict: dict with: nodeClass mapping: keys to: codeArray

	| codeStream key |
	codeStream _ ReadStream on: codeArray.
	keys do: 
		[:key | dict 
				at: key
				put:  (nodeClass new name: key key: key code: codeStream next)]!
init: aClass context: aContext notifying: req

	| variable node n homeNode indexNode |
	requestor _ req.
	class _ aClass.
	nTemps _ 0.
	supered _ false.
	self initScopeAndLiteralTables.
	n _ -1.
	class allInstVarNames do: 
		[:variable | 
		node _ VariableNode new
					name: variable
					index: (n _ n + 1)
					type: LdInstType.
		scopeTable at: variable put: node].
	aContext == nil
		ifFalse: 
			[homeNode _ self bindTemp: 'homeContext'.
			"first temp = aContext passed as arg"
			n _ 0.
			aContext tempNames do: 
				[:variable | 
				indexNode _ self encodeLiteral: (n _ n + 1).
				node _ MessageNode new
							receiver: homeNode
							selector: #tempAt:
							arguments: (Array with: indexNode)
							precedence: 3
							from: self.
				scopeTable at: variable put: node]].
	sourceRanges _ Dictionary new: 32!
initScopeAndLiteralTables

	scopeTable _ StdVariables copy.
	litSet _ StdLiterals copy.
	selectorSet _ StdSelectors copy.
	litIndSet _ Dictionary new: 16.
	literalStream _ WriteStream on: (Array new: 32)!
noteSuper

	supered _ true!
nTemps: n literals: lits class: cl 
	"Decompile."

	class _ cl.
	nTemps _ n.
	literalStream _ ReadStream on: lits.
	literalStream position: lits size!
release

	requestor _ nil! !

!Encoder methodsFor: 'encoding'!
cantStoreInto: varName

	^StdVariables includesKey: varName!
encodeLiteral: object

	^self
		name: object
		key: (class literalScannedAs: object notifying: self)
		class: LiteralNode
		type: LdLitType
		set: litSet!
encodeSelector: selector

	^self
		name: selector
		key: selector
		class: SelectorNode
		type: SendType
		set: selectorSet!
encodeVariable: name
	^ self encodeVariable: name ifUnknown: [ self undeclared: name ]!
encodeVariable: name ifUnknown: action

	| varNode assoc sym |
	varNode _ 
		scopeTable 
			at: name
			ifAbsent: 
				[self lookupInPools: name 
					ifFound: [:assoc | ^self global: assoc name: name].
				^action value].
	^varNode!
litIndex: literal
	| p |
	p _ literalStream position.
	p = 64 ifTrue:
		[self notify: 'More than 64 literals referenced. 
You must split or otherwise simplify this method.
The 65th literal is: ', literal printString. ^nil].
		"Would like to show where it is in the source code, 
		 but that info is hard to get."
	literalStream nextPut: literal.
	^ p!
undeclared: name

	| sym |
	requestor interactive ifTrue: [^self notify: 'Undeclared'].
	Transcript show: ' (' , name , ' is Undeclared) '.
	sym _ name asSymbol.
	Undeclared at: sym put: nil.
	^self global: (Undeclared associationAt: sym) name: sym! !

!Encoder methodsFor: 'temps'!
autoBind: name 
	"Declare a block argument as a temp if not already declared."

	| node assoc |
	node _ 
		scopeTable 
			at: name
			ifAbsent: 
				[(self lookupInPools: name ifFound: [:assoc | assoc])
					ifTrue: [self notify: 'Name already used in a Pool or Global'].
				^self reallyBind: name].
	node isTemp ifFalse: [^self notify: 'Name already used in this class'].
	^node!
bindTemp: name 
	"Declare a temporary; error not if a field or class variable."

	(scopeTable includesKey: name)
		ifTrue: [^self notify: 'Name is already defined'].
	^self reallyBind: name!
maxTemp

	^nTemps!
newTemp: name

	nTemps _ nTemps + 1.
	^VariableNode new
		name: name
		index: nTemps - 1
		type: LdTempType! !

!Encoder methodsFor: 'results'!
allLiterals
	supered ifTrue: [self litIndex: (self associationFor: class)].
	^ literalStream contents!
associationFor: aClass

	| name |
	name _ Smalltalk keyAtValue: aClass ifAbsent: [^Association new value: aClass].
	^Smalltalk associationAt: name!
literals
	"Should only be used for decompiling primitives"
	^ literalStream contents!
tempNames 
	| tempNodes |
	tempNodes _ SortedCollection sortBlock: [:n1 :n2 | n1 code <= n2 code].
	scopeTable associationsDo:
		[:assn | (assn value isTemp and:
				[assn value isMemberOf: VariableNode]) "no remote temps"
			ifTrue: [tempNodes add: assn value]].
	^tempNodes collect: [:node | node key]! !

!Encoder methodsFor: 'error handling'!
notify: string
	"Put a separate notifier on top of the requestor's window"
	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string].
	^false!
notify: string at: location

	| req |
	requestor == nil
		ifFalse: 
			[req _ requestor.
			self release.
			req notify: string at: location].
	^false!
requestor: req
	"Often the requestor is a BrowserCodeController"
	requestor _ req! !

!Encoder methodsFor: 'source mapping'!
noteSourceRange: range forNode: node

	sourceRanges at: node put: range!
sourceMap
	"Answer with a sorted set of associations (pc range)."

	| key |
	^(sourceRanges keys collect: 
		[:key |  Association key: key pc value: (sourceRanges at: key)])
			asSortedCollection! !

!Encoder methodsFor: 'private'!
classEncoding
	"This is a hack so that the parser may findout what class it was parsing for when it wants to create a syntax error view."
	^ class!
global: ref name: name

	^self
		name: name
		key: ref
		class: VariableNode
		type: LdLitIndType
		set: litIndSet!
lookupInPools: name ifFound: assocBlock

	| sym out |
	Symbol 
		hasInterned: name 
		ifTrue: [:sym | ^class scopeHas: sym ifTrue: assocBlock].
	^ class scopeHas: name ifTrue: assocBlock.  "Its a string in the pool"!
name: name key: key class: leafNodeClass type: type set: dict

	| node |
	^dict 
		at: key
		ifAbsent: 
			[node _ leafNodeClass new
						name: name
						key: key
						index: nil
						type: type.
			dict at: key put: node.
			^node]!
possibleVariablesFor: proposedVariable

	| results |
	results _ proposedVariable correctAgainstDictionary: scopeTable
								continuedFrom: nil.
	proposedVariable first isUppercase ifTrue:
		[ results _ class possibleVariablesFor: proposedVariable
						continuedFrom: results ].
	^ proposedVariable correctAgainst: nil continuedFrom: results.
!
reallyBind: name

	| node |
	node _ self newTemp: name.
	scopeTable at: name put: node.
	^node! !ReadWriteStream subclass: #ExternalStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
ExternalStream comment:
'I represent an accessor for a sequence of objects that communicate to the outside world. My instances can contain non-homogenous elements. Assumes streaming on a collection of binary, byte-sized elements. My methods assume that a "word" consists of two-bytes.'!

!ExternalStream methodsFor: 'accessing'!
next: anInteger 
	"Answer the next anInteger elements of my collection. Must override 
	because default uses self contents species, which might involve a large 
	collection."

	| newArray |
	newArray _ collection species new: anInteger.
	1 to: anInteger do: [:index | newArray at: index put: self next].
	^newArray! !

!ExternalStream methodsFor: 'nonhomogeneous positioning'!
padTo: bsize 
	"Pad (skip) to next boundary of bsize characters, and answer how many 
	characters were skipped."

	self subclassResponsibility!
padTo: bsize put: aCharacter 
	"Pad using the argument, aCharacter, to the next boundary of bsize 
	characters, and answer how many characters were written."

	self subclassResponsibility!
padToNextWord
	"Make position even (on word boundary), answering the padding 
	character if any."

	self position even
		ifTrue: [^false]
		ifFalse: [^self next]!
padToNextWordPut: char
	"Make position even on word boundary, writing the padding character, 
	char, if necessary."

	self position even
		ifTrue: [^nil]
		ifFalse: [^self nextPut: char]!
skipWords: nWords 
	"Position after nWords number of words."

	self skip: 2 * nWords!
wordPosition
	"Answer the current position in words."

	^self position / 2!
wordPosition: wp 
	"Set current position in words to be wp."

	self position: 2 * wp! !

!ExternalStream methodsFor: 'nonhomogeneous accessing'!
nextInt32
	"Read a 32-bit signed integer from the next 4 bytes"
	| s |
	s _ 0.
	1 to: 4 do: [:i | s _ (s bitShift: 8) + self next].
	(s bitAnd: 16r80000000) = 0
		ifTrue: [^ s]
		ifFalse: [^ -1 - s bitInvert32]!
nextInt32Put: int32
	"Write a signed integer to the next 4 bytes"
	| pos |
	pos _ int32 < 0
		ifTrue: [(0-int32) bitInvert32 + 1]
		ifFalse: [int32].
	1 to: 4 do: [:i | self nextPut: (pos digitAt: 5-i)].
	^ int32!
nextNumber: n 
	"Answer the next n bytes as a positive Integer or LargePositiveInteger."

	| s |
	n <= 2
		ifTrue: 
			[s _ 0.
			n timesRepeat: [s _ s * 256 + self next].
			^s].
	s _ LargePositiveInteger new: n.
	1 to: n do: [:i | s at: n + 1 - i put: self next].
	"reverse order of significance"
	^s normalize!
nextNumber: n put: v 
	"Append to the receiver the argument, v, which is a positive 
	SmallInteger or a LargePositiveInteger, as the next n bytes.
	Possibly pad with leading zeros."

	1 to: n do: [:i | self nextPut: (v digitAt: 5-i)].
	^ v
!
nextString
	"Read a string from the receiver. The first byte is the length of the 
	string, unless it is greater than 192, in which case the first two bytes 
	encode the length."

	| aString char length|
	length _ self next.		"first byte."
	length >= 192 ifTrue: [length _ (length - 192) * 256 + self next].
	aString _ String new: length.
	1 to: length do: [:i | aString at: i put: self next asCharacter].
	^aString!
nextStringPut: s 
	"Append the string, s, to the receiver."

	| length |
	(length _ s size) < 192
		ifTrue: [self nextPut: length]
		ifFalse: 
			[self nextPut: (length // 256 + 192).
			self nextPut: (length \\ 256)].
	s do: [:char | self nextPut: char asciiValue].
	^s!
nextWord
	"Answer the next two bytes from the receiver as an Integer."

	| high low |
	high _ self next.
		high==nil ifTrue: [^false].
	low _ self next.
		low==nil ifTrue: [^false].
	^(high asInteger bitShift: 8) + low asInteger!
nextWordPut: aWord 
	"Append to the receiver an Integer as the next two bytes."

	self nextPut: ((aWord bitShift: -8) bitAnd: 255).
	self nextPut: (aWord bitAnd: 255).
	^aWord! !

!ExternalStream methodsFor: 'positioning'!
resetContents
	"Set the position and limits to 0."

	position _ 0.
	readLimit _ 0! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ExternalStream class
	instanceVariableNames: ''!

!ExternalStream class methodsFor: 'instance creation'!
new

	^self basicNew! !Object subclass: #FakeClassPool
	instanceVariableNames: ''
	classVariableNames: 'SystemChanges LastQuitLogPosition CachedClassNames LowSpaceProcess LowSpaceSemaphore SpecialSelectors '
	poolDictionaries: ''
	category: 'Interface-Browser'!
FakeClassPool comment:
'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.'!

!FakeClassPool methodsFor: 'as yet unclassified'!
aReadThis
	"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."! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FakeClassPool class
	instanceVariableNames: ''!

!FakeClassPool class methodsFor: 'as yet unclassified'!
classPool: aDictionary
	"temporarily use the classPool of another class"
	classPool _ aDictionary!
sharedPools: anOrderedCollection
	"temporarily use the sharedPools of another class"
	sharedPools _ anOrderedCollection! !Boolean subclass: #False
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Objects'!
False comment:
'I represent the logical value false.'!

!False methodsFor: 'logical operations'!
& alternativeObject 
	"Evaluating conjunction -- answer false since receiver is false."

	^self!
not
	"Negation -- answer true since the receiver is false."

	^true!
| aBoolean 
	"Evaluating disjunction (OR) -- answer with the argument, aBoolean."

	^aBoolean! !

!False methodsFor: 'controlling'!
and: alternativeBlock 
	"Nonevaluating conjunction -- answer with false since the receiver is false."

	^self!
ifFalse: alternativeBlock 
	"Answer the value of alternativeBlock. Execution does not actually
	reach here because the expression is compiled in-line."

	^alternativeBlock value!
ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value!
ifTrue: alternativeBlock 
	"Since the condition is false, answer the value of the false alternative, 
	which is nil. Execution does not actually reach here because the
	expression is compiled in-line."

	^nil!
ifTrue: trueAlternativeBlock ifFalse: falseAlternativeBlock 
	"Answer the value of falseAlternativeBlock. Execution does not
	actually reach here because the expression is compiled in-line."

	^falseAlternativeBlock value!
or: alternativeBlock 
	"Nonevaluating disjunction -- answer value of alternativeBlock."

	^alternativeBlock value! !

!False methodsFor: 'printing'!
printOn: aStream 

	aStream nextPutAll: 'false'! !

!False methodsFor: 'conversion'!
binaryValue
	^0
! !Dictionary subclass: #FastDictionary
	instanceVariableNames: 'key1 assoc1 key2 assoc2 key3 assoc3 key4 assoc4 '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!FastDictionary methodsFor: 'as yet unclassified'!
at: key ifAbsent: aBlock
	"Answer the value associated with the key.  Look in cache first.  Remember to invalidate when removing.  7/10/96 tk"

	| index which |
	key == key1 ifTrue: [^ assoc1 value].
	key == key2 ifTrue: [^ assoc2 value].
	key == key3 ifTrue: [^ assoc3 value].
	key == key4 ifTrue: [^ assoc4 value].

	index _ self findElementOrNil: key.
	(array at: index) == nil ifTrue: [^ aBlock value].

	which _ ((Time millisecondClockValue) bitAnd: 3) + 1.
	which = 1 ifTrue: [key1 _ key.  assoc1 _ array at: index. ^ assoc1 value].
	which = 2 ifTrue: [key2 _ key.  assoc2 _ array at: index. ^ assoc2 value].
	which = 3 ifTrue: [key3 _ key.  assoc3 _ array at: index. ^ assoc3 value].
	which = 4 ifTrue: [key4 _ key.  assoc4 _ array at: index. ^ assoc4 value].
	self error: 'had to be one of those!!'!
rehash
	"Rehash gives new Associations, so must clear old ones from the cache.  9/7/96 tk"

key1 _ Array new: 1.	"Unique"
key2 _ Array new: 1.	"Unique"
key3 _ Array new: 1.	"Unique"
key4 _ Array new: 1.	"Unique"
^ super rehash!
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.
	If the key is cached, clear it's entry.  7/10/96 tk"

	key == key1 ifTrue: [key1 _ Array new: 1].	"Unique"
	key == key2 ifTrue: [key2 _ Array new: 1].	"Unique"
	key == key3 ifTrue: [key3 _ Array new: 1].	"Unique"
	key == key4 ifTrue: [key4 _ Array new: 1].	"Unique"
	^ super removeKey: key ifAbsent: aBlock! !StringHolderController subclass: #FileController
	instanceVariableNames: ''
	classVariableNames: 'FileYellowButtonMenu FileYellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileController comment:
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). The commands accept and cancel are omitted. I provide control for editing the contents of an external file. Additional menu commands are:
	fileItIn	treat the text selection as though it were the contents of a file and read it into the system
	get	retrieve the file contents to be the contents of the StringHolder (analogous to cancel)
	put	save the contents of the StringHolder in the file (analogous to accept)'!

!FileController methodsFor: 'menu messages'!
browseChanges
	"Browse the selected file in fileIn format."
	self controlTerminate.
	model browseChanges.
	self controlInitialize!
get
	"Get contents of file again, it may have changed. Do this by making the 
	cancel string be the contents, and doing a cancel."

	Cursor read
		showWhile: 
			[initialText _ (model readContentsBrief: false) asText.
			self cancel]!
getHex
	"Get contents of file again, and display in Hex. Do this by making the 
	cancel string be the contents, and doing a cancel."

	Cursor read
		showWhile: 
			[initialText _ (model readContentsHex) asText.
			self cancel]!
put
	"Replace file contents with contents of view."

	self controlTerminate.
	model put: paragraph string.
	self unlockModel.
	self controlInitialize! !

!FileController methodsFor: 'private'!
initializeYellowButtonMenu

	self yellowButtonMenu: FileYellowButtonMenu
		yellowButtonMessages: FileYellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileController class
	instanceVariableNames: ''!

!FileController class methodsFor: 'class initialization'!
initialize
	"Initialize the yellow button pop-up menu for a file controller; this is the same as for a general text widnow, with the addition of the top four file-related items.  5/12/96 sw"

	FileYellowButtonMenu _ PopUpMenu labels: 
'file it in
put
get
view as hex
browse changes
find...(f)
find again (g)
set search string (h)
do again (j)
undo (z)
copy (c)
cut (x)
paste (v)
do it (d)
print it (p)
inspect it (i)
accept (s)
cancel (l)
more...' 
		lines: #(5 8 10 13 16 18).

	FileYellowButtonMessages _ 
		#(fileItIn put get getHex browseChanges find findAgain setSearchString again undo copySelection cut paste doIt printIt inspectIt accept cancel shiftedYellowButtonActivity)

"FileController initialize"
! !

FileController initialize!
Object subclass: #FileDirectory
	instanceVariableNames: 'pathName closed '
	classVariableNames: 'DefaultDirectory '
	poolDictionaries: ''
	category: 'System-Files'!
FileDirectory comment:
'I represent a collection of Files. My instances are uniquely identified by the device or server to which they refer. They may also be found in some other dictionary or FileDirectory, though often this is implicit.'!

!FileDirectory methodsFor: 'path name'!
pathName
	^ pathName!
pathNameDelimiter
	^ self class pathNameDelimiter!
pathParts
	^ pathName findTokens: self pathNameDelimiter asString! !

!FileDirectory methodsFor: 'file names'!
fileNames
	"FileDirectory default fileNames"
	^ self directoryContents collect: [:spec | spec first]!
fileNamesMatching: pat
	"FileDirectory default fileNamesMatching: '*'"
	^ self directoryContents
		collect: [:spec | spec first]
		thenSelect: [:fname | pat match: fname]!
fullNameFor: fileName
	(pathName isEmpty
		or: [fileName includes: self pathNameDelimiter])
		ifTrue: [^ fileName].
	^ pathName , self pathNameDelimiter asString , fileName!
localNameFor: fileName
	pathName isEmpty ifTrue: [^ fileName].
	pathName size >= fileName size ifTrue: [String new].
	(pathName, '*' match: fileName)
		ifTrue: [^ fileName copyFrom: pathName size+2
							to: fileName size].
	^ String new! !

!FileDirectory methodsFor: 'file creation'!
copyFileNamed: fileName1 toFileNamed: fileName2
	"FileDirectory default copyFileNamed: 'todo.txt'
						toFileNamed: 'todocopy.txt'"
	| file1 file2 buffer |
	file1 _ self readOnlyFileNamed: fileName1.
	file2 _ self newFileNamed: fileName2.
	buffer _ String new: 50000.
	[file1 atEnd] whileFalse:
		[file2 nextPutAll: (file1 nextInto: buffer)].
	file1 close.  file2 close!
fileNamed: fileName
	^ self fileClass fileNamed: (self fullNameFor: fileName)!
newFileNamed: fileName
	^ self fileClass newFileNamed: (self fullNameFor: fileName)!
oldFileNamed: fileName
	^ self fileClass oldFileNamed: (self fullNameFor: fileName)!
readOnlyFileNamed: fileName
	^ self fileClass readOnlyFileNamed: (self fullNameFor: fileName)! !

!FileDirectory methodsFor: 'delete, rename'!
deleteFileNamed: aFileName
	^ self primitiveDeleteFileNamed: (self fullNameFor: aFileName)!
deleteFileNamed: aFileName ifAbsent: failBlock
	"Delete the file of the given name if it exists, else evaluate failBlock"
	(self deleteFileNamed: aFileName) == nil ifTrue: [^ failBlock value]!
primitiveDeleteFileNamed: aFileName
	"Delete the file of the given name.
	^ self if it had existed, else ^ nil"
	<primitive: 156>
	^ nil!
primitiveRename: oldFileName toBe: newFileName 
	"Rename the file of the given name if it exists, else fail"
	<primitive: 159>
	self halt: 'Attempt to rename a non-existent file,
or to use a name that is already in use'!
rename: oldFileName toBe: newFileName 
	^ self primitiveRename: (self fullNameFor: oldFileName)
						toBe: (self fullNameFor: newFileName) 
! !

!FileDirectory methodsFor: 'dictionary access'!
includesKey: aString
	"Answer whether the receiver includes an element of the given name."
	"Note: aString may designate a file local to this directory, or it may be a full path name. Try both."

	^ (StandardFileStream isAFileNamed: pathName, ':', aString) or:
		[StandardFileStream isAFileNamed: aString]!
keysDo: nameBlock
	^ self fileNames do: nameBlock! !

!FileDirectory methodsFor: 'file status'!
close
	"Close the receiver if it is not already closed."

	closed ifFalse: [self release]!
closed
	"Answer whether the receiver is closed."

	^closed!
open
	"Open the directory."

	closed _ false.
!
release
	"Release the receiver. a more forgiving version of close which should
	always be possible even if close isn't desired or doesn't work."

	closed _ true! !

!FileDirectory methodsFor: 'printing'!
printOn: aStream 
	"Refer to the comment in Object|printOn:."

	aStream nextPutAll: 
		(self closed ifTrue: ['a closed '] ifFalse: ['an open ']).
	aStream nextPutAll: self class name.
	aStream nextPutAll: ' on '.
	pathName printOn: aStream! !

!FileDirectory methodsFor: 'private'!
directoryContents
	"FileDirectory default directoryContents"
	^ self class directoryContentsFor: pathName!
fileClass
	"Answer the proper subclass of File of which the files in the receiver are 
	instances."

	self subclassResponsibility!
setPathName: pathString
	pathName _ pathString! !

!FileDirectory methodsFor: 'file names-old'!
checkName: aFileName fixErrors: fixing 
	"Check a string aFileName for validity as a file name. If there are 
	problems (e.g., illegal length or characters) and fixing is false, create 
	an error; if there are problems and fixing is true, make the name legal 
	(usually by truncating and/or tranforming characters) and answer the 
	new name. Otherwise, answer the name. Default behavior is to shorten
	to 31 chars. Subclasses can do any kind of checking they want and 
	answer either the name, or false if no good."

	aFileName isEmpty
		ifTrue: [self error: 'file name empty'].
	aFileName size > 31 ifTrue:
		[fixing ifTrue: [^ aFileName contractTo: 31]
				ifFalse: [self error: 'file name too long']].
	^ aFileName!
checkNameOfFile: aFileName
	"See FileDirector|checkNameOfFile: aFileName fixErrors: false."

	^self checkNameOfFile: aFileName fixErrors: false!
checkNameOfFile: aFile fixErrors: aBoolean 
	"See FileDirectory|checkNameOfFile: aFileName fixErrors: aBoolean. The 
	first argument is the name of the file, aFile."

	^self checkName: aFile fileName fixErrors: aBoolean!
isLegalFileName: aString 
	"Answer whether aString is a legal file name."

	^(self checkName: aString fixErrors: true) = aString! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileDirectory class
	instanceVariableNames: ''!
FileDirectory class comment:
'FileDirectories carry a path name, and are capable of a number of file creation and access functions, relating to the directory, or volume indicated by their path name.  A FileDirectory can be thought of as a Dictionary whose keys are the local names of files in that directory, and whose values are directory "entries".

A directory "entry" is an array of five items:
	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>
See the comment in lookupEntry:... which provides primitive access to this information.'!

!FileDirectory class methodsFor: 'class initialization'!
newOnPath: pathName
	^ (self activeDirectoryClass new setPathName: pathName) open!
openSources: sourcesName andChanges: changesName forImage: imageName
	"Look for the changes file on the image volume, and make the image volume the default directory.  Then look for the sources in the image volume.   Install results in SourceFiles.  2/13/96 sw."
	| sources changes |
	self setDefaultDirectoryFrom: imageName.
	sources _ (DefaultDirectory includesKey: sourcesName)
		ifTrue: [DefaultDirectory readOnlyFileNamed: sourcesName]
		ifFalse: [nil].
	changes _ (DefaultDirectory includesKey: changesName)
		ifTrue: [DefaultDirectory oldFileNamed: changesName]
		ifFalse: [nil].
	SourceFiles _ Array with: sources with: changes!
setDefaultDirectoryFrom: imageName
	self activeDirectoryClass convertName: imageName
		to: [:directory :fileName | DefaultDirectory _ directory]! !

!FileDirectory class methodsFor: 'documentation'!
documentation 
	"Subclasses are expected to implement the following messages which are
	implemented as self subclassResponsibility unless otherwise noted.

	file accessing
		fileClass
		[optional] rename:newName:
		[default] checkNameOfFile:
			(default makes no sense to me; for the abstract anything is okay)

	file status
		[optional] flush

	page accessing
		[optional] allocate:after:
		[optional] allocateSN
		[optional] deallocate:
		[optional] freePages

	dictionary adding
		addNew: 

	dictionary removing
		removeOld:

	dictionary enumerating
		[optional] next
		[default] do: 
		[optional] reset

	directory accessing
		[default] versionNumbers
"! !

!FileDirectory class methodsFor: 'name service'!
checkName: fullName fixErrors: flag
	FileDirectory convertName: fullName
		to: [:directory :fileName | ^ directory checkName: fileName fixErrors: flag]!
convertName: fileName to: volAndNameBlock
	"Convert the fileName to a directory object and a local fileName.  FileName must be of the form: <path><name> where the optional <path> specifies a known directory and <name> is the file name within that directory."
	| i delim |
	(fileName includes: (delim_ self pathNameDelimiter))
		ifFalse: [^ volAndNameBlock
					value: DefaultDirectory
						value: fileName].
	i _ fileName findLast: [:c | c = delim].
	^ volAndNameBlock
		value: (self newOnPath: (fileName copyFrom: 1 to: i - 1))
		value: (fileName copyFrom: i + 1 to: fileName size)!
default
	"Answer the default directory."

	^ DefaultDirectory!
fileNamesMatching: pat inVolume: volName folderSuffix: suffix
	"FileDirectory fileNamesMatching: '*' inVolume: '' "
	^ (MacFileDirectory directoryContentsFor: volName)
		collect: [:spec | (spec at: 4) ifTrue: [spec first , suffix]
								ifFalse: [spec first]]
		thenSelect: [:fname | pat match: fname]!
isLegalFileName: fullName
	FileDirectory convertName: fullName
		to: [:directory :fileName | ^ directory isLegalFileName: fileName]!
joinVol: volName toFileName: fileName
	volName isEmpty ifTrue: [^ fileName].
	^ volName , self pathNameDelimiter asString , fileName!
localNameFor: fullName
	^ FileDirectory splitName: fullName
		to: [:vol :local | ^ local]!
splitName: fileName to: volAndNameBlock
	"Take the file name and convert it into a volume name and a fileName.  FileName must be of the form: d:f where the optional d: specifies a known directory and f is the file name within that directory."
	| delimiter colonIndex realName dirName |
	delimiter _ self pathNameDelimiter.
	(colonIndex _ fileName findLast: [:c | c = delimiter]) = 0
		ifTrue:
			[dirName _ String new.
			realName _ fileName ]
		ifFalse:
			[dirName _ fileName copyFrom: 1 to: colonIndex - 1.
			realName _ fileName copyFrom: colonIndex + 1 to: fileName size ].

	^ volAndNameBlock value: dirName value: realName! !

!FileDirectory class methodsFor: 'primitives'!
activeDirectoryClass
	FileDirectory subclasses do:
		[:dirClass | dirClass isActive ifTrue: [^ dirClass]].
	^ self halt "No responding subclass"!
actualPathNameDelimiter
	"Return the path delimiter for the underlying file system."
 	<primitive: 161>
	self primitiveFailed.!
createDirectory: pathString
	"Create a directory named by the given path. Fail if the path is bad or if a file or directory by that name already exists."

 	<primitive: 160>
	self primitiveFailed.!
isActive
	"Return true if this Directory class is the one we're running"
	^ self pathNameDelimiter = self actualPathNameDelimiter!
lookupEntryIn: pathName index: index
	"Look up the index-th entry of the directory with the given path (starting from the root of the file hierarchy) and return an array containing:

	<name> <creationTime> <modificationTime> <dirFlag> <fileSize>

	 The creation and modification times are in seconds since the start of the Smalltalk time epoch. DirFlag is true if the entry is a directory. FileSize the file size in bytes or zero for directories. The primitive returns nil when index is past the end of the directory. It fails if the given pathName is bad."

 	<primitive: 162>
	self primitiveFailed.!
pathNameDelimiter
	^ $:! !

!FileDirectory class methodsFor: 'primitive support'!
dateAndTimeFromSeconds: secondCount

	^ Array
		with: (Time fromSeconds: secondCount \\ 86400)
		with: (Date fromDays: secondCount // 86400)!
directoryContentsFor: pathName
	"FileDirectory directoryContentsFor: ''"

	| entries index done entry |
	entries _ OrderedCollection new: 200.
	index _ 1.
	done _ false.
	[done] whileFalse: [
		entry _ self lookupEntryIn: pathName index: index.
		entry == nil
			ifTrue: [ done _ true ]
			ifFalse: [ entries addLast: entry ].
		index _ index + 1.
	].
	^ entries asArray!
scanTree: rootedPathName
	"FileDirectory scanTree: 'Reggae:Desktop Folder:New Mail'"

	| dirs files bytes todo p entries |
	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, ':', (entry at: 1)).
				dirs _ dirs + 1.
			] ifFalse: [
				files _ files + 1.
				bytes _ bytes + (entry at: 5).
			].
		].
	].
	^ Array with: dirs with: files with: bytes
! !FileModel subclass: #FileList
	instanceVariableNames: 'list listIndex directory pattern volList volListIndex sortMode '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileList comment:
'I am a FileModel that can be viewed as a ListMenu as well as the text of a file.'!

!FileList methodsFor: 'initialization'!
directory: dir
	"Set the path of the volume to be displayed."
	sortMode == nil ifTrue: [sortMode _ #name].
	self okToChange ifFalse: [^ self].
	directory _ dir.
	volList _ (Array with: 'Desk Top') , directory pathParts.
	self changed: #relabel.
	self changed: #list.
	self newListAndPattern: (pattern == nil ifTrue: ['*']
										ifFalse: [pattern]).
!
folderString
	^ ' [...]'!
fullName
	^ directory fullNameFor: fileName!
newListAndPattern: aString
	self okToChange ifFalse: [^ self].
	pattern _ aString.
	self newList! !

!FileList methodsFor: 'list access'!
fileList
	"Answer the list of files in the current volume."

	^ list!
fileListIndex
	"Answer the index of the currently selected file."

	^ listIndex!
list
	"Answer the list of volumes currently in the path."

	^ volList!
listIndex
	"Answer the index of the currently selected volume."

	^ volListIndex!
newList
	"Make the list be those file names which match the pattern."
	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.
		contents _ ''.
		self changed: #listIndex.
		self changed: #fileList]
!
toggleFileListIndex: anInteger
	"Select the file name in the receiver's list whose index is the argument, 
	anInteger. If the current selection index is already anInteger, deselect it."
	| item name |
	listIndex = anInteger
	ifTrue:
		[listIndex _ 0.
		contents _ ''.
		fileName _ nil]
	ifFalse: 
		[listIndex _ anInteger.
		item _ list at: anInteger.
		item first = $( ifTrue:  "remove size or date"
			[item _ item copyFrom: (item indexOf: $)) + 2 to: item size].
		(item endsWith: self folderString)
			ifTrue:
			["remove [...] folder string and open the folder"
			name _ item copyFrom: 1 to: item size - self folderString size.
			listIndex _ 0.
			^ self directory: (FileDirectory newOnPath:
				(directory fullNameFor: name))]
			ifFalse:
			["open the file selected"
			self setFileName: item]].
	self changed: #fileListIndex!
toggleListIndex: index
	"Select the volume name in the receiver's list whose index is the argument."
	| delim name |
	volListIndex _ index.
	delim _ directory pathNameDelimiter.
	name _ volList at: index.
	self directory: (FileDirectory newOnPath: 
			(String streamContents: 
					[:strm | 2 to: index do:
						[:i | strm nextPutAll: (volList at: i).
						i < index ifTrue: [strm nextPut: delim]]])).! !

!FileList methodsFor: 'menu messages'!
addNewFile
	"Add a new file and update the list"
	| newName index |
	self okToChange ifFalse: [^ self].
	newName _ (FillInTheBlank request: 'New File Name?' 					initialAnswer: 'FileName') asFileName.
	(directory newFileNamed: newName) close.
	self newList.
	index _ list indexOf: newName ifAbsent: [^0].
	self toggleFileListIndex: index!
browseChanges
	"FileIn all of the currently selected file if any."
	listIndex = 0 ifTrue: [^ self].
	super browseChanges!
copyName
	listIndex = 0 ifTrue: [^ self].
	ParagraphEditor new clipboardTextPut: 
		(FileDirectory default localNameFor: self fullName) asText!
deleteFile
	"Delete the currently selected file"
	listIndex = 0 ifTrue: [^ self].
	(self confirm: 'Really delete ' , fileName , '?') ifFalse: [^ self].
	directory deleteFileNamed: fileName.
	self newList!
editFile
	"Open a simple Edit window"
	listIndex = 0 ifTrue: [^ self].
	(directory oldFileNamed: fileName) edit!
fileAllIn
	"FileIn all of the currently selected file if any."
	listIndex = 0 ifTrue: [^ self].
	super fileAllIn!
renameFile
	"Rename the currently selected file"
	| newName index |
	listIndex = 0 ifTrue: [^ self].
	self okToChange ifFalse: [^ self].
	newName _ (FillInTheBlank request: 'NewFileName?' 					initialAnswer: fileName) asFileName.
	newName = fileName ifTrue: [^ self].
	directory rename: fileName toBe: newName.
	self newList.
	index _ list indexOf: newName ifAbsent: [^0].
	self toggleFileListIndex: index!
sortByDate
	"Resort the list of files"
	sortMode _ #date.
	self newListAndPattern:
		(pattern == nil ifTrue: ['*'] ifFalse: [pattern])!
sortByName
	"Resort the list of files"
	sortMode _ #name.
	self newListAndPattern:
		(pattern == nil ifTrue: ['*'] ifFalse: [pattern])!
sortBySize
	"Resort the list of files"
	sortMode _ #size.
	self newListAndPattern:
		(pattern == nil ifTrue: ['*'] ifFalse: [pattern])! !

!FileList methodsFor: 'private'!
labelString
	^ directory pathName contractTo: 50!
listForPattern: pat
	"Make the list be those file names which match the pattern."
	| newList thisName allFiles sizeStr specList maxiPad |
	specList _ directory directoryContents.
	sortMode == #size
		ifTrue: [maxiPad _ (specList inject: 0 into:
						[:mx :spec | mx max: (spec at: 5)])
							asStringWithCommas size - 1].
	newList _ sortMode == #name
		ifTrue: [(SortedCollection new: 30) sortBlock: [:x :y | x <= y]]
		ifFalse: [(SortedCollection new: 30) sortBlock: [:x :y | x >= y]].
	allFiles _ pat = '*'.
	specList do:
		[:spec | "<name><creationTime><modificationTime><dirFlag><fileSize>"
		thisName _ (spec at: 4)
			ifTrue: [spec first , self folderString]
			ifFalse: [spec first].
		(allFiles or: [pat match: thisName]) ifTrue:
			[sortMode == #date
				ifTrue: [thisName _ '(' ,
						((Date fromDays: (spec at: 3) // 86400)
							printFormat: #(3 2 1 $. 1 1 2)) , ' ' ,
						(String streamContents: [:s |
							(Time fromSeconds: (spec at: 3) \\ 86400)
								print24: true on: s])
						, ') ' , thisName].
			sortMode == #size
				ifTrue: [sizeStr _ (spec at: 5) asStringWithCommas.
						thisName _ '(' ,
							((sizeStr size to: maxiPad) collect: [:i | $ ]) ,
							sizeStr
						, ') ' , thisName].
			newList add: thisName]].
	^ newList!
put: aString 
	"Refer to the comment in FileModel|put:."

	listIndex = 0
		ifFalse: [super put: aString]!
readContentsBrief: brevity
	"Read the contents of the receiver's selected file."
	listIndex = 0
		ifTrue: [^'']
		ifFalse: [^ super readContentsBrief: brevity]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileList class
	instanceVariableNames: ''!

!FileList class methodsFor: 'instance creation'!
open  "FileList open"
	^ self openWithEditPane: true!
openWithEditPane: withEdit  "FileList open"
	"Open a view of an instance of me on the default directory.   2/14/96 sw: use standard directory.  (6/96 functionality substantially changed by di)
	 7/12/96 sw: set the label to the pathname"

	| topView aTemplateView fileListView aFileView aFileList aFileTemplateHolder dir volListView |
	topView _ StandardSystemView new.
	aFileList _ self new directory: (dir _ FileDirectory default).
	topView model: aFileList.
	topView label: dir pathName.
	topView minimumSize:
		200 @ (withEdit ifTrue: [200] ifFalse: [60]).

	volListView _ ListView new.
	volListView model: aFileList.
	volListView list: aFileList list.
	volListView window: (0 @ 0 extent: 80 @ 45).
	volListView borderWidthLeft: 2 right: 1 top: 2 bottom: 1.
	topView addSubView: volListView.

	aFileTemplateHolder _ FileTemplateHolder on: aFileList.
	aTemplateView _ StringHolderView new.
	aTemplateView controller: FileTemplateController new.
	aTemplateView model: aFileTemplateHolder.
	aTemplateView window: (0 @ 0 extent: 80 @ 15).
	aTemplateView borderWidthLeft: 2 right: 1 top: 1 bottom: 1.
	topView addSubView: aTemplateView below: volListView.

	fileListView _ FileListView new.
	fileListView model: aFileList.
	fileListView controller: FileListController new.
	fileListView list: aFileList fileList.
	fileListView window: (0 @ 0 extent: 120 @ 60).
	fileListView borderWidthLeft: 1 right: 2 top: 2 bottom: 1.
	topView addSubView: fileListView toRightOf: volListView.

	withEdit ifTrue: [
	aFileView _ FileView new.
	aFileView model: aFileList.
	aFileView window: (0 @ 0 extent: 200 @ 140).
	aFileView borderWidthLeft: 2 right: 2 top: 1 bottom: 2.
	topView addSubView: aFileView below: aTemplateView.
	].

	topView controller open!
openWithoutEditPane  "FileList openWithoutEditPane"
	^ self openWithEditPane: false! !BrowserListController subclass: #FileListController
	instanceVariableNames: ''
	classVariableNames: 'FileListYellowButtonMessages FileListYellowButtonMenu '
	poolDictionaries: ''
	category: 'Interface-FileList'!

!FileListController methodsFor: 'initialize'!
initialize
	super initialize.
	self yellowButtonMenu: FileListYellowButtonMenu
		yellowButtonMessages: FileListYellowButtonMessages
! !

!FileListController methodsFor: 'menu messages'!
addNewFile
	"FileIn all of the selected file."
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model addNewFile.
	self controlInitialize!
browseChanges
	"Browse the selected file in fileIn format."
	self controlTerminate.
	model browseChanges.
	self controlInitialize!
copyName
	model copyName.
!
deleteFile
	"FileIn all of the selected file."
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model deleteFile.
	self controlInitialize!
editFile
	"FileIn all of the selected file."
	self controlTerminate.
	model editFile.
	self controlInitialize!
fileInSelection
	"FileIn all of the selected file."
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model fileAllIn.
	self controlInitialize!
fileIntoNewChangeSet
	"File in the selected file into a new change set.  7/12/96 sw"

	model isLocked ifTrue: [^ view flash].

	self controlTerminate.
	model fileIntoNewChangeSet.
	self controlInitialize!
imporHyperSqueaktGIF
	"Import the selected file as a GIF file, into the HyperSqueak picture library.  8/17/96 sw"

	model isLocked ifTrue: [^ view flash].

	self controlTerminate.
	model imporHyperSqueaktGIF.
	self controlInitialize!
importGIF
	"Import the selected file as a GIF file, putting it into the global GIFImports dictionary at a key that is a function of the filename.  7/18/96 sw"

	model isLocked ifTrue: [^ view flash].

	self controlTerminate.
	model importGIF.
	self controlInitialize!
loadIntoHyperSqueak
	"Import the selected file as a HyperSqueak file.  8/12/96 sw"

	self controlTerminate.
	model loadIntoHyperSqueak.
	self controlInitialize!
renameFile
	"FileIn all of the selected file."
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model renameFile.
	self controlInitialize!
sortByDate
	"Resort the list of files"
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model sortByDate.
	self controlInitialize!
sortByName
	"Resort the list of files"
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model sortByName.
	self controlInitialize!
sortBySize
	"Resort the list of files"
	model isLocked ifTrue: [^view flash].
	self controlTerminate.
	model sortBySize.
	self controlInitialize! !

!FileListController methodsFor: 'private'!
changeModelSelection: anInteger
	self controlTerminate.
	model toggleFileListIndex: anInteger.
	self controlInitialize! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileListController class
	instanceVariableNames: ''!

!FileListController class methodsFor: 'class initialization'!
initialize
	"Initialize the file list menu.  6/96 di; modified 7/12/96 sw to add the file-into-new-change-set feature"

	FileListYellowButtonMenu _ PopUpMenu labels:
'fileIn
file into new change set
import GIF into GIFImports
import GIF into HyperSqueak
load HyperSqueak stack
browse changes
spawn this file
sort by name
sort by size
sort by date
copy name
rename
delete
add new file' lines: # (3 5 7 10 ).
	FileListYellowButtonMessages _ #(fileInSelection fileIntoNewChangeSet importGIF imporHyperSqueaktGIF loadIntoHyperSqueak browseChanges editFile sortByName sortBySize sortByDate copyName renameFile deleteFile addNewFile)

	"FileListController initialize"! !

FileListController initialize!
ListView subclass: #FileListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-FileList'!

!FileListView methodsFor: 'as yet unclassified'!
update: aSymbol 
	aSymbol = #relabel ifTrue: [^ self].
	aSymbol == #fileList ifTrue: 
			[self list: model fileList.
			self displayView.
			^self].
	aSymbol == #fileListIndex ifTrue: 
			[self moveSelectionBox: model fileListIndex.
			^self]! !StringHolder subclass: #FileModel
	instanceVariableNames: 'fileName fileGotten '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileModel comment:
'I represent an interface between a File and an editable view of it. As a StringHolder, the string is the contents of the File.'!

!FileModel methodsFor: 'accessing'!
browseChanges
	"Browse the selected file in fileIn format."
	ChangeList browseFile: self fullName!
contents
	"Answer the contents of the file, reading it first if needed."

	contents _ self readContentsBrief: true.
	^ super contents.!
defaultBackgroundColor
	^ #lightMagenta!
fileAllIn
	"FileIn all of the contents from the external file"
	| f |
	f _ FileStream oldFileNamed: self fullName.
	f fileIn!
fileIntoNewChangeSet
	"FileIn all of the contents from the external file, into a new change set.  7/12/96 sw"

	ChangeSorter newChangesFromFileStream: (FileStream oldFileNamed: self fullName)!
fileName
	"Answer the receiver's file name"

	^ fileName!
fullName
	^ fileName!
imporHyperSqueaktGIF
	"Import the file into a GIF file, into HyperSqueak. It had better be in the appropriate format, or you'll regret it!!  Places the resulting form into the HyperSqueak picture library, at a key which the short filename up to the first period. 8/17/96 sw
	 9/18/96 sw: handle no-gif-reader and no-HyperSqueak cases with Informers"

	| aKey anImage hsq gifReader |
	Smalltalk hyperSqueakPresent ifFalse:
		[^ self inform: 'Sorry, HyperSqueak is not present in the current system.'].
	(gifReader _ Smalltalk gifReaderClass) == nil ifTrue: [^ self inform: 'Sorry, there is no GIF reader available in the current system.'].
	aKey _ self fileName sansPeriodSuffix.
	anImage _ gifReader imageFrom: (FileStream oldFileNamed: self fullName).
	(hsq _ Smalltalk at: #SqueakSupport ifAbsent: [nil]) == nil
		ifFalse:
			[hsq importPicture: anImage withKey: aKey]!
importGIF
	"Import the file into a GIF file. It had better be in the appropriate format, or you'll regret it!!  Places the resulting form into the global dictionary GIFImports, at a key which the short filename up to the first period.  7/18/96 sw
	 9/18/96 sw: fail gracefully if GIF is missing."

	| aKey anImage gifReader |
	(gifReader _ Smalltalk gifReaderClass) == nil ifTrue: [^ self inform: 'Sorry, there is no GIF reader available in the current system.'].
	aKey _ self fileName sansPeriodSuffix.
	anImage _ gifReader imageFrom: (FileStream oldFileNamed: self fullName).
	Smalltalk gifImports at: aKey put: anImage!
loadIntoHyperSqueak
	"Load the currently-selected file in as a HyperSqueak save-file.  8/12/96 sw"

	| ff this save |
	Smalltalk hyperSqueakPresent ifFalse:
		[^ self inform: 'Sorry, HyperSqueak is not present in the current system.'].

	ff _ ReferenceStream fileNamed: self fullName.
	save _ Preferences logUserScripts.
	Preferences startLoggingUserScripts.  "for incoming buttons"
	[this _ ff next.
		this class == SmallInteger ifTrue: ["version number"].
		this class == Array ifTrue:
			[(this at: 1) = 'class structure' ifTrue:
				["Verify the shapes of all the classes"
				(DataStream incomingObjectsClass  acceptStructures: this) ifFalse:
					[^ ff close]]].	"An error occurred"
		this class name == DataStream incomingObjectsClass name ifTrue:
			["My HyperSqueak objects were installed during 'next'"].
		ff atEnd] whileFalse.		 
	ff close.
	save ifFalse: [Preferences stopLoggingUserScripts].!
put: aString 
	| f |
	(aString size >= 5 and:
		[#('File ' '16r0 ') includes: (aString copyFrom: 1 to: 5)])
		ifTrue: [(PopUpMenu confirm:
'Abbreviated and hexadecimal file views
cannot be meaningfully saved at present.
Is this REALLY what you want to do?')
				ifFalse: [^ self]].
	f _ FileStream newFileNamed: self fullName.
	Cursor write showWhile: [f nextPutAll: aString; close].!
readContentsBrief: brevityFlag
	"retrieve the contents from the external file unless it is too long"
	| f size newContents first1000 last1000 |
	f _ FileStream fileNamed: self fullName. 
	f == nil ifTrue:
		[^ 'For some reason, this file cannot be read'].
	(brevityFlag and: [(size _ f size) > 30000]) ifFalse: 
		[^ f contentsOfEntireFile].

	"Don't display long files at first.
	Composing the paragraph may take a long time."
	first1000 _ f next: 1000.
	f position: size - 1000.
	last1000 _ f next: 1000.
	f close.
	^ 'File ''' , fileName , ''' is ', size printString, ' bytes long.
You may use the ''get'' command to read the entire file.

Here are the first 1000 characters:
--------------------------------
' , first1000 , '

... and here are the last 1000 characters:
--------------------------------------
' , last1000!
readContentsHex
	"retrieve the contents from the external file unless it is too long"
	| f size data hexData s |
	f _ FileStream fileNamed: self fullName. 
	f == nil ifTrue:
		[^ 'For some reason, this file cannot be read'].
	(size _ f size) > 10000
		ifTrue: [data _ f next: 10000. f close]
		ifFalse: [data _ f contentsOfEntireFile].

	s _ WriteStream on: (String new: data size*4).
	0 to: data size-1 by: 16 do:
		[:loc | s nextPutAll: loc hex; space;
			nextPut: $(; print: loc; nextPut: $); space; tab.
		loc+1 to: (loc+16 min: data size) do: [:i | s nextPutAll: (data at: i) hex; space].
		s cr].
	hexData _ s contents.

	size > 10000
		ifTrue: [^ 'First 10k bytes:
------------------
' , hexData]
		ifFalse: [^ hexData].! !

!FileModel methodsFor: 'private'!
setFileName: fullFileName

	fileName _ fullFileName!
setFileStream: aStream

	fileName _ aStream file fullName.
	aStream close.
! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileModel class
	instanceVariableNames: ''!

!FileModel class methodsFor: 'instance creation'!
fileStream: aFileStream
	"Answer an instance of me on the argument, aFileStream."

	^self new setFileStream: aFileStream!
open: aFileModel named: aString 
	"Answer a scheduled view whose model is aFileModel and whose label is aString. "

	| topView aView |
	topView _ StandardSystemView new.
	topView model: aFileModel.
	topView label: aString.
	topView minimumSize: 180 @ 120.
	aView _ FileView new.
	aView model: aFileModel.
	aView window: (0 @ 0 extent: 180 @ 120).
	aView
		borderWidthLeft: 2
		right: 2
		top: 2
		bottom: 2.
	topView addSubView: aView.
	topView controller open! !ExternalStream subclass: #FileStream
	instanceVariableNames: 'rwmode closed '
	classVariableNames: ''
	poolDictionaries: 'FilePool '
	category: 'System-Files'!
FileStream comment:
'I represent a Stream that accesses a FilePage from a File. One use for my instance is to access larger "virtual Strings" than can be stored contiguously in main memory. I restrict the objects stored and retrieved to be Integers or Characters. An end of file pointer terminates reading; it can be extended by writing past it, or the file can be explicitly truncated.
	
To use the file system for most applications, you typically create a FileStream. This is done by sending a message to a FileDirectory (file:, oldFile:, newFile:, rename:newName:) which creates an instance of me. Accesses to the file are then done via my instance.'!

!FileStream methodsFor: 'accessing'!
contentsOfEntireFile
	"Read all of the contents of the receiver."

	| s binary |
	self readOnly.
	binary _ self isBinary.
	self reset.	"erases knowledge of whether it is binary"
	binary ifTrue: [self binary].
	s _ self next: self size.
	self close.
	^s!
dataContents
	"Read most of the contents of the receiver."
	| s |
	s _ self size < 4000
		ifTrue: [self next: self size]
		ifFalse: [self next: 4000].
	self close.
	^s!
next

	(position >= readLimit and: [self atEnd])
		ifTrue: [^nil]
		ifFalse: [^collection at: (position _ position + 1)]!
next: anInteger

	| newCollection howManyRead increment |
	newCollection _ collection species new: anInteger.
	howManyRead _ 0.
	[howManyRead < anInteger] whileTrue:
		[self atEnd ifTrue:
			[(howManyRead + 1) to: anInteger do: [:i | newCollection at: i put: (self next)].
			^newCollection].
		increment _ (readLimit - position) min: (anInteger - howManyRead).
		newCollection replaceFrom: (howManyRead + 1)
			to: (howManyRead _ howManyRead + increment)
			with: collection
			startingAt: (position + 1).
		position _ position + increment].
	^newCollection!
nextPut: aByte
	"1/31/96 sw: subclassResponsibility"

	self subclassResponsibility!
nextPutAll: aCollection
	"1/31/96 sw: made subclass responsibility"

	self subclassResponsibility!
size
	"Answer the size of the file in characters.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'testing'!
atEnd
	"Answer true if the current position is >= the end of file position.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'positioning'!
position
	"Answer the current character position in the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility!
position: pos
	"Set the current character position in the file to pos.
	 1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility!
reset
	"Set the current character position to the beginning of the file.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility!
setToEnd
	"Set the current character position to the end of the File. The same as
	self position: self size.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility!
skip: n
	"Set the character position to n characters from the current position.
	Error if not enough characters left in the file
	1/31/96 sw: made subclassResponsibility."
 
	self subclassResponsibility! !

!FileStream methodsFor: 'printing'!
printOn: aStream

	super printOn: aStream.
	aStream nextPutAll: ' on '.
	self file printOn: aStream! !

!FileStream methodsFor: 'nonhomogeneous positioning'!
padTo: bsize put: aCharacter 
	"Refer to the comment in ExternalStream|padTo:put:."
	| rem |
	rem _ bsize - (self position \\ bsize).
	rem = bsize ifTrue: [^ 0].
	self next: rem put: aCharacter.
	^rem! !

!FileStream methodsFor: 'editing'!
edit
	"Create and schedule a FileView of the contents of the receiver. The 
	label of the view is the name of the receiver."

	FileModel 
		open: (FileModel fileStream: self)
		named: self file fullName! !

!FileStream methodsFor: 'file accessing'!
file
	"Answer the file for the page the receiver is streaming over.
	 1/31/96 sw: made subclass responsibility"

	self subclassResponsibility!
localName
	^ self class localNameFor: self name!
name
	"Answer the name of the file for the page the receiver is streaming over.  1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'file testing'!
closed
	"Answer the status of the file--false if open, true otherwise."

	^closed!
writing
	"Answer whether it is possible to write on the receiver."

	rwmode == nil
		ifTrue: 
			[self readWriteShorten.	"default mode"
			^true].
	^(rwmode bitAnd: Write) = Write! !

!FileStream methodsFor: 'file modes'!
binary
	"Set the receiver's file to be binary mode.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility!
readOnly
	"Set the receiver's mode so that pages are not flushed and reading stops at 
	end of file."

	self setMode: Read!
readWrite
	"Set the receiver's mode so that pages are flushed, end of file can be 
	extended by writing, and closing does not truncate file."

	self setMode: Read + Write!
readWriteShorten
	"Same as readWrite except close truncates file at current position."

	self setMode: Read + Write + Shorten!
text
	"Set the receiver's file to be in text mode.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility!
writeShorten
	"Allow write and shorten the receiver's file upon closing."

	self setMode: Write + Shorten! !

!FileStream methodsFor: 'file status'!
close
	"Set the receiver's file status to closed."

	closed
		ifFalse: 
			[self writing 
				ifTrue: [(rwmode bitAnd: Shorten) = Shorten
							ifTrue: [self shorten]
							ifFalse: [self flush]].
			closed _ true.
			readLimit _ writeLimit _ 0.
			self file close.
			FileDirectory removeExternalReference: self]!
flush
	"Write the current buffer back onto the file
	1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility!
release
	"Set the receiver's status to closed, if it is not already, and do not allow
	any further reading or writing."

	closed
		ifFalse: 
			[closed _ true.
			readLimit _ writeLimit _ 0.
			self file release]!
reopen
	"Set the receiver's file to be open again, setting the position to its 
	previous position. Create an error if the file cannot be reopened.
	 1/31/96 sw: subclassResponsibility"

	self subclassResponsibility! !

!FileStream methodsFor: 'fileIn/Out'!
fileIn
	"Guarantee that the receiver is readOnly before fileIn for efficiency and
	to eliminate remote sharing conflicts."

	self readOnly.
	^super fileIn! !

!FileStream methodsFor: 'private'!
setMode: m

	rwmode = m 
		"don't flush if first time or not write mode or continuing write mode"
		ifFalse: [(rwmode == nil or: [(rwmode bitAnd: Write) = 0 
					or: [(m bitAnd: Write) = Write]])
					ifTrue: [rwmode _ m]
					ifFalse: 
						[self flush.
						rwmode _ m]]!
shorten
	"Normally called by close and not directly by the user.
	1/31/96 sw: made subclassResponsibility"

	self subclassResponsibility! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileStream class
	instanceVariableNames: ''!

!FileStream class methodsFor: 'instance creation'!
fileNamed: fileName 
	^ StandardFileStream fileNamed: (self fullName: fileName)!
fullName: fileName
	^ FileDirectory default fullNameFor: fileName!
localNameFor: fullName
	^ self directoryClass localNameFor: fullName!
newFileNamed: fileName 
	^ StandardFileStream newFileNamed: (self fullName: fileName)!
oldFileNamed: fileName 
	^ StandardFileStream oldFileNamed: (self fullName: fileName)!
readOnlyFileNamed: fileName 
	^ StandardFileStream readOnlyFileNamed: (self fullName: fileName)! !

!FileStream class methodsFor: 'concrete classes'!
directoryClass
	"To be overridden by different file systems"
	^ FileDirectory! !StringHolderController subclass: #FileTemplateController
	instanceVariableNames: ''
	classVariableNames: 'TemplateMenu TemplateMessages '
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileTemplateController comment:
'I am the controller of the upper part of a three-part file directory window. My contents may be edited. When accepted, my contents becomes the template for the list of files in the other parts. The template consists of repetitions of file name/pattern followed by a carriage return character. A file pattern is a sequence of characters including at least one asterisk, $*. A file name is a sequence of characters without any asterisks.'!

!FileTemplateController methodsFor: 'menu messages'!
accept
	model okToChange ifFalse: [^ self].
	self controlTerminate.
	super accept.
	model newListAndPattern: paragraph text string.
	self controlInitialize! !

!FileTemplateController methodsFor: 'editing'!
dispatchOnCharacter: char with: typeAheadStream
	"Check for CR and cause an ACCEPT"

	char = Character cr
		ifTrue: [sensor keyboard. 	"gobble cr"
				self replaceSelectionWith:
					(Text string: typeAheadStream contents
						emphasis: emphasisHere).
				self accept.
				^ true]
		ifFalse: [^ super dispatchOnCharacter: char with: typeAheadStream]! !StringHolder subclass: #FileTemplateHolder
	instanceVariableNames: 'fileList '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileTemplateHolder comment:
'I am a StringHolder that also refers to an instance of FileList. Typically, my contents is the template being edited in an upper pane of a file list window; the instance of FileList is the one whose list appears in the middle pane.'!

!FileTemplateHolder methodsFor: 'accessing'!
defaultContents

	^'*'!
newListAndPattern: pattern
	fileList newListAndPattern: pattern! !

!FileTemplateHolder methodsFor: 'lock access'!
isLocked 
	"Refer to the comment in StringHolder|isLocked."

	^fileList isLocked! !

!FileTemplateHolder methodsFor: 'private'!
fileList: aFileList

	fileList _ aFileList! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FileTemplateHolder class
	instanceVariableNames: ''!

!FileTemplateHolder class methodsFor: 'instance creation'!
on: aFileList 
	"Create an instance of me on the argument, aFileList."

	^self new fileList: aFileList! !StringHolderView subclass: #FileView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-FileList'!
FileView comment:
'I am a StringHolderView of the text contained in a File. FileController is my default controller.'!

!FileView methodsFor: 'controller access'!
defaultControllerClass

	^FileController! !

!FileView methodsFor: 'updating'!
update: aSymbol
	aSymbol = #relabel
		ifTrue: [^ self topView relabel: model labelString].
	^ super update: aSymbol! !StringHolder subclass: #FillInTheBlank
	instanceVariableNames: 'actionBlock actionTaken '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
FillInTheBlank comment:
'I represent a request for information that will be applied as the argument of a block of actions.'!

!FillInTheBlank methodsFor: 'initialize-release'!
defaultBackgroundColor
	^ #lightBrown!
initialize 
	"Refer to the comment in StringHolder|initialize."

	super initialize.
	actionTaken _ false! !

!FillInTheBlank methodsFor: 'accessing'!
action: aBlock
	"The argument, aBlock, will be evaluated when the receiver is sent the 
	message selectAction."

	actionBlock _ aBlock!
actionTaken 
	"Answer whether the receiver has taken its appropriate action(s) yet."

	^actionTaken !
setAction: aBoolean 
	"Set the receiver's flag denoting whether its action(s) were taken to be 
	the argument, aBoolean."

	actionTaken _ aBoolean! !

!FillInTheBlank methodsFor: 'menu messages'!
selectAction
	"Evaluate the receiver's assigned action block, if any, with the answer as 
	the block argument."

	actionBlock notNil ifTrue: [actionBlock value: contents]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FillInTheBlank class
	instanceVariableNames: ''!

!FillInTheBlank class methodsFor: 'instance creation'!
action: aBlock initialAnswer: aString 
	"Answer an instance of me whose action is aBlock and initial action 
	argument is aString."

	| newBlank |
	newBlank _ self new initialize.
	newBlank action: aBlock.
	newBlank contents: aString.
	^newBlank!
message: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString 
	"Answer an instance of me whose question is messageString. Once the 
	user provides an answer, then evaluate aBlock. If centered, a Boolean, is 
	false, display the view of the instance at aPoint; otherwise display it 
	with its center at aPoint."

	| newBlank |
	newBlank _ self new initialize.
	newBlank action: aBlock.
	newBlank contents: aString.
	FillInTheBlankView
		openOn: newBlank
		message: messageString
		displayAt: aPoint
		centered: centered!
request: messageString
	"Create an instance of me whose question is messageString. Display it 
	centered around the cursor. Answer whatever the user accepts."

	^self request: messageString initialAnswer: ''!
request: messageString displayAt: aPoint centered: centered action: aBlock initialAnswer: aString 
	"Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, aBoolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint. "

	| newBlank fillInView savedArea |
	newBlank _ self new initialize.
	newBlank action: aBlock.
	newBlank contents: aString.
	fillInView _ FillInTheBlankView
				on: newBlank
				message: messageString
				displayAt: aPoint
				centered: centered.
	savedArea _ Form fromDisplay: fillInView displayBox.
	fillInView display.
	aString isEmpty
		ifFalse: [fillInView lastSubView controller selectFrom: 1 to: aString size].
	(fillInView lastSubView containsPoint: Sensor cursorPoint)
		ifFalse: [fillInView lastSubView controller centerCursorInView].
	fillInView controller startUp.
	fillInView release.
	savedArea displayOn: Display at: fillInView viewport topLeft!
request: messageString initialAnswer: aString 
	"Create an instance of me whose question is messageString. Display it 
	centered around the cursor. Supply aString as an initial answer. Answer 
	whatever the user accepts."

	self
		request: messageString
		displayAt: Sensor cursorPoint
		centered: true
		action: [:response | response]
		initialAnswer: aString.
	^response!
request: messageString  initialAnswer: aString  avoiding: aRect
	"Answer an instance of me whose question is messageString. Once the user provides an answer, then evaluate aBlock. If centered, aBoolean, is false, display the view of the instance at aPoint; otherwise display it with its center at aPoint.   
	2/5/96 sw: This variant tries to avoid obscuring aRect
	2/6/96 sw: fixed to return the user's response"

	self request: messageString displayAt: aRect bottomLeft centered: false action: [:response | response] initialAnswer: ''.
	^ response! !

!FillInTheBlank class methodsFor: 'examples'!
example1

	FillInTheBlank
		message: 'What is your name?' 
		displayAt: Sensor waitButton 
		centered: true
		action: [:answer | Transcript cr; show: answer] 
		initialAnswer: ''

	"FillInTheBlank example1"!
example2

	FillInTheBlank
		request: 'What is your name?' 
		displayAt: Sensor waitButton 
		centered: true
		action: [:answer | Transcript cr; show: answer] 
		initialAnswer: 'Your Name'

	"FillInTheBlank example2"!
example3

	^Text fromUser

	"FillInTheBlank example3"! !StringHolderController subclass: #FillInTheBlankController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
FillInTheBlankController comment:
'I am a StringHolderController for a FillInTheBlankView. The string is information that the user can type in and edit. Upon issuing the accept command, this information is used by my model in the evaluation of an action block.'!

!FillInTheBlankController methodsFor: 'basic control sequence'!
controlTerminate

	| topController |
	super controlTerminate.
	model actionTaken ifFalse: [^self].
	topController _ view topView controller.
	topController notNil ifTrue: [topController close].
	model selectAction! !

!FillInTheBlankController methodsFor: 'control defaults'!
isControlActive

	model actionTaken ifTrue: [^false].
	^ true!
isControlWanted

	^ model actionTaken not! !

!FillInTheBlankController methodsFor: 'menu messages'!
accept

	super accept.
	model setAction: true! !StringHolderView subclass: #FillInTheBlankView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
FillInTheBlankView comment:
'I am a view of a FillInTheBlank. I display a query and an area in which the user can type some information. My instances'' default controller is FillinTheBlankController.'!

!FillInTheBlankView methodsFor: 'controller access'!
defaultControllerClass

	^FillInTheBlankController! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FillInTheBlankView class
	instanceVariableNames: ''!

!FillInTheBlankView class methodsFor: 'instance creation'!
on: aFillInTheBlank message: messageString displayAt: originPoint centered: centered 
	"Answer an instance of me on the model aFillInTheBlank asking the 
	question messageString. If the argument centered, a Boolean, is false, 
	display the instance with top left corner at originPoint; otherwise, 
	display it with its center at originPoint."

	| topView messageView answerView |
	messageView _ self buildMessageView: messageString.
	answerView _ 
		self buildAnswerView: aFillInTheBlank 
			frameWidth: messageView window width.
	answerView controller: CRFillInTheBlankController new.
	topView _ View new model: aFillInTheBlank.
	topView controller: ModalController new.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView.
	topView align: (centered
			ifTrue: [topView viewport center]
			ifFalse: [topView viewport topLeft])
		with: originPoint.
	topView window: 
		(0 @ 0 extent: 
			messageView window width @ 
			(messageView window height + answerView window height)).
	topView translateBy:
		(topView displayBox amountToTranslateWithin: Display boundingBox).
	^topView!
openOn: aFillInTheBlank message: messageString displayAt: originPoint centered: centered
	"Create and schedule an instance of me that displays aFillInTheBlank 
	asking the question messageString. If the argument centered, a Boolean, 
	is false, display the instance with top left corner at originPoint; 
	otherwise, display it with its center at originPoint. Do not schedule, 
	rather take control immediately and insist that the user respond."

	| topView messageView answerView |
	messageView _ self buildMessageView: messageString.
	answerView _ 
		self buildAnswerView: aFillInTheBlank 
			frameWidth: messageView window width.
	topView _ StandardSystemView new model: aFillInTheBlank.
	topView addSubView: messageView.
	topView addSubView: answerView below: messageView. 
	topView
		align: (centered
				ifTrue: [topView viewport center]
				ifFalse: [topView viewport topLeft])
		with: originPoint.
	topView label: 'Type a response'.
	topView window: 
		(0@0 extent: messageView window width @ (messageView window height + 40)).
	topView controller openDisplayAt: originPoint! !

!FillInTheBlankView class methodsFor: 'private'!
buildAnswerView: aFillInTheBlank frameWidth: widthInteger

	| answerView |
	answerView _ self new model: aFillInTheBlank.
	answerView window: (0@0 extent: widthInteger @ 40).
	answerView borderWidth: 2.
	^answerView!
buildMessageView: messageString
	|  messageView  |
	messageView _ DisplayTextView new model: messageString asDisplayText.
	messageView borderWidthLeft: 2 right: 2 top: 2 bottom: 0.
	messageView controller: NoController new.
	messageView window: (0@0 extent: (messageView window extent max: 200@30)).
	messageView centered.
	^messageView! !Number variableWordSubclass: #Float
	instanceVariableNames: ''
	classVariableNames: 'Fourthpi ExpPCoefficients TanCoefficients RadiansPerDegree SinCoefficients Sqrt2 LnCoefficients ExpQCoefficients Pi Ln2 Twopi Halfpi '
	poolDictionaries: ''
	category: 'Numeric-Numbers'!
Float comment:
'My instances represent about 8 or 9 digits of accuracy; their range is between plus and minus 10^32. 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.'!

!Float methodsFor: 'arithmetic'!
* aNumber 
	"Primitive. Answer the result of multiplying the receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 49>
	^self retry: #* coercing: aNumber!
+ 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>
	^self retry: #+ coercing: aNumber!
- 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>
	^self retry: #- coercing: aNumber!
/ aNumber 
	"Primitive. Answer the result of dividing receiver by aNumber.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 50>
	aNumber = 0
		ifTrue: [self error: 'attempt to divide by zero']
		ifFalse: [^self retry: #/ coercing: aNumber]!
abs
	self < 0.0
		ifTrue: [^ self negated]
		ifFalse: [^ self]!
negated
	"Answer a Number that is the negation of the receiver."

	^0.0 - self! !

!Float methodsFor: 'mathematical functions'!
arcCos
	"Answer the angle in radians."

	^Halfpi - self arcSin!
arcSin
	"Answer the angle in radians."

	self abs > 1.0 ifTrue: [self error: 'Value out of range'].
	self abs = 1.0
		ifTrue: [^Halfpi]
		ifFalse: [^(self / (1 - (self * self)) sqrt) arcTan]!
arcTan
	"Answer the angle in radians."

	| theta term y eps i |
	self = 1.0 ifTrue: [^Fourthpi].
	self = -1.0 ifTrue: [^Fourthpi negated].
	self * self > 1.0
		ifTrue: 
			[theta _ Halfpi.
			y _ -1.0 / (self * self).
			term _ -1.0 / self abs]
		ifFalse: 
			[theta _ 0.0.
			y _ 0.0 - (self * self).
			term _ self abs].
	i _ 1.
	eps _ 1.0e-4.
	[term abs > eps]
		whileTrue: 
			[theta _ theta + term.
			term _ term * y * i asFloat / (i + 2) asFloat.
			i _ i + 2].
	^self sign asFloat * theta!
cos
	"Answer the cosine of the receiver in radians."

	self < 0.0 ifTrue: [^(self + Halfpi) sin].
	^(Halfpi - self) sin!
degreeCos
	"Answer the sine of the receiver in degrees."
	^ self degreesToRadians cos!
degreeSin
	"Answer the sine of the receiver in degrees."
	^ self degreesToRadians sin!
exp
	"See Computer Approximations, pp. 96-104, p. 205 (EXPB 1065)."

	| a n1 x x2 P Q |
	self abs > 9212.0
		ifTrue: ["Float maxVal ln"
			"1.0 exp"
			self error: 'exp overflow']
		ifFalse: 
			[x _ self / Ln2.
			n1 _ 2.0 raisedTo: x asInteger.
			(x _ x - x asInteger) >= 0.5
				ifTrue: 
					[n1 _ n1 * Sqrt2.
					x _ x - 0.5].
			x2 _ x * x.
			"compute 2.0 power: x"
			P _ Q _ 0.0.
			ExpPCoefficients do: [:a | P _ P * x2 + a].
			ExpQCoefficients do: [:a | Q _ Q * x2 + a].
			^n1 * (Q + (x * P) / (Q - (x * P)))]!
floorLog: radix 
	"Quick computation of (self log: radix) floor."

	| x |
	self < radix ifTrue: [^0]. 	"self assumed positive"
	self < radix squared ifTrue: [^1].
	x _ 2 * (self floorLog: radix squared).	"binary recursion like ipow"
	^x + (self / (radix raisedTo: x) floorLog: radix)!
ln
	"See Computer Approximations, pp. 105-111, p. 227 (LOGE 2663)."

	| expt x x2 n P |
	self <= 0.0
		ifTrue: [self error: 'ln not valid for ' , self printString]
		ifFalse: 
			[expt _ self exponent.
			n _ Ln2 * (expt - 0.5).
			"mantissa between 0.5 and 1.0"
			x _ self timesTwoPower: 0 - expt.
			x _ x * Sqrt2.
			x _ x - 1.0 / (x + 1.0).
			x2 _ x * x.
			P _ 0.0.
			LnCoefficients do: [:a | P _ P * x2 + a].
			^n + (x * P)]

	"2.718284 ln 1.0"!
log
	"Answer the base 10 logarithm."

	^self ln / 10.0 ln!
sin
	"Answer the sine of the receiver in radians."

	| x x2 sum |
		"normalize to 0<=self<=(Pi/2)"
	self < 0.0 ifTrue: [^self negated sin negated].
	self > Twopi ifTrue: [^(self \\ Twopi) sin].
	self > Pi ifTrue: [^(self - Pi) sin negated].
	self > Halfpi ifTrue: [^(Pi - self) sin].
	sum _ x _ self.
	x2 _ x * x.
	SinCoefficients do: [:const | sum _ const * (x _ x * x2) + sum].
	^sum!
sqrt
	"Answer the square root of the receiver."

	| guess |
	self <= 0.0 ifTrue: [self = 0.0
			ifTrue: [^0.0]
			ifFalse: [^self error: 'sqrt invalid for x < 0']].
	"copy and halve the exponent for first guess"
	guess _ self timesTwoPower: 0 - (self exponent // 2).
	5 timesRepeat: [guess _ self - (guess * guess) / (guess * 2.0) + guess].
	^guess!
tan
	"Answer the ratio of the sine to cosine of the receiver in radians."

	| x x2 sum |
		"normalize to 0<=self<=(Pi/4)"
	self < 0.0 ifTrue: [^self negated tan negated].
	self > Pi ifTrue: [^(self \\ Pi) tan].
	self > Halfpi ifTrue: [^(Pi - self) tan negated].
	self > Fourthpi ifTrue: [^1.0 / (Halfpi - self) tan].
	sum _ x _ self.
	x2 _ x * x.
	TanCoefficients do: [:const | sum _ const * (x _ x * x2) + sum].
	^sum! !

!Float methodsFor: 'comparing'!
< aNumber 
	"Primitive. Compare the receiver with the argument and return true
	if the receiver is less than the argument. Otherwise return false.
	Fail if the argument is not a Float. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 43>
	^self retry: #< coercing: aNumber!
<= 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>
	^self retry: #<= coercing: aNumber!
= 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].
	^ self retry: #= coercing: aNumber!
> 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>
	^self retry: #> coercing: aNumber!
>= 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>
	^self retry: #>= coercing: aNumber!
hash
	"Hash is reimplemented because = is implemented."

	^(self basicAt: 1) bitAnd: 16383		"High bits as an Integer"!
~= 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! !

!Float methodsFor: 'truncation and round off'!
fractionPart
	"Primitive. Answer a Float whose value is the difference between the 
	receiver and the receiver's asInteger value. Optional. See Object 
	documentation whatIsAPrimitive."

	<primitive: 52>
	^self - self asInteger!
integerPart
	"Answer a Float whose value is the receiver's truncated value."

	^self - self fractionPart!
rounded
	"Answer the integer nearest the receiver."

	self >= 0.0
		ifTrue: [^(self + 0.5) truncated]
		ifFalse: [^(self - 0.5) truncated]!
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 primitiveFailed! !

!Float methodsFor: 'coercing'!
coerce: aNumber 
	"Refer to the comment in Number|coerce:."

	^aNumber asFloat!
generality 
	"Refer to the comment in Number|generality."

	^80! !

!Float methodsFor: 'converting'!
asFloat
	"Answer the receiver itself."

	^self!
asFraction
	"Answer a Fraction representing the receiver. This conversion uses the 
	continued fraction method to approximate a floating point number."

	| num1 denom1 num2 denom2 int frac newD temp |
	num1 _ self asInteger.	"The first of two alternating numerators"
	denom1 _ 1.		"The first of two alternating denominators"
	num2 _ 1.		"The second numerator"
	denom2 _ 0.		"The second denominator--will update"
	int _ num1.		"The integer part of self"
	frac _ self fractionPart.		"The fractional part of self"
	[frac = 0]
		whileFalse: 
			["repeat while the fractional part is not zero"
			newD _ 1.0 / frac.			"Take reciprocal of the fractional part"
			int _ newD asInteger.		"get the integer part of this"
			frac _ newD fractionPart.	"and save the fractional part for next time"
			temp _ num2.				"Get old numerator and save it"
			num2 _ num1.				"Set second numerator to first"
			num1 _ num1 * int + temp.	"Update first numerator"
			temp _ denom2.				"Get old denominator and save it"
			denom2 _ denom1.			"Set second denominator to first"
			denom1 _ int * denom1 + temp.		"Update first denominator"
			10000.0 < denom1
				ifTrue: 
					["Is ratio past float precision?  If so, pick which 
					of the two ratios to use"
					num2 = 0.0 
						ifTrue: ["Is second denominator 0?"
								^Fraction numerator: num1 denominator: denom1].
					^Fraction numerator: num2 denominator: denom2]].
	"If fractional part is zero, return the first ratio"
	denom1 = 1
		ifTrue: ["Am i really an Integer?"
				^num1"Yes, return Integer result"]
		ifFalse: ["Otherwise return Fraction result"
				^Fraction numerator: num1 denominator: denom1]!
degreesToRadians
	"Answer the receiver in radians. Assumes the receiver is in degrees."

	^self * RadiansPerDegree!
radiansToDegrees
	"Answer the receiver in degrees. Assumes the receiver is in radians."

	^self / RadiansPerDegree! !

!Float methodsFor: 'copying'!
deepCopy

	^self copy!
shallowCopy

	^self + 0.0! !

!Float methodsFor: 'printing'!
hex
	| word nibble |
	^ String streamContents:
		[:strm |
		1 to: 5 do:
			[:i | word _ self at: i.
			1 to: 4 do: 
				[:s | nibble _ (word bitShift: -4+s*4) bitAnd: 16rF.
				strm nextPut: ('0123456789ABCDEF' at: nibble+1)]]]
"
(-2.0 to: 2.0) collect: [:f | f hex]
"!
isLiteral

	^true!
printOn: aStream base: base
	"Estimate significant figures and handle sign." 
	| digitCount |
	digitCount _ 2r1.0e23 "23 bits" floorLog: base asFloat.
	self > 0.0
		ifTrue: [self absPrintOn: aStream base: base digitCount: digitCount]
		ifFalse: [self = 0.0 ifTrue: [^ aStream nextPutAll: '0.0'].
				aStream nextPutAll: '-'.
				self negated absPrintOn: aStream base: base digitCount: digitCount]! !

!Float methodsFor: 'private'!
absPrintOn: aStream base: base digitCount: digitCount 
	"Print me in the given base, using digitCount significant figures."
	| fuzz x exp q i fBase |
	fBase _ base asFloat.
	"x is myself normalized to [1.0, fBase), exp is my exponent"
	exp _ 
		self < 1.0
			ifTrue: [(fBase / self floorLog: fBase) negated]
			ifFalse: [self floorLog: fBase].
	x _ self / (fBase raisedTo: exp).
	fuzz _ fBase raisedTo: 1 - digitCount.
	"round the last digit to be printed"
	x _ 0.5 * fuzz + x.
	x >= fBase
		ifTrue: 
			["check if rounding has unnormalized x"
			x _ x / fBase.
			exp _ exp + 1].
	(exp < 6 and: [exp > -4])
		ifTrue: 
			["decimal notation"
			q _ 0.
			exp < 0 ifTrue: [1 to: 1 - exp do: [:i | aStream nextPut: ('0.0000' at: i)]]]
		ifFalse: 
			["scientific notation"
			q _ exp.
			exp _ 0].
	[x >= fuzz]
		whileTrue: 
			["use fuzz to track significance"
			i _ x asInteger.
			aStream nextPut: (Character digitValue: i).
			x _ x - i * 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]!
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!
timesTwoPower: anInteger 
	"Primitive. Answer with the receiver mulitplied by 2.0 raised to the
	power of the argument. Optional. See Object documentation
	whatIsAPrimitive."

	<primitive: 54>
	^self * (2.0 raisedToInteger: anInteger)! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Float class
	instanceVariableNames: ''!

!Float class methodsFor: 'class initialization'!
initialize		"Float initialize. Float pi"
	"Constants from Computer Approximations, pp. 182-183:
		Pi = 3.14159265358979323846264338327950288 
		Pi/2 = 1.57079632679489661923132169163975144 
		Pi/4 = 0.78539816339744830961566084581987572 
		Pi*2 = 6.28318530717958647692528676655900576 
		Pi/180 = 0.01745329251994329576923690768488612 
		2.0 ln = 0.69314718055994530941723212145817657 
		2.0 sqrt = 1.41421356237309504880168872420969808"

	Pi _ 3.14159265.
	Halfpi _ Pi / 2.0.
	Fourthpi _ Pi / 4.0.
	Twopi _ Pi * 2.0.
	RadiansPerDegree _ Pi / 180.0.
	Ln2 _ 0.69314718.
	Sqrt2 _ 1.41421356.
	SinCoefficients _ #(-0.166667 0.00833333 -1.98409e-4 2.7526e-6 -2.39e-8 ).
	TanCoefficients _ #(0.333331 0.133392 0.0533741 0.0245651 0.00290052 0.00951681 ).
	ExpPCoefficients _ #(28.8756 2525.04 ).
	ExpQCoefficients _ #(1.0 375.022 7285.73 ).
	LnCoefficients _ #(0.237625 0.285254 0.400006 0.666667 2.0 )! !

!Float class methodsFor: 'instance creation'!
readFrom: aStream 
	"Answer a new Float as described on the stream, aStream."

	^(super readFrom: aStream) asFloat! !

!Float class methodsFor: 'constants'!
pi
	"Answer the constant, Pi."

	^Pi! !

Float initialize!
WaveTableSound subclass: #FMSound
	instanceVariableNames: 'initialModulation modulation modulationDecay offsetIncrement offsetIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Sound'!

!FMSound methodsFor: 'initialization'!
setPitch: p dur: d loudness: l

	super setPitch: p dur: d loudness: l.
	self modulation: 900 multiplier: 0.76.
	self modulationDecay: 0.92.
	self decayRate: 0.85.

! !

!FMSound methodsFor: 'accessing'!
modulation: mod multiplier: mult

	| modInRange multInRange |
	modInRange _ mod rounded min: 1023 max: 0.
	multInRange _ mult asFloat max: 0.0.
	initialModulation _ (modInRange * increment) bitShift: -7.
	modulation _ initialModulation.
	offsetIncrement _ (increment * multInRange) rounded.
	offsetIndex _ 1.
!
modulationDecay: modDecay

	modulationDecay _ modDecay asFloat min: 1.0 max: 0.0.
! !

!FMSound methodsFor: 'sound generation'!
doControl

	super doControl.
	modulationDecay ~= 1.0 ifTrue: [
		modulation _ (modulationDecay * modulation asFloat) asInteger.
	].
!
mixSampleCount: n into: aSoundBuffer startingAt: startIndex pan: pan
	"A simple implementation of Chowning's frequency-modulation synthesis technique. The center frequency is varied as the sound plays by changing the increment by which to step through the wave table."
	"FMSound majorScale play"
	"(FMSound pitch: 440.0 dur: 1.0 loudness: 200) play"

	| lastIndex i mySample sample channelIndex |
	<primitive: 177>
	self var: #aSoundBuffer declareC: 'short int *aSoundBuffer'.
	self var: #waveTable declareC: 'short int *waveTable'.

	lastIndex _ (startIndex + n) - 1.
	startIndex to: lastIndex do: [ :i |
		mySample _ (amplitude * (waveTable at: index)) // 1000.
		pan > 0 ifTrue: [
			channelIndex _ 2 * i.
			sample _ (aSoundBuffer at: channelIndex) + ((mySample * pan) // 1000).
			sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"
			sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"
			aSoundBuffer at: channelIndex put: sample.
		].
		pan < 1000 ifTrue: [
			channelIndex _ (2 * i) - 1.
			sample _ (aSoundBuffer at: channelIndex) + ((mySample * (1000 - pan)) // 1000).
			sample >  32767 ifTrue: [ sample _  32767 ].  "clipping!!"
			sample < -32767 ifTrue: [ sample _ -32767 ].  "clipping!!"
			aSoundBuffer at: channelIndex put: sample.
		].

		index _ index + increment + ((modulation * (waveTable at: offsetIndex)) // 1000000).
		index > waveTableSize ifTrue: [
			index _ index - waveTableSize.
		].
		index < 1 ifTrue: [
			index _ index + waveTableSize.
		].
		offsetIndex _ offsetIndex + offsetIncrement.
		offsetIndex > waveTableSize ifTrue: [
			offsetIndex _ offsetIndex - waveTableSize.
		].
	].
	count _ count - n.
!
reset

	super reset.
	modulation _ initialModulation.
! !DisplayMedium subclass: #Form
	instanceVariableNames: 'bits width height depth offset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
Form comment:
'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'!
fromDisplay: aRectangle 
	"Create a virtual bit map from a user specified rectangular area on the 
	display screen. Reallocates bitmap only if aRectangle ~= the receiver's 
	extent."

	(width = aRectangle width and: [height = aRectangle height])
		ifFalse: [self setExtent: aRectangle extent depth: depth].
	self
		copyBits: (aRectangle origin extent: self extent)
		from: Display
		at: 0 @ 0
		clippingBox: self boundingBox
		rule: Form over
		fillColor: nil! !

!Form methodsFor: 'accessing'!
extent
	^ width @ height!
form
	"Answer the receiver's form.  For vanilla Forms, this degenerates to self.  Makes several methods that operate on both Forms and MaskedForms much more straightforward.   6/1/96 sw"

	^ self!
height
	^ height!
offset

	offset == nil
		ifTrue: [^0 @ 0]
		ifFalse: [^offset]!
offset: aPoint

	offset _ aPoint!
size
	"Answer the number of bits in the receiver's bitmap."
self halt.  "Should no longer be used -- use bitsSize instead"
	^ self bitsSize!
width
	^ width! !

!Form methodsFor: 'copying'!
copy: aRect
 	"Return a new form which derives from the portion of the original form delineated by aRect."
	| newForm |
	newForm _ Form extent: aRect extent depth: depth.
	^ newForm copyBits: aRect from: self at: 0@0
		clippingBox: newForm boundingBox rule: Form over fillColor: nil!
deepCopy
	| newForm |
	newForm _ self shallowCopy.
	newForm bits: (bits class new: self bitsSize).
	newForm copyBits: self boundingBox
		from: self
		at: 0 @ 0
		clippingBox: newForm boundingBox
		rule: Form over
		fillColor: nil.
	^newForm! !

!Form methodsFor: 'displaying'!
copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm 
	"Make up a BitBlt table and copy the bits."

	(BitBlt 
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: rule
		destOrigin: destOrigin
		sourceOrigin: sourceRect origin
		extent: sourceRect extent
		clipRect: clipRect) copyBits!
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!
displayOffset

"Answer the offset from the bottom center to the origin (top left corner)."

^0@0 - ((width // 2) @ height)!
displayOn: aDisplayMedium at: aDisplayPoint clippingBox: clipRectangle rule: ruleInteger fillColor: aForm

	aDisplayMedium copyBits: self boundingBox
		from: self
		at: aDisplayPoint + self offset
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm!
displayOn: aDisplayMedium transformation: displayTransformation clippingBox: clipRectangle align: alignmentPoint with: relativePoint rule: ruleInteger fillColor: aForm 
	"Graphically, it means nothing to scale a Form by floating point values.  
	Because scales and other display parameters are kept in floating point to 
	minimize round off errors, we are forced in this routine to round off to the 
	nearest integer."

	| absolutePoint scale magnifiedForm |
	absolutePoint _ displayTransformation applyTo: relativePoint.
	absolutePoint _ absolutePoint x asInteger @ absolutePoint y asInteger.
	displayTransformation noScale
		ifTrue: [magnifiedForm _ self]
		ifFalse: 
			[scale _ displayTransformation scale.
			scale _ scale x rounded @ scale y rounded.
			(1@1 = scale)
					ifTrue: [scale _ nil. magnifiedForm _ self]
					ifFalse: [magnifiedForm _ self magnify: self boundingBox by: scale]].
	magnifiedForm
		displayOn: aDisplayMedium
		at: absolutePoint - alignmentPoint
		clippingBox: clipRectangle
		rule: ruleInteger
		fillColor: aForm!
displayOnPort: port at: location
	port copyForm: self to: location rule: Form over!
drawLine: sourceForm from: beginPoint to: endPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Refer to the comment in 
	DisplayMedium|drawLine:from:to:clippingBox:rule:mask:." 
	
	| dotSetter |
	"set up an instance of BitBlt for display"
	dotSetter _ BitBlt
		destForm: self
		sourceForm: sourceForm
		fillColor: aForm
		combinationRule: anInteger
		destOrigin: beginPoint
		sourceOrigin: 0 @ 0
		extent: sourceForm extent
		clipRect: clipRect.
	dotSetter drawFrom: beginPoint to: endPoint! !

!Form methodsFor: 'display box access'!
boundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height!
computeBoundingBox
	^ Rectangle origin: 0 @ 0
			corner: width @ height! !

!Form methodsFor: 'pattern'!
bitPatternForDepth: suspectedDepth
	"Only called when a Form is being used as a fillColor.  Use a Pattern or InfiniteForm instead for this purpose.
	Interpret me as an array of (32/depth) Color pixelValues.  BitBlt aligns the first element of this array with the top scanline of the destinationForm, the second with the second, and so on, cycling through the color array as necessary. 6/18/96 tk"

	^ self!
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 d2 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!
colorAt: aPoint
	"Return the Color in the pixel at coordinate aPoint.  6/20/96 tk"

	^ Color 
		colorFromPixelValue: 
			((BitBlt bitPokerToForm: self) pixelAt: aPoint)
		depth: depth!
colorAt: aPoint put: aColor
	"Store a Color into the pixel at coordinate aPoint.  6/20/96 tk"

	^ (BitBlt bitPokerToForm: self)
		pixelAt: aPoint
		put: (aColor pixelValueForDepth: depth)
"
[Sensor anyButtonPressed] whileFalse:
	[Display colorAt: Sensor cursorPoint put: Color red]
"!
fillFromXColorBlock: colorBlock
	"Horizontal Gradient Fill.
	Supply relative x in [0.0 ... 1.0] to colorBlock,
	and paint each pixel with the color that comes back"
	| xRel |
	0 to: width-1 do:
		[:x |  xRel _ x asFloat / (width-1) asFloat.
		self fill: (x@0 extent: 1@height) 
			fillColor: (colorBlock value: xRel)]
"
((Form extent: 100@100 depth: Display depth)
	fillFromXColorBlock: [:x | Color r: x g: 0.0 b: 0.5]) display
"!
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
"!
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 |  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
"!
fillPeriphery: aHalfTone
	"Fill any white areas at the periphery of this form with aHalftone."
	^ self shapeFill: aHalfTone seedBlock:
		[:form | form border: form boundingBox width: 1 rule: Form reverse fillColor: nil]!
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!
makeBWForm: foregroundColor
	"Map this form into a B/W form with 1's in the foreground regions."
	| bwForm map |
	bwForm _ Form extent: self extent.
	map _ self newColorMap.  "All non-foreground go to 0's"
	map at: (foregroundColor mapIndexForDepth: depth) put: 1.
	bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map.
	^ bwForm!
pixelValueAt: aPoint 
	"Return the raw pixel value at coordinate aPoint.  Depends on the form's depth.  Use colorAt: instead to get a Color.  6/20/96 tk"

	^ (BitBlt bitPeekerFromForm: self) pixelAt: aPoint!
pixelValueAt: aPoint put: pixelValue
	"Store the pixel value at coordinate aPoint.  Use colorAt:put: instead. 6/20/96 tk"

	^ (BitBlt bitPokerToForm: self) pixelAt: aPoint put: pixelValue!
shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint
	sharpCorners: sharpen internal: internal
	"Identify the shape (region of identical color) at interiorPoint,
	and then add an outline of width=borderWidth and color=aColor.
	If sharpen is true, then cause right angles to be outlined by
	right angles.  If internal is true, then produce a border that lies
	within the identified shape.  Thus one can put an internal border
	around the whole background, thus effecting a normal border
	around every other foreground image."
	| shapeForm borderForm interiorColor |
	"First identify the shape in question as a B/W form"
	interiorColor _ Color colorFromPixelValue:
		(self pixelValueAt: interiorPoint) depth: depth.
	shapeForm _ (self makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:form | form pixelValueAt: interiorPoint put: 1].
	"Reverse the image to grow the outline inward"
	internal ifTrue: [shapeForm reverse].
	"Now find the border fo that shape"
	borderForm _ shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen.
	"Finally use that shape as a mask to paint the border with color"
	self fillShape: borderForm fillColor: aColor!
shapeFill: aColor interiorPoint: interiorPoint
	"Identify the shape (region of identical color) at interiorPoint,
	and then fill that shape with the new color, aColor
	9/19/96 sw: modified di's original method such that it returns the bwForm, for potential use by the caller"

	| bwForm map interiorColor |
	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."
	interiorColor _ Color colorFromPixelValue:
		(self pixelValueAt: interiorPoint) depth: depth.
	bwForm _ self makeBWForm: interiorColor.
	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"
	self fillShape: bwForm fillColor: aColor.
	^ bwForm!
shapeFill: aColor seedBlock: seedBlock
	depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms."
	(self findShapeAroundSeedBlock: seedBlock)
		displayOn: self at: 0@0 clippingBox: self boundingBox
		rule: Form under fillColor: aColor !
sumBitsAt: aPoint cellSize: s
	"Return the number of pixels whose value is 1 (black) in the s-by-s cell whose topLeft is aPoint.  Only meaningful for depth 1 forms."
	| bp n |
	n _ 0.
	bp _ BitBlt bitPeekerFromForm: self.
	0 to: s-1 do:
		[:x | 0 to: s-1 do: 
			[:y | n _ n + (bp pixelAt: aPoint + (x@y))]].
	^ n! !

!Form methodsFor: 'bordering'!
borderWidth: anInteger 
	"Set the width of the border for the receiver to be anInteger and paint it 
	using Form black as the border color."

	self border: self boundingBox width: anInteger fillColor: Color black!
borderWidth: anInteger color: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask!
borderWidth: anInteger fillColor: aMask
	"Set the width of the border for the receiver to be anInteger and paint it 
	using aMask as the border color."

	self border: self boundingBox width: anInteger fillColor: aMask! !

!Form methodsFor: 'scaling'!
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."
	| newForm |
	newForm _ Form extent: (aRectangle extent * scale) truncated depth: depth.
	(WarpBlt toForm: newForm)
		sourceForm: self;
		combinationRule: 3;
		copyQuad: aRectangle asQuad toRect: newForm boundingBox.
	^ newForm

"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]]
"!
shrink: aRectangle by: scale 
	^ self magnify: aRectangle by: 1.0/scale! !

!Form methodsFor: 'editing'!
bitEdit
	"Create and schedule a view located in an area designated by the user 
	that contains a view of the receiver magnified by 8@8 that can be 
	modified using the Bit Editor. It also contains a view of the original 
	form."

	BitEditor openOnForm: self

	"Note that using direct messages to BitEditor, fixed locations and scales can be created.
	That is, also try:
		BitEditor openOnForm: self at: <some point>
		BitEditor openOnForm: self at: <some point> scale: <some point>"!
bitEditAt: magnifiedFormLocation scale: scaleFactor 
	"Create and schedule a view whose top left corner is magnifiedLocation 
	and that contains a view of the receiver magnified by scaleFactor that 
	can be modified using the Bit Editor. It also contains a view of the 
	original form."

	BitEditor openOnForm: self at: magnifiedFormLocation scale: scaleFactor !
edit
	"Start up an instance of the FormEditor on this form. Typically the form 
	is not visible on the screen. The editor menu is located at the bottom of 
	the form editing frame. The form is displayed centered in the frame. 
	YellowButtonMenu accept is used to modify the form to reflect the 
	changes made on the screen version; cancel restores the original form to 
	the screen. Note that the changes are clipped to the original size of the 
	form."
 
	FormEditor openOnForm: self! !

!Form methodsFor: 'image manipulation'!
cgForPixelValue: pv orNot: not
	"Return the center of gravity for all pixels of value pv.
	Note:  If orNot is true, then produce the center of gravity for all pixels
	that are DIFFERENT from the supplied (background) value"
	| pixCount weighted xAndY |
	xAndY _ (Array with: (self xTallyPixelValue: pv orNot: not)
					with: (self yTallyPixelValue: pv orNot: not)) collect:
		[:profile |	"For both x and y profiles..."
		pixCount _ 0.  weighted _ 0.
		profile doWithIndex:
			[:t :i | pixCount _ pixCount + t.
			weighted _ weighted + (t*i)].
		pixCount = 0  "Produce average of nPixels weighted by coordinate"
			ifTrue: [0.0]
			ifFalse: [weighted asFloat / pixCount asFloat - 1.0]].

	^ xAndY first @ xAndY last
"
| f cg |
[Sensor anyButtonPressed] whileFalse:
	[f _ Form fromDisplay: (Sensor cursorPoint extent: 50@50).
	cg _ f cgForPixelValue: (Color black pixelValueForDepth: f depth) orNot: false.
	f displayAt: 0@0.
	Display fill: (cg extent: 2@2) fillColor: Color red].
	ScheduledControllers restore
"!
convexShapeFill: aMask     "(Form dotOfSize: 20) displayAt: 20@20"
	"Fill the interior of the outtermost outlined region in the receiver.  The outlined region must not be concave by more than 90 degrees."
	| 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).
		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!
flipBy: direction centerAt: aPoint
	"Return a copy of the receiver flipped either #vertical or #horizontal."
	| newForm quad |
	newForm _ Form extent: self extent depth: depth.
	quad _ self boundingBox asQuad.
	quad _ (direction = #vertical ifTrue: [#(2 1 4 3)] ifFalse: [#(4 3 2 1)])
		collect: [:i | quad at: i].
	(WarpBlt toForm: newForm)
		sourceForm: self;
		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]
"!
innerPixelRectFor: pv orNot: not
	"Return a rectangle describing the smallest part of me that includes 
	all pixels of value pv.
	Note:  If orNot is true, then produce a copy that includes all pixels
	that are DIFFERENT from the supplied (background) value"

	| xTally yTally |
	xTally _ self xTallyPixelValue: pv orNot: not.
	yTally _ self yTallyPixelValue: pv orNot: not.
	^ ((xTally findFirst: [:t | t>0]) - 1) @ ((yTally findFirst: [:t | t>0]) - 1)
		corner:
			(xTally findLast: [:t | t>0])@(yTally findLast: [:t | t>0])!
opaqueRotationSet: steps rotationCenter: aPoint
	"CAUTION:  this returns the set in counterclockwise order from north-pointing.  For the HyperSqueak work of 6/96, the assumption is that they come in clockwise order, and so a fudging routine, SqueakSupport.reversedFormSetFrom:, is provided.  Someday this should be cleaned up.
	8/8/96 sw: this variant has a rotationCenter argument, though at the moment it is not used.  It will come in as nil if there is no special center, in which case the centroid of the form should be used, as it always is in the current implementation."

	| drawing  back90 flip quad |

	self flag: #noteToTed.  "This at the moment is the same as what you fixed up a couple of months ago, and does not actually use the rotationCenter part.  8/9/96 sw"

	drawing _ Array new: steps.

	steps \\ 4 = 0 ifFalse: ["Can't pull any symmetry tricks, rotate every one"
		1 to: steps do: [:ind |
			drawing at: ind put: (self rotateBy: 360 - ((ind-1) * 360 // steps))].
			^ drawing].
	"Do in four sections"
	quad _ steps // 4.
	1 to: quad do: [:ind |		"degrees: 360, 330, 300"
			drawing at: ind put: (self rotateBy: 360 - ((ind-1)*360//steps))].
	1 to: quad do: [:ind |		"degrees: 270, 240, 210"
			back90 _ drawing at: ind.
			drawing at:  ind + quad put: (back90 rotateBy: #left centerAt: back90 center)].
	1 to: quad + quad do: [:ind |	"the entire second half circle is rotated 180"
			back90 _ drawing at: ind.
			flip _ back90 flipBy: #vertical centerAt: back90 center. 
			drawing at: ind + quad + quad put: (flip flipBy: #horizontal centerAt: flip center)]. 

	^ drawing collect: [:elem |
		elem offset: 0@0. 
		MaskedForm transparentBorder: elem]!
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: 22].
	"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: 22
"  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]
"!
primCountBits
	"Count the non-zero pixels of this form."
	^ (BitBlt toForm: self)
		fillColor: (Bitmap with: 0);
		destRect: (0@0 extent: width@height);
		combinationRule: 22;
		copyBits!
rotateBy: deg
	"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 p0 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;
		combinationRule: Form over.
	r1 _ rot boundingBox align: center with: self boundingBox center.

	pts _ r1 asQuad 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)) display].
f display
"!
rotateBy: direction centerAt: aPoint
	"Return a copy of the receiver rotated either #right or #left"
	| newForm warp quad |
	newForm _ Form extent: height@width depth: depth.
	quad _ self boundingBox asQuad.
	quad _ (direction = #left ifTrue: [0 to: 3] ifFalse: [2 to: 5])
		collect: [:i | quad atWrap: i].
	(WarpBlt toForm: newForm)
		sourceForm: self;
		combinationRule: 3;
		copyQuad: quad 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]
"!
rotateBy: deg rotationCenter: aPoint
	"Rotate the receiver by the indicated number of degrees.  This variant gets a rotation center, but in fact ignores the thing -- awaiting someone's doing the right thing.   8/9/96 sw
	Note that rotationCenter should now be easy to include in the offset of the resulting form -- see <Point> rotateBy: angle about: center.  Could be even faster by sharing the sin, cos inside rotateBy:.  This should really be reversed so that this becomes the workhorse, and rotateBy: calls this with rotationCenter: self boundingBox center.  And while we're at it, why not include scaling?  9/19/96 di "

	^ self rotateBy: deg!
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]!
tallyPixelValues
	"Return a Bitmap with tallies in it of the number of pixels in this Form
	that have each of the given values.  Note that several forms may be
	tallied into the same table by callingtPVInto: with the same table.
	Also bitmaps of depth 16 or 32 can be tallied into tables of size
	512, 4096 or 32768 by direct calls with a Bitmap of such size."
	| tallies pixPerWord |
	tallies _ Bitmap new: (1 bitShift: (self depth min: 9)).
	self tallyPixelValuesPrimitive: self boundingBox into: tallies.
	pixPerWord _ 32//depth.
	self width\\pixPerWord ~= 0 ifTrue:
		["Subtract bogus null-count due to word-boundary."
		tallies at: 1 put: (tallies at: 1) - (pixPerWord-(self width\\pixPerWord)*self height)].
	^ tallies!
tallyPixelValuesInRect: destRect into: valueTable
	"Tally the selected pixels of this form into the valueTable, which is
	a bitmap similar to a color map.  Since the underlying BitBlt function
	that performs the tally does not do bit-boundary clipping, the
	tallies for any word-boundary fringes must be subtracted."
	| fringeTallies pixPerWord |
	self tallyPixelValuesPrimitive: destRect into: valueTable.
	pixPerWord _ 32//depth.
	destRect left\\pixPerWord ~= 0 ifTrue:
		[fringeTallies _ (self copy:
			((destRect left//pixPerWord*pixPerWord)@destRect top extent: pixPerWord@destRect height)) tallyPixelValues.
		"Extra nulls in the fringeTallies about to be subtracted"
		valueTable at: 1 put: (valueTable at: 1) + (destRect left\\pixPerWord*destRect height).
		1 to: fringeTallies size do:
			[:i | valueTable at: i put: (valueTable at: i) - (fringeTallies at: i)]].
	destRect right\\pixPerWord ~= 0 ifTrue:
		[fringeTallies _ (self copy:
			((destRect right)@destRect top extent: pixPerWord@destRect height)) tallyPixelValues.
		"Extra nulls in the fringeTallies about to be subtracted"
		valueTable at: 1 put: (valueTable at: 1) + ((pixPerWord-(destRect right\\pixPerWord))*destRect height).
		1 to: fringeTallies size do:
			[:i | valueTable at: i put: (valueTable at: i) - (fringeTallies at: i)]].
	^ 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) collect: [:i | i -> (tallies at: i)]
			thenSelect: [:assn | assn value > 0].
	nonZero printString , '          ' displayAt: 0@0.
	Display border: (r expandBy: 2) width: 2 rule: Form reverse fillColor: nil]]
"!
tallyPixelValuesPrimitive: destRect into: valueTable
	"Tally the selected pixels of this form into the valueTable, which is
	a bitmap similar to a color map.  Since the underlying BitBlt function
	that performs the tally does not do bit-boundary clipping, the
	tallies for any word-boundary fringes must be subtracted."

	(BitBlt toForm: self)
		sourceForm: self;  "src must be given for color map ops"
		sourceOrigin: 0@0;
		colorMap: valueTable;
		combinationRule: 23;
		destRect: destRect;
		copyBits.
	^ valueTable!
trimToPixelValue: pv orNot: not
	"Return the smallest part of me that includes all pixels of value pv.
	Note:  If orNot is true, then produce a copy that includes all pixels
	that are DIFFERENT from the supplied (background) value"

	^ self copy: (self innerPixelRectFor: pv orNot: not)
"
Try this to select all but the background...
Form fromUser do: [:f |
(f trimToPixelValue: f peripheralColor orNot: true) display]

Or this to select whatever is black...
Form fromUser do: [:f |
(f trimToPixelValue: (Color black pixelValueForDepth: f depth) orNot: false) display]
"!
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 |
	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.
	^ (0 to: width-1) collect:
		[:x |
		slice copyBits: (x@0 extent: 1@height) from: self at: 0@0
			colorMap: cm.
		slice primCountBits]!
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 |
	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.
	^ (0 to: height-1) collect:
		[:y |
		slice copyBits: (0@y extent: width@1) from: self at: 0@0
			colorMap: cm.
		slice primCountBits]! !

!Form methodsFor: 'fileIn/Out'!
bigMacPaintOn: stream
	| wLimit hLimit |
	width <= height 
		ifTrue: [wLimit _ 576. hLimit _ 720]
		ifFalse: [wLimit _ 720.	hLimit _ 576].

	(width <= wLimit and: [height <= hLimit])
		ifTrue: [^ self macPaintOn: stream].

	(width > 576 and: [width <= 720]) ifTrue:		"subdivide along height using 576"
		[^ self divideOn: stream extent: width@576 restOrigin: 0@576 restName: 'b'].
	(height > 576 and: [height <= 720]) ifTrue:	"subdivide along width using 576"
		[^ self divideOn: stream extent: 576@height restOrigin: 576@0 restName: 'a'].

	width > wLimit ifTrue:	"subdivide along width first"
		[^ self divideOn: stream extent: wLimit@height restOrigin: wLimit@0 restName: 'a'].

	"subdivide along height"
	self divideOn: stream extent: width@hLimit restOrigin: 0@hLimit restName: 'b'.
!
bigMacPaintOn: stream label: labelDisplayBox
	| form |
	form _ Form extent: (width max: labelDisplayBox width) @ (height + labelDisplayBox height).
	form copy: (0@0 extent: labelDisplayBox extent)
		from: labelDisplayBox topLeft
		in: Display rule: Form over.
	form copy: (0@labelDisplayBox height extent: self extent)
		from: 0@0
		in: self rule: Form over.
	form bigMacPaintOn: stream!
divideOn: stream extent: ext restOrigin: restOrigin restName: name
	"Divide self to fit in MacPaint file along width or height."
	| form newStream |
	form _ Form extent: ext.
	form copy: (0@0 extent: form extent)
			from: 0@0
			in: self rule: Form over.
	form bigMacPaintOn: stream.
	stream close.
	form _ Form extent: self extent - restOrigin.
	form copy: (0@0 extent: form extent)
			from: restOrigin
			in: self rule: Form over.
	newStream _ FileStream fileNamed: stream fileName, name.
	form bigMacPaintOn: newStream.
	newStream close.
!
macPaintOn: stream
	"Write the form to the stream in MacPaint format." 

	| scanLineForm scanLineBits scanLineBitBlt topMargin leftMargin |
	(width > 576) | (height > 720) ifTrue:
		[(width <=720 and: [height <= 576]) ifTrue:
			[^ (self rotateBy: #left centerAt: 0@0) macPaintOn: stream].
		self error: 'Form too big for MacPaint' ].
	stream nextPutAll: (ByteArray new: 512).	"The header"

	"BitBlt wants even # bytes, but Macpaint format wants
	73 bytes per line, so have to skip -1 after each write."
	scanLineBits _ ByteArray new: 74.
	scanLineBits at: 1 put: 71.	"Magic number for un-compressed images"
	scanLineForm _ Form new.
	scanLineForm setExtent: 584@1	"8 bits on left for magic number"
		offset: 0@0
		bits: scanLineBits.
	leftMargin _ ((576 - width) / 2) asInteger + 8.
	scanLineBitBlt _ BitBlt destForm: scanLineForm
		sourceForm: self
		fillColor: nil
		combinationRule: Form over
		destOrigin: leftMargin@0
		sourceOrigin: 0@0
		extent: width@1
		clipRect: (leftMargin@0 extent: (leftMargin+width)@1).

	topMargin _ ((720 - height) / 3) asInteger.
	scanLineBitBlt sourceForm: nil; fillColor: (Color white); copyBits.
	topMargin timesRepeat:
		[ stream nextPutAll: scanLineBits; skip: -1 ].

	scanLineBitBlt sourceForm: self; fillColor: nil; copyBits.
	0 to: height - 1 do: [ :n |
		scanLineBitBlt sourceY: n; copyBits.
		stream nextPutAll: scanLineBits; skip: -1 ].

	topMargin _ (720 - height - topMargin).
	scanLineBitBlt sourceForm: nil; fillColor: (Color white); copyBits.
	topMargin timesRepeat:
		[ stream nextPutAll: scanLineBits; skip: -1 ].

	(stream isKindOf: FileStream) ifTrue:
		[stream setType: 'PNTG' creator: 'MPNT']

	"To turn some rectangle on the screen into a MacPaint file do:
	| f |
	f _ FileStream fileNamed: 'STScreen0'.
	Form fromUser macPaintOn: f.
	f close.
	"!
macPaintOn: stream label: labelDisplayBox
	"Write the form to the stream in MacPaint format.
	 NOTE: this implementation is nearly identical to the equally lengthy macPaintOn: method, from which it was derived (by Frank Ludolph, back in 1988, I believe); if we retain these methods, then surely someone should go to the work of merging them so that there's not so much wasted overlalp.  Modified 2/14/96 sw so that non-HFS versions of filestreams can be used also"

	| scanLineForm scanLineBits scanLineBitBlt topMargin leftMargin labelForm |

	(width > 576) | (height > (720 - (labelDisplayBox height)))
		ifTrue: [ self error: 'Form too big for MacPaint' ].
	stream nextPutAll: (ByteArray new: 512).	"The header"

	scanLineBits _ ByteArray new: 74.
	"BitBlt wants even # bytes, but Macpaint format wants
	73 bytes per line, so have to skip -1 after each write."
	scanLineBits at: 1 put: 71.	"Magic number for un-compressed images"
	scanLineForm _ Form new.
	scanLineForm setExtent: 584@1	"8 bits on left for magic number"
		offset: 0@0
		bits: scanLineBits.
	leftMargin _ ((576 - width) / 2) asInteger + 8.
	labelForm _ Form fromDisplay: labelDisplayBox.
	scanLineBitBlt _ BitBlt destForm: scanLineForm
		sourceForm: labelForm
		fillColor: nil
		combinationRule: Form over
		destOrigin: leftMargin@0
		sourceOrigin: 0@0
		extent: (labelDisplayBox width)@1
		clipRect: (leftMargin@0
				extent: (leftMargin+labelDisplayBox width)@1).

	topMargin _ ((720 - height - (labelDisplayBox height)) / 3) asInteger.
	scanLineBitBlt sourceForm: nil; fillColor: (Color white); copyBits.
	topMargin timesRepeat:
		[ stream nextPutAll: scanLineBits; skip: -1 ].

	scanLineBitBlt sourceForm: labelForm; fillColor: nil; copyBits.
	0 to: (labelDisplayBox height) - 1 do: [ :n |
		scanLineBitBlt sourceY: n; copyBits.
		stream nextPutAll: scanLineBits; skip: -1 ].

	scanLineBitBlt _ BitBlt destForm: scanLineForm
		sourceForm: self
		halftoneForm: nil
		combinationRule: Form over
		destOrigin: leftMargin@0
		sourceOrigin: 0@0
		extent: width@1
		clipRect: (leftMargin@0 extent: (leftMargin+width)@1).
	0 to: height - 1 do: [ :n |
		scanLineBitBlt sourceY: n; copyBits.
		stream nextPutAll: scanLineBits; skip: -1 ].

	topMargin _ (720 - height - (labelDisplayBox height) - topMargin).
	scanLineBitBlt sourceForm: nil; fillColor: (Color white); copyBits.
	topMargin timesRepeat:
		[ stream nextPutAll: scanLineBits; skip: -1 ].

	(stream isKindOf: FileStream) ifTrue:
		[stream setType: 'PNTG' creator: 'MPNT']!
readFrom: aFile
	"Reads the receiver from the file in the format:
		depth, extent, offset, bits."
	| offsetX offsetY |
	depth _ aFile next.
	(depth isPowerOfTwo and: [depth between: 1 and: 32])
		ifFalse: [self halt  "invalid depth"].
	width _ aFile nextWord.
	height _ aFile nextWord.
	offsetX  _ aFile nextWord.
	offsetY _ aFile nextWord.
	offsetX > 32767 ifTrue: [offsetX _ offsetX - 65536].
	offsetY > 32767 ifTrue: [offsetY _ offsetY - 65536].
	bits _ Bitmap newFromStream: aFile.
	bits size = self bitsSize ifFalse: [self halt "incompatible bitmap size"].
	^ self!
readFromOldFile: file
	"Read a Form in the original ST-80 format"
	| newForm w h code theBits pos offsetX offsetY |
	w _ file nextWord.
	h _ file nextWord.
	offsetX  _ file nextWord.
	offsetY _ file 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.
self halt.  "Update this to 32-bit bitmaps"
	1 to: w + 15 // 16 do:
		[:j | 
		1 to: h do:
			[:i | theBits at: (pos _ pos+1) put: file nextWord]].
	newForm bits: theBits.
	file close.
	^ newForm!
writeOn: file
	"Write the receiver on the file in the format
		depth, extent, offset, bits."
	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 writeOn: file! !

!Form methodsFor: 'printing'!
storeOn: aStream

	self storeOn: aStream base: 10!
storeOn: aStream base: anInteger 
	"Store the receiver out in the form: Form newExtent:fromArray:#()offset:"

	aStream nextPut: $(.
	aStream nextPutAll: self species name.
	aStream crtab: 1.
	aStream nextPutAll: 'extent: '.
	self extent printOn: aStream.
	aStream crtab: 1.
	aStream nextPutAll: 'fromArray: #('.
	1 to: bits size do: 
		[:index | 
		anInteger = 10
			ifTrue: [aStream space]
			ifFalse: [aStream crtab: 2].
		(self bits at: index) printOn: aStream base: anInteger].
	aStream nextPut: $).
	aStream crtab: 1.
	aStream nextPutAll: 'offset: '.
	self offset printOn: aStream.
	aStream nextPut: $)! !

!Form methodsFor: 'private'!
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!
fill: aRectangle rule: anInteger fillColor: aForm 
	"Replace a rectangular area of the receiver with the pattern described by aForm 
	according to the rule anInteger."
	(BitBlt toForm: self)
		copy: aRectangle
		from: 0@0 in: nil
		fillColor: aForm rule: anInteger!
initFromArray: anArray
	"Fill the bitmap from anArray.  If the array is shorter,
	then cycle around in its contents until the bitmap is filled."
	| ax as |
	ax _ 0.
	as _ anArray size.
	1 to: bits size do:
		[:index |
		(ax _ ax + 1) > as ifTrue: [ax _ 1].
		bits at: index put: (anArray at: ax)]!
isAllWhite
	"Answer whether all bits in the receiver are white (=0)."

	bits do: [:data | data ~= 0 ifTrue: [^false]].
	^true!
setExtent: extent
	"Create a virtual bit map with the given extent."

	^ self setExtent: extent depth: 1!
setExtent: extent depth: bitsPerPixel
	"Create a virtual bit map with the given extent and bitsPerPixel."

	width _ extent x.
	width < 0 ifTrue: [width _ 0].
	height _ extent y.
	height < 0 ifTrue: [height _ 0].
	depth _ bitsPerPixel.
	bits _ Bitmap new: self bitsSize!
setExtent: extent offset: aPoint
	"Create a virtual bit map with the givcen extent and offset."

	^ (self setExtent: extent depth: 1) offset: aPoint!
setExtent: extent offset: aPoint bits: aBitmap 
	"Should be rewritten -- most users are obsolete"
	^ (self setExtent: extent offset: aPoint) bits: aBitmap 
!
spread: rect from: sourceForm by: scale direction: dir
	| port |
	port _ BitBlt toForm: self.
	dir == #horiz
	ifTrue:
		[0 to: width-1 do: 
			[:i |  "slice up original area"
			port copy: (i@0 extent: 1@height)
				from: rect topLeft+((i asFloat/scale) truncated@0)
				in: sourceForm fillColor: nil rule: Form over]]
	ifFalse:
		[0 to: height-1 do: 
			[:i |  "slice up original area"
			port copy: (0@i extent: width@1)
				from: rect topLeft+(0@(i asFloat/scale) truncated)
				in: sourceForm fillColor: nil rule: Form over]]! !

!Form methodsFor: 'palette access'!
gray
	^ Color gray!
highLight  "Color fromUser"
	"A default color that will at least reverse most bits"

	^ Color quickHighLight: depth!
someColor: colorIndex
	"Map 0 to white, 1 to black, and 2...nColors throughout the 
	remaining color space for this pixel depth"

	^ (Color allColorsForDepth: depth) atWrap: colorIndex! !

!Form methodsFor: 'bitmap, color test'!
bits
	"Answer the receiver's Bitmap containing its bits."

	^ bits!
bits: aBitmap 
	"Reset the Bitmap containing the receiver's bits."

	bits _ aBitmap!
bitsSize
	| pixPerWord |
	depth == nil ifTrue: [depth _ 1].
	pixPerWord _ 32 // depth.
	^ width + pixPerWord - 1 // pixPerWord * height!
depth
	^ depth!
depth: bitsPerPixel
	(bitsPerPixel > 32 or:
		[(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0])
		ifTrue: [self halt: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32'].
	depth _ bitsPerPixel!
newColorMap 
	"Return an uninitialized color map array appropriate to this depth form.
	Note that RBG forms may want 4k or 32k maps instead of the min 512"
	^ Bitmap new: (1 bitShift: (depth min: 9))!
peripheralColor
	"Return most common peripheral color,
	as sampled at 4 corners and 3 edges
	(this is so that the corners of round rectangles
	will win over the edges)"
	| perim samples |
	perim _ self boundingBox insetBy: (0@0 corner: 1@1).
	samples _ #(topLeft topCenter topRight rightCenter bottomRight bottomLeft leftCenter) collect:
		[:locName | self pixelValueAt: (perim perform: locName)].
	^ samples asBag sortedElements first key! !

!Form methodsFor: 'transitions'!
fadeImage: otherImage at: topLeft
	indexAndMaskDo: indexAndMaskBlock
	"This fade uses halftones as a blending hack.
	Zeros in the halftone produce the original image (self), and 
	ones in the halftone produce the 'otherImage'.
	IndexAndMaskBlock gets evaluated prior to each cycle,
	and the resulting boolean determines whether to continue cycling."
	| index imageRect maskForm tempForm resultForm |
	imageRect _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: imageRect extent).
	maskForm _ Form extent: 32@32.
	index _ 0.
	[indexAndMaskBlock value: (index _ index+1) value: maskForm]
	whileTrue:
		[maskForm reverse.
		resultForm copyBits: imageRect from: resultForm at: 0@0
			clippingBox: imageRect rule: Form over fillColor: maskForm.
		maskForm reverse.
		resultForm copyBits: imageRect from: otherImage at: 0@0
			clippingBox: imageRect rule: Form under fillColor: maskForm.
		self copyBits: imageRect from: resultForm at: topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil]!
fadeImageCoarse: otherImage at: topLeft
	"Display fadeImageCoarse: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j |
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: depth) - 1.
					1 to: 8//depth-1 do: [:q | pix _ pix bitOr: (pix bitShift: depth*4)]].
		i <= 16 ifTrue:
		[j _ i-1//4+1.
		(0 to: 28 by: 4) do: [:k |
			mask bits at: j+k
				put: ((mask bits at: j+k) bitOr: (pix bitShift: i-1\\4*depth))].
		"mask display." true]
		ifFalse: [false]]!
fadeImageFine: otherImage at: topLeft
	"Display fadeImageFine: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	| pix j ii |
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		i=1 ifTrue: [pix _ (1 bitShift: depth) - 1.
					1 to: 8//depth-1 do:
						[:q | pix _ pix bitOr: (pix bitShift: depth*4)]].
		i <= 16 ifTrue:
		[ii _ #(0 10 2 8 7 13 5 15 1 11 3 9 6 12 4 14) at: i.
		j _ ii//4+1.
		(0 to: 28 by: 4) do:
			[:k | mask bits at: j+k put:
				((mask bits at: j+k) bitOr: (pix bitShift: ii\\4*depth))].
		true]
		ifFalse: [false]]!
fadeImageHor: otherImage at: topLeft
	"Display fadeImageHor: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(mask height//2-i) extent: mask width@(i*2)) fillColor: Color black.
		(i*2) <= mask width]!
fadeImageHorFine: otherImage at: topLeft
	"Display fadeImageHorFine: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: (0@(i-1) extent: mask width@1) fillColor: Color black.
		mask fill: (0@(i-1+16) extent: mask width@1) fillColor: Color black.
		(i*2) <= mask width]!
fadeImageSquares: otherImage at: topLeft 
	"Display fadeImageSquares: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((16-i) asPoint extent: (i*2) asPoint) fillColor: Color black.
		i <= 16]!
fadeImageVert: otherImage at: topLeft
	"Display fadeImageVert: (Form fromDisplay: (10@10 extent: 300@300)) reverse at: 10@10"
	^ self fadeImage: otherImage at: topLeft indexAndMaskDo:
		[:i :mask |
		mask fill: ((mask width//2//depth-i*depth)@0 extent: i*2*depth@mask height) fillColor: Color black.
		i <= (mask width//depth)]!
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 p maskLoc maskRect stepSize cornerSel smallRect |
	stepSize _ 10.
	bb _ otherImage boundingBox.
	resultForm _ self copy: (topLeft extent: bb extent).
	maskForm _ Form extent: ((otherImage width min: otherImage height) + stepSize) asPoint.

	"maskLoc _ starting loc rel to topLeft"
	otherImage width > otherImage height
		ifTrue: ["wide image; motion is horizontal."
				(corner between: 2 and: 3) not ifTrue:
					["motion is to the right"
					delta _ 1@0.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [maskForm width@0]
						ifFalse: [maskForm width@stepSize])]
					ifFalse:
					["motion is to the left"
					delta _ -1@0.
					maskLoc _ bb topRight - (corner = 2
						ifTrue: [0@0]
						ifFalse: [0@stepSize])]]
		ifFalse: ["tall image; motion is vertical."
				corner <= 2 ifTrue:
					["motion is downward"
					delta _ 0@1.
					maskLoc _ bb topLeft - (corner = 1
						ifTrue: [0@maskForm height]
						ifFalse: [stepSize@maskForm height])]
					ifFalse:
					["motion is upward"
					delta _ 0@-1.
					maskLoc _ bb bottomLeft - (corner = 3
						ifTrue: [stepSize@0]
						ifFalse: [0@0])]].

	"Build a solid triangle in the mask form"
	(Pen newOnForm: maskForm) do: [:p |
		corner even  "Draw 45-degree line"
			ifTrue: [p place: 0@0; turn: 135; go: maskForm width*3//2]
			ifFalse: [p place: 0@(maskForm height-1); turn: 45; go: maskForm width*3//2]].
	maskForm smear: delta negated distance: maskForm width.
	"Copy the mask to full resolution for speed.  Make it be the reversed
	so that it can be used for ORing in the page-corner color"
	maskForm _ (Form extent: maskForm extent depth: otherImage depth)
		copyBits: maskForm boundingBox from: maskForm at: 0@0
		colorMap: (Bitmap with: 16rFFFFFFFF with: 0).

	"Now move the triangle maskForm across the resultForm selecting the
	triangular part of otherImage to display, and across the resultForm,
	selecting the part of the original image to erase."
	cornerSel _ #(topLeft topRight bottomRight bottomLeft) at: corner.
	1 to: (otherImage width + otherImage height // stepSize)+1 do:
		[:i |		"Determine the affected square"
		maskRect _ (maskLoc extent: maskForm extent) intersect: bb.
		((maskLoc x*delta x) + (maskLoc y*delta y)) < 0 ifTrue:
			[smallRect _ 0@0 extent: (maskRect width min: maskRect height) asPoint.
			maskRect _ smallRect align: (smallRect perform: cornerSel)
								with: (maskRect perform: cornerSel)].

		"AND otherForm with triangle mask, and OR into result"
		resultForm copyBits: bb from: otherImage at: 0@0
				clippingBox: maskRect rule: Form over fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form erase fillColor: nil.
		resultForm copyBits: maskForm boundingBox from: maskForm at: maskLoc
				clippingBox: maskRect rule: Form under fillColor: Color lightBrown.

		"Now update Display in a single BLT."
		self copyBits: maskRect from: resultForm at: topLeft + maskRect topLeft
				clippingBox: self boundingBox rule: Form over fillColor: nil.
		maskLoc _ maskLoc + (delta*stepSize)]
"
1 to: 4 do: [:corner | Display pageImage:
				(Form fromDisplay: (10@10 extent: 200@300)) reverse
			at: 10@10 corner: corner]
"
!
slideImage: otherImage at: topLeft delta: delta
	"Display slideImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 3@-4"
	| bb nSteps clipRect |
	bb _ otherImage boundingBox.
	clipRect _ topLeft extent: otherImage extent.
	nSteps _ 1.
	delta x = 0 ifFalse: [nSteps _ nSteps max: (bb width//delta x abs) + 1].
	delta y = 0 ifFalse: [nSteps _ nSteps max: (bb height//delta y abs) + 1].
	1 to: nSteps do:
			[:i | self copyBits: bb from: otherImage
				at: delta*(i-nSteps) + topLeft
				clippingBox: clipRect rule: Form over fillColor: nil]!
wipeImage: otherImage at: topLeft delta: delta
	"Display wipeImage: (Form fromDisplay: (40@40 extent: 300@300)) reverse
		at: 40@40 delta: 0@-2"
	| wipeRect bb nSteps |
	bb _ otherImage boundingBox.
	wipeRect _ delta x = 0
		ifTrue:
		[delta y = 0 ifTrue: [nSteps _ 1. bb "allow 0@0"] ifFalse: [
		nSteps _ bb height//delta y abs + 1.  "Vertical movement"
		delta y > 0
			ifTrue: [bb topLeft extent: bb width@delta y]
			ifFalse: [bb bottomLeft+delta extent: bb width@delta y negated]]]
		ifFalse:
		[nSteps _ bb width//delta x abs + 1.  "Horizontal movement"
		delta x > 0
			ifTrue: [bb topLeft extent: delta x@bb height]
			ifFalse: [bb topRight+delta extent: delta x negated@bb height]].
	^ self wipeImage: otherImage at: topLeft rectForIndex:
		[:i | i <= nSteps
			ifTrue: [wipeRect translateBy: (i-1)*delta]
			ifFalse: [nil]]!
wipeImage: otherImage at: topLeft rectForIndex: rectForIndexBlock
	| index thisRect clipRect |
	index _ 0.
	clipRect _ topLeft extent: otherImage extent.
	[(thisRect _ rectForIndexBlock value: (index _ index+1)) == nil]
	whileFalse:
		[thisRect do:
			[:r | self copyBits: r from: otherImage at: topLeft + r topLeft
				clippingBox: clipRect rule: Form over fillColor: nil]].!
zoomInTo: otherImage at: topLeft
	"Display zoomInTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self wipeImage: otherImage at: topLeft rectForIndex:
		[:i | i <= 16
			ifTrue: [otherImage center - (otherImage extent*i//32)
						extent: otherImage extent*i//16]
			ifFalse: [nil]]!
zoomOutTo: otherImage at: topLeft
	"Display zoomOutTo: (Form fromDisplay: (40@40 extent: 300@300)) reverse at: 40@40"
	^ self wipeImage: otherImage at: topLeft rectForIndex:
		[:i | i <= 16
			ifTrue: [(otherImage center - (otherImage extent*(17-i)//32)
						extent: otherImage extent*(17-i)//16)
					areasOutside:
					(otherImage center - (otherImage extent*(16-i)//32)
						extent: otherImage extent*(16-i)//16)]
			ifFalse: [nil]]! !

!Form methodsFor: 'coloring'!
clear
	"Reset the receiver to all white.   Created by Alan for his Ob prototype, 2/96, and now also used in the Obj world, though perhaps one might think about some forms clearing to other than pure white?!!"

        self fillWhite! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Form class
	instanceVariableNames: 'whiteMask darkGrayMask grayMask blackMask lightGrayMask veryLightGrayMask '!

!Form class methodsFor: 'instance creation'!
dotOfSize: diameter
	"Create a form which contains a round black dot."
	| radius form bite circle |
	radius _ diameter//2.
	form _ Form extent: diameter@diameter offset: (0@0) - (radius@radius).	
	diameter <= 9 ifTrue: "special case for speed"
		[form fillBlack.
		bite _ diameter//3.
		form fillWhite: (0@0 extent: bite@1).
		form fillWhite: (0@(diameter-1) extent: bite@1).
		form fillWhite: (diameter-bite@0 extent: bite@1).
		form fillWhite: (diameter-bite@(diameter-1) extent: bite@1).
		form fillWhite: (0@0 extent: 1@bite).
		form fillWhite: (0@(diameter-bite) extent: 1@bite).
		form fillWhite: (diameter-1@0 extent: 1@bite).
		form fillWhite: (diameter-1@(diameter-bite) extent: 1@bite).
		^ form].

	radius _ diameter-1//2.  "so circle fits entirely"
	(Circle new center: radius@radius radius: radius) displayOn: form.
	form convexShapeFill: form black.	"fill the circle with black"
	^ form

	"(Form dotOfSize: 8) displayAt: Sensor cursorPoint"!
extent: extentPoint
	"Answer an instance of me with blank bitmap."

	^ self basicNew setExtent: extentPoint!
extent: extentPoint depth: bitsPerPixel
	"Answer an instance of me with blank bitmap."

	^ self basicNew setExtent: extentPoint depth: bitsPerPixel!
extent: extentPoint fromArray: anArray offset: offsetPoint 
	"Answer an instance of me with bitmap initialized from anArray."

	^ (self basicNew setExtent: extentPoint offset: offsetPoint)
		initFromArray: anArray!
extent: extentPoint fromStipple: fourNibbles
	"Answer an instance of me with bitmap initialized from
	a repeating 4x4 bit stipple encoded in a 16-bit constant."
	| nibble |
	^ (self basicNew setExtent: extentPoint)
		initFromArray: ((1 to: 4) collect:
				[:i | nibble _ (fourNibbles bitShift: -4*(4-i)) bitAnd: 16rF.
				16r11111111 * nibble])  "fill 32 bits with each 4-bit nibble"!
extent: extentPoint offset: offsetPoint 
	"Answer an instance of me with a blank bitmap."

	^ (self basicNew setExtent: extentPoint)
		offset: offsetPoint!
fromDisplay: aRectangle 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen defined by aRectangle."

	^ (self extent: aRectangle extent depth: Display depth)
		fromDisplay: aRectangle!
fromDisplay: aRectangle using: oldForm
	"Like fromDisplay: only if oldForm is the right size, copy into it and answer it instead."

	((oldForm ~~ nil) and: [oldForm extent = aRectangle extent])
		ifTrue:
			[oldForm fromDisplay: aRectangle.
			 ^ oldForm]
		ifFalse:
			[^ self fromDisplay: aRectangle]!
fromTripletOfLiterals: aTriplet
	| extentDoublet offsetDoublet |
	extentDoublet _ aTriplet at: 1.
	offsetDoublet _ aTriplet at: 3.
	^ self extent: (extentDoublet at: 1) @ (extentDoublet at: 2) fromArray: (aTriplet at: 2) offset: ((offsetDoublet at: 1) @ (offsetDoublet at: 2))!
fromUser
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	1@1."

	^self fromUser: 1 @ 1!
fromUser: aPoint 
	"Answer an instance of me with bitmap initialized from the area of the 
	display screen designated by the user. The grid for selecting an area is 
	aPoint."

	^ self fromDisplay: (Rectangle fromUser: aPoint)! !

!Form class methodsFor: 'mode constants'!
and
	"Answer the integer denoting the logical 'and' combination rule."

	^1!
blend
	"Answer the integer denoting BitBlt's alpha blend combination rule."
	^24!
erase
	"Answer the integer denoting mode erase."

	^4!
erase1bitShape
	"Answer the integer denoting mode erase."

	^ 17!
over
	"Answer the integer denoting mode over."

	^3!
paint
	"Answer the integer denoting the 'paint' combination rule."

	^16!
reverse
	"Answer the integer denoting mode reverse."

	^6!
under
	"Answer the integer denoting mode under."

	^7! !

!Form class methodsFor: 'default colors'!
black
	"This message should be sent to Display, or other destForm"

	^ Display black!
darkGray
	"This message should be sent to Display, or other destForm"

	^ Display darkGray!
gray
	"This message should be sent to Display, or other destForm"

	^ Color gray!
lightGray
	"This message should be sent to Display, or other destForm"

	^ Display lightGray!
white
	"This message should be sent to Display, or other destForm"

	^ Display white! !

!Form class methodsFor: 'examples'!
exampleBorder    "Form exampleBorder"
	"This example demonstrates the border finding algorithm. Start
	by having the user sketch on the screen (end with option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of the region to be
	outlined, and the region begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeBorder: Color blue width: 2 interiorPoint: interiorPoint
			sharpCorners: false internal: false].
	f displayOn: Display at: r origin	!
exampleEdits
	"In Form category editing are messages edit and bitEdit that make it possible to 
	create editors on instances of Form. 
	 
	This is the general form editor:
	| f | 
	f _ Form fromUser. 
	f edit. 
	 
	This is the general bit editor:
	| f | 
	f _ Form fromUser. 
	f bitEdit."!
exampleMagnify

	| f m |
	f _ Form fromUser.
	m _ f magnify: f boundingBox by: 5 @ 5.
	m displayOn: Display at: Sensor waitButton

	"Form exampleMagnify."!
exampleShrink

	| f s |
	f _ Form fromUser.
	s _ f shrink: f boundingBox by: 2 @ 5.
	s displayOn: Display at: Sensor waitButton	

	"Form exampleShrink."!
exampleSketch
	"This is a simple drawing algorithm to get a sketch on the display screen.
	Draws whenever mouse button down.  Ends with option-click."
	| aPen color |
	aPen _ Pen new.
	color _ 0.
	[Sensor yellowButtonPressed]
		whileFalse:
		[aPen place: Sensor cursorPoint; color: (color _ color + 1).
		[Sensor redButtonPressed]
			whileTrue: [aPen goto: Sensor cursorPoint]].
	Sensor waitNoButton.

	"Form exampleSketch"!
exampleSpaceFill    "Form exampleSpaceFill"
	"This example demonstrates the area filling algorithm. Starts by having
	the user sketch on the screen (ended by option-click) and then select a rectangular
	area of the screen which includes all of the area to be filled. Finally,
	(with crosshair cursor), the user points at the interior of some region to be
	filled, and the filling begins with that place as its seed."
	| f r interiorPoint |
	Form exampleSketch.		"sketch a little area with an enclosed region"
	r _ Rectangle fromUser.
	f _ Form fromDisplay: r.
	Cursor crossHair showWhile:
		[interiorPoint _ Sensor waitButton - r origin].
	Cursor execute showWhile:
		[f shapeFill: Color gray interiorPoint: interiorPoint].
	f displayOn: Display at: r origin	!
makeStar  "See the similar example in OpaqueForm"
	| sampleForm pen |
	sampleForm _ Form extent: 50@50.  "Make a form"
	pen _ Pen newOnForm: sampleForm.
	pen place: 24@50; turn: 18.		"Draw a 5-pointed star on it."
	1 to: 5 do: [:i | pen go: 19; turn: 72; go: 19; turn: -144].
	^ sampleForm
"
Form makeStar follow: [Sensor cursorPoint]
				while: [Sensor noButtonPressed]
"!
tinyText: aText scale: m
	"(Form tinyText: 'Hi There!!  These caps are 5 high, and
the lower-case are 3 high.  Not bad, eh?' asText allBold scale: 2) display"
	| f1 tiny grays |
	f1 _ aText asDisplayText form.
	tiny _ Form extent: f1 extent//m depth: 8.
	grays _ (0 to: m*m) collect: [:i | 39 - (i*(39-16)//(m*m))].
	0 to: tiny width-1 do:
		[:x | 0 to: tiny height-1 do:
			[:y | tiny pixelValueAt: x@y
				put: (grays at: (f1 sumBitsAt: (x*m)@(y*m) cellSize: m) + 1)]].
	^ tiny!
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 |
	colors _ Display depth = 1
		ifTrue: [Array with: Color black]
		ifFalse: [Color red wheel: 20].
	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 veryLightGray.
	#(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 white veryLightGray) at: x))].
	ball _ Form dotOfSize: diam.
	color _ 1.
	[ true ] whileTrue:
		[port _ BitBlt toForm: Display.
		"Expand 1-bit forms to any pixel depth"
		port colorMap: (Bitmap with: 0 with: 16rFFFFFFFF).
		queue _ SharedQueue new: 32.
		16 timesRepeat: [queue nextPut: -20@-20].
		Sensor waitButton.
		Sensor yellowButtonPressed ifTrue: [^ self].
		filter _ Sensor cursorPoint.
		[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: (colors atWrap: color*9).
			(q _ queue next) == nil ifTrue: [^ self].	"exit"
			port copyForm: facade to: q rule: Form erase.
			Sensor redButtonPressed ifTrue: [queue nextPut: point]].
		color _ color + 1]!
xorHack: size  "Display restoreAfter: [Form xorHack: 256]"
	"Draw a smiley face or stick figure, and end with option-click.
	Thereafter image gets 'processed' as long as you have button down.
	If you stop at just the right time, you'll see you figure upside down,
	and at the end of a full cycle, you'll see it perfectly restored.
	Dude -- this works in color too!!"
	| rect form i bb |
	rect _ 5@5 extent: size@size.
	Display fillWhite: rect; border: (rect expandBy: 2) width: 2.
	Display border: (rect topRight - (0@2) extent: rect extent*2 + 4) width: 2.
	Form exampleSketch.
	form _ Form fromDisplay: rect.
	bb _ form boundingBox.
	i _ 0.
	[Sensor yellowButtonPressed] whileFalse:
		[[Sensor redButtonPressed] whileTrue:
			[i _ i + 1.
			(Array with: 0@1 with: 0@-1 with: 1@0 with: -1@0) do:
				[:d | form copyBits: bb from: form at: d
					clippingBox: bb rule: Form reverse fillColor: nil].
			form displayAt: rect topLeft.
			i+2\\size < 4 ifTrue: [(Delay forMilliseconds: 300) wait]].
		(form magnify: form boundingBox by: 2@2) displayAt: rect topRight + (2@0).
		Sensor waitButton].! !

!Form class methodsFor: 'screen dump'!
screenDump
	| form f |
	form _ Form fromDisplay: Display boundingBox.
	f _ FileStream fileNamed: 'STScreen', Time millisecondClockValue printString.
	form bigMacPaintOn: f.
	f close

"Form screenDump"! !

!Form class methodsFor: 'miscellaneous'!
randomTransitionSelector
	"Return a two-argument transition selector, chosen randomly.  7/25/96 sw"

	^ #(fadeImageCoarse:at: fadeImageFine:at: fadeImageHor:at: fadeImageHorFine:at: fadeImageSquares:at: fadeImageVert:at: zoomInTo:at: zoomOutTo:at:) atRandom

" slideImage:at:delta: wipeImage:at:delta: "! !Object subclass: #FormButtonCache
	instanceVariableNames: 'offset form value initialState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Editors'!
FormButtonCache comment:
'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.'!

!FormButtonCache methodsFor: 'accessing'!
form
	"Answer the receiver's form, the image of the button on the screen."

	^form!
form: aForm
	"Set the receiver's form to be the argument."

	form _ aForm!
initialState
	"Answer the receiver's initial state, on or off."

	^initialState!
initialState: aBoolean
	"Set the receiver's initial state, on or off, to be the argument."

	initialState _ aBoolean!
offset
	"Answer the receiver's offset, its relative position for displaying the 
	button."

	^offset!
offset: anInteger
	"Set the receiver's offset."

	offset _ anInteger!
value
	"Answer the receiver's value, the keyboard key that selects the button."

	^value!
value: aCharacter
	"Set the receiver's key character."

	value _ aCharacter! !MouseMenuController subclass: #FormEditor
	instanceVariableNames: 'form tool grid togglegrid mode previousTool color unNormalizedColor xgridOn ygridOn '
	classVariableNames: 'YgridKey OverKey YellowButtonMenu RepeatCopyKey SingleCopyKey InKey BlackKey OutKey LineKey TogglexGridKey FlashCursor DarkGrayKey ChangeGridsKey GrayKey SelectKey UnderKey ReverseKey WhiteKey BlockKey LightGrayKey CurveKey BitEditKey YellowButtonMessages EraseKey ToggleyGridKey '
	poolDictionaries: ''
	category: 'Graphics-Editors'!
FormEditor comment:
'I represent the basic editor for creating and modifying Forms. This is intended to be an easy to use general-purpose picture (bitMap) editor. I am a kind of MouseMenuController that creates a yellow button menu for accepting and canceling edits. My instances give up control if the cursor is outside the FormView or if a key on the keyboard is pressed.'!

!FormEditor methodsFor: 'initialize-release'!
initialize

	super initialize.
	self setVariables.
	self initializeYellowButtonMenu!
release
	"Break the cycle between the Controller and its view. It is usually not 
	necessary to send release provided the Controller's view has been properly 
	released independently."

	super release.
	form _ nil! !

!FormEditor methodsFor: 'basic control sequence'!
controlInitialize

	Cursor blank show.
	self normalizeColor: unNormalizedColor.
	sensor waitNoButton!
controlTerminate
	"Resets the cursor to be the normal Smalltalk cursor."

	Cursor normal show.
	view updateDisplay! !

!FormEditor methodsFor: 'control defaults'!
controlActivity

	super controlActivity.
	self dragForm!
isControlActive

	^super isControlActive & sensor blueButtonPressed not 
		& sensor keyboardPressed not! !

!FormEditor methodsFor: 'editing tools'!
block
	"Allow the user to fill a rectangle with the gray tone and mode currently 
	selected."

	| rectangle |
	rectangle _ Rectangle fromUser: grid.
	rectangle isNil 
		ifFalse: [Display
					fill: (rectangle intersect: view insetDisplayBox)
					rule: mode
					fillColor: color]!
changeGridding
	"Allow the user to change the values of the horizontal and/or vertical 
	grid modules. Does not change the primary tool."

	| response gridInteger |
	response _ 
		self promptRequest: 'Current horizontal gridding is: ' 
						, togglegrid x printString 
						, '.
Type new horizontal gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger _ Integer readFromString: response.
			togglegrid x: ((gridInteger max: 1) min: Display extent x)].
	response _ 
		self promptRequest: 'Current vertical gridding is: ' 
						, togglegrid y printString 
						, '.
Type new vertical gridding.'.
	response isEmpty
		ifFalse: 
			[gridInteger _ Integer readFromString: response.
			togglegrid y: ((gridInteger max: 1) min: Display extent y)].
	xgridOn ifTrue: [grid x: togglegrid x].
	ygridOn ifTrue: [grid y: togglegrid y].
	tool _ previousTool!
changeTool: aCharacter 
	"Change the value of the instance variable tool to be the tool 
	corresponding to aCharacter. Typically sent from a Switch in a 
	FormMenuView."

	previousTool _ tool.
	tool _ self selectTool: aCharacter.
	(#(singleCopy repeatCopy line curve block) includes: tool)
		ifFalse:
			[self perform: tool]!
colorBlack
	"Set the mask (color) to black. Leaves the tool set in its previous state."

	self setColor: Color black!
colorDarkGray
	"Set the mask (color) to dark gray. Leaves the tool set in its previous 
	state."

	self setColor: Color darkGray!
colorGray
	"Set the mask (color) to gray. Leaves the tool set in its previous state."

	self setColor: Color gray!
colorLightGray
	"Set the mask (color) to light gray. Leaves the tool set in its previous 
	state."

	self setColor: Color lightGray!
colorWhite
	"Set the mask (color) to white. Leaves the tool set in its previous state."

	self setColor: Color white!
curve
	"Conic-section specified by three points designated by: first point--press 
	red button second point--release red button third point--click red button. 
	The resultant curve on the display is displayed according to the current 
	form and mode."

	| firstPoint secondPoint thirdPoint curve |
	"sensor noButtonPressed ifTrue: [^self]."
	firstPoint _ self cursorPoint.
	form
		displayOn: Display
		at: firstPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	secondPoint _ self trackFormUntil: [sensor noButtonPressed].
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	thirdPoint _ self trackFormUntil: [sensor redButtonPressed]..
	form
		displayOn: Display
		at: thirdPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	form
		displayOn: Display
		at: secondPoint
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: color.
	curve _ Curve new.
	curve firstPoint: firstPoint.
	curve secondPoint: secondPoint.
	curve thirdPoint: thirdPoint.
	curve form: form.
	curve
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	sensor waitNoButton!
eraseMode
	"Set the mode for the tools that copy the form onto the display to erase. 
	Leaves the tool set in its previous state."

	mode _ 4.
	tool _ previousTool!
fileInForm
	"Ask the user for a file name and then recalls the Form in that file as 
	the current source Form (form). Does not change the tool."

	| inName |
	inName _ self promptRequest: 'type a name for recalling a source Form . . . '.
	(FileDirectory isLegalFileName: inName) 
		ifTrue: [form _ Form readFrom: inName].
	tool _ previousTool!
fileOutForm
	"Ask the user for a file name and then save the current source form 
	(form) under that name. Does not change the tool."

	| outName |
	outName _ self promptRequest: 'type a name for saving the source Form . . . '.
	FileDirectory convertName: outName with: [ :vol :name |
		(vol isLegalFileName: name)
			ifTrue: [(vol includesKey: name) 
					ifTrue: [(self confirm: 
									'Okay to write over old file?')
								ifTrue: [form writeOn: outName]]
					ifFalse: [form writeOn: outName]]].
	tool _ previousTool!
line
	"Line is specified by two points from the mouse: first point--press red 
	button; second point--release red button. The resultant line is displayed 
	according to the current form and mode."

	| firstPoint endPoint |
	firstPoint _ self cursorPoint.
	endPoint _ self rubberBandFrom: firstPoint until: [sensor noButtonPressed].
	(Line from: firstPoint to: endPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color!
magnify
	"Allow for bit editing of an area of the Form. The user designates a 
	rectangular area that is scaled by 5 to allow individual screens dots to be 
	modified. Red button is used to set a bit to black, and yellow button is 
	used to set a bit to white. Editing continues until the user depresses any 
	key on the keyboard."

	| smallRect smallForm scaleFactor tempRect |
	scaleFactor _ 8@8.
	smallRect _ (Rectangle fromUser: grid) intersect: view insetDisplayBox.
	smallRect isNil ifTrue: [^self].
	smallForm _ Form fromDisplay: smallRect.

	"Do this computation here in order to be able to save the existing display screen."
	tempRect _ BitEditor locateMagnifiedView: smallForm scale: scaleFactor.
	BitEditor
		openScreenViewOnForm: smallForm 
		at: smallRect topLeft 
		magnifiedAt: tempRect topLeft 
		scale: scaleFactor.
	tool _ previousTool!
newSourceForm
	"Allow the user to define a new source form for the FormEditor. Copying 
	the source form onto the display is the primary graphical operation. 
	Resets the tool to be repeatCopy."
	| dForm interiorPoint interiorColor |
	dForm _ Form fromUser: grid.
	"sourceForm must be only 1 bit deep"
	interiorPoint _ dForm extent // 2.
	interiorColor _ Color colorFromPixelValue:
		(dForm pixelValueAt: interiorPoint) depth: dForm depth.
	form _ (dForm makeBWForm: interiorColor) reverse
				findShapeAroundSeedBlock:
					[:f | f pixelValueAt: interiorPoint put: 1].
	form _ form trimToPixelValue: 1 orNot: false.
	tool _ previousTool!
overMode
	"Set the mode for the tools that copy the form onto the display to over. 
	Leaves the tool set in its previous state."

	mode _ Form over.
	tool _ previousTool!
repeatCopy
	"As long as the red button is pressed, copy the source form onto the 
	display screen."

	[sensor redButtonPressed]
		whileTrue: 
			[form
				displayOn: Display
				at: self cursorPoint
				clippingBox: view insetDisplayBox
				rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
				fillColor: color]!
reverseMode
	"Set the mode for the tools that copy the form onto the display to reverse. 
	Leaves the tool set in its previous state."

	mode _ Form reverse.
	tool _ previousTool!
setColor: aColor
	"Set the mask (color) to aColor.
	Hacked to invoke color chooser if not B/W screen.
	Leaves the tool set in its previous state."

	self normalizeColor:  (Display depth > 1
							ifTrue: [Color fromUser]
							ifFalse: [aColor]).
	tool _ previousTool!
singleCopy 
	"If the red button is clicked, copy the source form onto the display 
	screen."

	form
		displayOn: Display
		at: self cursorPoint
		clippingBox: view insetDisplayBox
		rule: (Display depth > 1 ifTrue: [Form paint]
										ifFalse: [mode])
		fillColor: color.
	sensor waitNoButton!
togglexGridding
	"Turn x (horizontal) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	xgridOn
		ifTrue: 
			[grid x: 1.
			xgridOn _ false]
		ifFalse: 
			[grid x: togglegrid x.
			xgridOn _ true].
	tool _ previousTool!
toggleyGridding
	"Turn y (vertical) gridding off, if it is on, and turns it on, if it is off. 
	Does not change the primary tool."

	ygridOn
		ifTrue: 
			[grid y: 1.
			ygridOn _ false]
		ifFalse: 
			[grid y: togglegrid y.
			ygridOn _ true].
	tool _ previousTool!
underMode
	"Set the mode for the tools that copy the form onto the display to under. 
	Leaves the tool set in its previous state."

	mode _ Form under.
	tool _ previousTool! !

!FormEditor methodsFor: 'menu messages'!
accept
	"The edited information should now be accepted by the view."

	view updateDisplay.
	view accept!
cancel
	"The edited information should be forgotten by the view."

	view cancel!
fileOut
	Cursor normal showWhile:
	[model writeOnFileNamed:
		(FillInTheBlank request: 'Enter file name'
				initialAnswer: 'Filename.form')]
!
redButtonActivity 
	"Refer to the comment in MouseMenuController|redButtonActivity."

	self perform: tool! !

!FormEditor methodsFor: 'cursor'!
cursorPoint
	"Answer the mouse coordinate data gridded according to the receiver's 
	grid."

	^sensor cursorPoint grid: grid! !

!FormEditor methodsFor: 'private'!
dragForm

	tool = #block
		ifTrue:
			[Cursor origin show.
			[sensor anyButtonPressed
				or: [sensor keyboardPressed
				or: [self viewHasCursor not]]]
				whileFalse: [].
			^self cursorPoint]
		ifFalse:
			[^self trackFormUntil:
				[sensor anyButtonPressed
					or: [sensor keyboardPressed
					or: [self viewHasCursor not]]]]!
initializeYellowButtonMenu

	self yellowButtonMenu: YellowButtonMenu
		yellowButtonMessages: YellowButtonMessages!
normalizeColor: aColor

	unNormalizedColor _ aColor.
	color _ unNormalizedColor originate: view insetDisplayBox origin on: Display !
promptRequest: outputMessage 
	"Answers with a string typed by the user on the keyboard. keyboard
	input is terminated by a line feed character. Typing feedback happens
	in a window that is at least 100 bits wide and 50 bits high."

	| answer |
	FillInTheBlank
		request: outputMessage
		displayAt: view insetDisplayBox topCenter + (0@80)
		centered: true
		action: [:answer] 
		initialAnswer: ''.
	^answer!
rubberBandFrom: startPoint until: aBlock

	| endPoint previousEndPoint |
	previousEndPoint _ startPoint.
	[aBlock value] whileFalse:
		[(endPoint _ self cursorPoint) = previousEndPoint 
			ifFalse:
			[(Line from: startPoint to: previousEndPoint withForm: form)
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Display black.
			(Line from: startPoint to: endPoint withForm: form)
				displayOn: Display
				at: 0 @ 0
				clippingBox: view insetDisplayBox
				rule: Form reverse
				fillColor: Display black.
			previousEndPoint  _ endPoint]].
	(Line from: startPoint to: previousEndPoint withForm: form)
		displayOn: Display
		at: 0 @ 0
		clippingBox: view insetDisplayBox
		rule: Form reverse
		fillColor: Display black.
	^endPoint!
selectTool: aCharacter
	"A new tool has been selected. It is denoted by aCharacter. Set the tool.
	This code is written out in long hand (i.e., rather than dispatching on a
	table of options) so that it is obvious what is happening."
	
	aCharacter =  SingleCopyKey	ifTrue: [^#singleCopy].
	aCharacter =  RepeatCopyKey	ifTrue: [^#repeatCopy].
	aCharacter =  LineKey			ifTrue: [^#line].					
	aCharacter =  CurveKey			ifTrue: [^#curve].				
	aCharacter =  BlockKey			ifTrue: [^#block].		
	aCharacter =  SelectKey			ifTrue: [^#newSourceForm].		
	aCharacter =  OverKey			ifTrue: [^#overMode].
	aCharacter =  UnderKey			ifTrue: [^#underMode].
	aCharacter =  ReverseKey		ifTrue: [^#reverseMode].
	aCharacter =  EraseKey			ifTrue: [^#eraseMode].
	aCharacter =  ChangeGridsKey	ifTrue: [^#changeGridding].
	aCharacter =  TogglexGridKey	ifTrue: [^#togglexGridding].
	aCharacter =  ToggleyGridKey	ifTrue: [^#toggleyGridding].
	aCharacter =  BitEditKey			ifTrue: [^#magnify].			
	aCharacter =  WhiteKey			ifTrue: [^#colorWhite].			
	aCharacter =  LightGrayKey		ifTrue: [^#colorLightGray].			
	aCharacter =  GrayKey			ifTrue: [^#colorGray].				
	aCharacter =  DarkGrayKey		ifTrue: [^#colorDarkGray].			
	aCharacter =  BlackKey			ifTrue: [^#colorBlack].				
	aCharacter =  OutKey			ifTrue: [^#fileOutForm].			
	aCharacter =  InKey				ifTrue: [^#fileInForm]!
setVariables
	tool _ #repeatCopy.
	previousTool _ tool.
	grid _ 1 @ 1.
	togglegrid _ 8 @ 8.
	xgridOn _ false.
	ygridOn _ false.
	mode _ Form over.
	form _ Form extent: 8 @ 8.
	form fillBlack.
	unNormalizedColor _ color _ Form black.
!
trackFormUntil: aBlock

	| previousPoint cursorPoint |
	previousPoint _ self cursorPoint.
	form displayOn: Display at: previousPoint rule: Form reverse.
	[aBlock value] whileFalse:
		[cursorPoint _ self cursorPoint.
		(FlashCursor or: [cursorPoint ~= previousPoint])
			ifTrue:
			[form displayOn: Display at: previousPoint rule: Form reverse.
			form displayOn: Display at: cursorPoint rule: Form reverse.
			previousPoint _ cursorPoint]].
	form displayOn: Display at: previousPoint rule: Form reverse.
	^previousPoint! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FormEditor class
	instanceVariableNames: ''!

!FormEditor class methodsFor: 'class initialization'!
flashCursor: aBoolean

	FlashCursor _ aBoolean

	"FormEditor flashCursor: true"!
initialize

	FlashCursor _ false.
	self setKeyboardMap.
	YellowButtonMenu _ PopUpMenu labels: 'accept
cancel
file out' lines: #(2).
	YellowButtonMessages _ #(accept cancel fileOut)

	"FormEditor initialize"! !

!FormEditor class methodsFor: 'instance creation'!
openFullScreenForm
	"Create and schedule an instance of me on the form whose extent is the 
	extent of the display screen."

	| topView |
	topView _ self createFullScreenForm.
	topView controller 
		openDisplayAt: (topView viewport extent//2)

	"FormEditor openFullScreenForm."!
openOnForm: aForm
	"Create and schedule an instance of me on the form aForm."

	| topView |
	topView _ self createOnForm: aForm.
	topView controller open

! !

!FormEditor class methodsFor: 'examples'!
formFromDisplay
	"Create an instance of me on a new form designated by the user at a
	location designated by the user."

	Form fromUser edit

	"FormEditor formFromDisplay"!
fullScreen
	"Create an instance of me on a new form that fills the full size of the
	display screen."

	FormEditor openFullScreenForm

	"FormEditor fullScreen"!
newForm
	"Create an instance of me on a new form at a location designated by the user. "

	(Form extent: 400 @ 200 depth: Display depth) edit

	"FormEditor newForm"! !

!FormEditor class methodsFor: 'private'!
createFullScreenForm
	"Create a StandardSystemView for a FormEditor on the form whole screen."
	| formView formEditor menuView topView extent aForm |
	aForm _ Form extent: (Display extent x @ (Display extent y - 112)) depth: Display depth.
	formView _ FormHolderView new model: aForm.
	formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: menuView controller.
	topView _ FormEditorView new.
	topView backgroundColor: #veryLightGray.
	topView model: aForm.
	topView addSubView: formView.
	topView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	topView window: 
		(formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))).
	topView label: 'Form Editor'.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView

!
createOnForm: aForm
	"Create a StandardSystemView for a FormEditor on the form aForm."

	| formView formEditor menuView aView topView extent topViewBorder |
	topViewBorder _ 2.
	formView _ FormHolderView new model: aForm.
	formEditor _ formView controller.
	menuView _ FormMenuView new makeFormEditorMenu model: formEditor.
	formEditor model: aForm.
	aView _ View new.
	aView model: aForm.
	aView addSubView: formView.
	aView 
		addSubView: menuView
		align: menuView viewport topCenter
		with: formView viewport bottomCenter + (0@16).
	aView window: 
		((formView viewport 
			merge: (menuView viewport expandBy: (16 @ 0 corner: 16@16))) 
		  expandBy: (0@topViewBorder corner: 0@0)).
	aView window extent > formView viewport extent
		ifTrue: [formView borderWidthLeft: 1 right: 1 top: 0 bottom: 1]
		ifFalse: [formView borderWidthLeft: 0 right: 0 top: 0 bottom: 1].
	topView _ FormEditorView new.
	topView backgroundColor: #veryLightGray.
	topView addSubView: aView.
	topView label: 'Form Editor'.
	topView borderWidth: topViewBorder.
	extent _ topView viewport extent.
	topView minimumSize: extent.
	topView maximumSize: extent.
	^topView!
setKeyboardMap
	"Keyboard Mapping."

	SelectKey_$a.
	SingleCopyKey_$s.			"tools"
	RepeatCopyKey_$d.
	LineKey_$f.
	CurveKey_$g.
	BlockKey_$h.
	OverKey_$j.				"modes"
	UnderKey_$k.
	ReverseKey_$l.
	EraseKey_$;.
	InKey_$'.					"file In"
	BitEditKey_$z.
	WhiteKey_$x.				"colors"
	LightGrayKey_$c.
	GrayKey_$v.
	DarkGrayKey_$b.
	BlackKey_$n.
	TogglexGridKey_$m.		"gridding"
	ToggleyGridKey_$,.
	ChangeGridsKey_$..
	OutKey_$/					"file Out"! !

FormEditor initialize!
StandardSystemView subclass: #FormEditorView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Editors'!

!FormEditorView methodsFor: 'as yet unclassified'!
cacheBitsAsTwoTone
	^ false! !FormView subclass: #FormHolderView
	instanceVariableNames: 'displayedForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Views'!
FormHolderView comment:
'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.'!

!FormHolderView methodsFor: 'initialize-release'!
release

	super release.
	displayedForm release.
	displayedForm _ nil! !

!FormHolderView methodsFor: 'model access'!
changeValueAt: location put: anInteger 
	"Refer to the comment in FormView|changeValueAt:put:."

	displayedForm pixelValueAt: location put: anInteger.
	displayedForm changed: self!
model: aForm

	super model: aForm.
	displayedForm _ aForm deepCopy!
workingForm
	"Answer the form that is currently being displayed--the working version 
	in which edits are carried out."

	^displayedForm! !

!FormHolderView methodsFor: 'displaying'!
displayView 
	"Display the Form associated with this View according to the rule and
	fillColor specifed by this class."

	| oldOffset |
	oldOffset _ displayedForm offset.
	displayedForm offset: 0@0.
	displayedForm
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	displayedForm offset: oldOffset!
updateDisplay
	"The working version is redefined by copying the bits displayed in the 
	receiver's display area."

	displayedForm fromDisplay: self displayBox.
	displayedForm changed: self! !

!FormHolderView methodsFor: 'menu messages'!
accept 
	"Refer to the comment in FormView|accept."
	model
		copyBits: displayedForm boundingBox
		from: displayedForm
		at: 0 @ 0
		clippingBox: model boundingBox
		rule: Form over
		fillColor: nil.
	model changed: self!
cancel 
	"Refer to the comment in FormView|cancel."

	displayedForm become: model deepCopy.
	displayedForm changed: self.
	self display! !FormView subclass: #FormInspectView
	instanceVariableNames: 'offset '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Views'!

!FormInspectView methodsFor: 'as yet unclassified'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  NoController!
displayTranformation
	displayTransformation == nil
		ifTrue: [displayTransformation _ self computeDisplayTransformation].
	displayTransformation setScale: 1@1 translation: displayTransformation translation.
	^ displayTransformation!
displayView 
	"Display the form as a value in an inspector.  8/11/96 sw"
	"Defeated form scaling for HS FormInspector.  8/20/96 di"
	| oldOffset |
	Display fill: self insetDisplayBox fillColor: Color white.
	model selectionIndex == 0 ifTrue: [^ self].
	oldOffset _ model selection offset.
	offset == nil ifFalse: [model selection offset: offset asPoint].
	model selection
		displayOn: Display
		transformation: (WindowingTransformation
			scale: 1@1
			translation: self displayTransformation translation)
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	model selection offset: oldOffset!
lock
	super lock.
	displayTransformation  setScale: 1@1 translation: displayTransformation translation!
offset: anOffset
	offset _ anOffset! !Controller subclass: #FormMenuController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Editors'!
FormMenuController comment:
'I represent a Controller that takes control if a key on the keyboard is depressed or if the cursor is within my rectangular area.'!

!FormMenuController methodsFor: 'control defaults'!
controlActivity
	"Pass control to a subView corresponding to a pressed keyboard key or to
	a mouse button pressed, if any."

	sensor keyboardPressed
		ifTrue: [self processMenuKey]
		ifFalse: [self controlToNextLevel]!
isControlActive
	"Answer false if the blue mouse button is pressed and the cursor is
	outside of the inset display box of the Controller's view; answer true,
	otherwise."

	^sensor keyboardPressed |
		(view containsPoint: sensor cursorPoint) & sensor blueButtonPressed not!
isControlWanted
	"Answer true if the cursor is inside the inset display box (see 
	View|insetDisplayBox) of the receiver's view, and answer false, 
	otherwise. It is sent by Controller|controlNextLevel in order to determine 
	whether or not control should be passed to this receiver from the
	Controller of the superView of this receiver's view."

	^sensor keyboardPressed | self viewHasCursor!
processMenuKey
	"The user typed a key on the keyboard. Give control to the subView that 
	is selected by this key."

	| aView |
	aView _ view subViewContainingCharacter: sensor keyboard.
	aView ~~ nil
		ifTrue: [aView controller sendMessage]! !View subclass: #FormMenuView
	instanceVariableNames: ''
	classVariableNames: 'BorderForm SpecialBorderForm FormButtons '
	poolDictionaries: ''
	category: 'Graphics-Editors'!
FormMenuView comment:
'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.'!

!FormMenuView methodsFor: 'initialize-release'!
makeFormEditorMenu

	| button buttonCache form aSwitchView aSwitchController|
	"Now get those forms into the subviews"
	self makeButton: 1.					"form source"
	self makeConnections: (2 to: 6).		"tools"
	self makeConnections: (7 to: 10).		"modes"
	self makeButton: 11.					"filing in"
	self makeButton: 12.					"bit editing"
	self makeColorConnections: (13 to: 17).		"colors"
	self makeGridSwitch: 18.					"toggle x"
	self makeGridSwitch: 19.					"toggle y"
	self makeButton: 20.					"setting grid"
	self makeButton: 21					"filing out"! !

!FormMenuView methodsFor: 'subView access'!
subViewContainingCharacter: aCharacter
	"Answer the receiver's subView that corresponds to the key, aCharacter. 
	Answer nil if no subView is selected by aCharacter."

	self subViews reverseDo: 
		[:aSubView |
		(aSubView containsKey: aCharacter) ifTrue: [^aSubView]].
	^nil	
! !

!FormMenuView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^FormMenuController! !

!FormMenuView methodsFor: 'private'!
makeButton: index

	| button buttonCache aSwitchView|
	buttonCache _ FormButtons at: index.
	button _ Button newOff.
	button onAction: [model changeTool: buttonCache value].
	aSwitchView _ self makeViews: buttonCache for: button.
	aSwitchView controller: IndicatorOnSwitchController new!
makeColorConnections: indexInterval

	| connector button buttonCache aSwitchView |
	connector _ Object new.		"A dummy model for connecting dependents"
	indexInterval do:
		[:index |
		buttonCache _ FormButtons at: index.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView highlightForm: BorderForm.
		aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1.
		aSwitchView controller selector: #turnOn].
	aSwitchView highlightForm: SpecialBorderForm.
	aSwitchView borderWidth: 1!
makeConnections: indexInterval

	| connector button buttonCache aSwitchView |
	connector _ Object new.		"A dummy model for connecting dependents."
	indexInterval do:
		[:index |
		buttonCache _ FormButtons at: index.
		buttonCache initialState = #true
			ifTrue: [button _ OneOnSwitch newOn]
			ifFalse: [button _ OneOnSwitch newOff].
		button onAction: [model changeTool: buttonCache value].
		button connection: connector.
		aSwitchView _ self makeViews: buttonCache for: button.
		aSwitchView borderWidthLeft: 1 right: 0 top: 1 bottom: 1.
		aSwitchView controller selector: #turnOn].
	aSwitchView borderWidth: 1!
makeGridSwitch: index

	| button buttonCache |
	buttonCache _ FormButtons at: index.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	button offAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button!
makeSwitch: index

	| button buttonCache |
	buttonCache _ FormButtons at: index.
	buttonCache initialState = #true
		ifTrue: [button _ Switch newOn]
		ifFalse: [button _ Switch newOff].
	button onAction: [model changeTool: buttonCache value].
	self makeViews: buttonCache for: button!
makeViews: cache for: aSwitch

	| form aSwitchView |
	form _ cache form.
	aSwitchView _ SwitchView new model: aSwitch.
	aSwitchView key: cache value.
	aSwitchView label: form.
	aSwitchView window: (0@0 extent: form extent).
	aSwitchView translateBy: cache offset.
	aSwitchView borderWidth: 1.
	self addSubView: aSwitchView.
	^aSwitchView! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FormMenuView class
	instanceVariableNames: ''!

!FormMenuView class methodsFor: 'class initialization'!
fileOut   "FormMenuView fileOut"
	"Save the FormEditor icons"
	| names |
	names _ 
		#('select.form.' 'singlecopy.form.' 'repeatcopy.form.' 'line.form.' 'curve.form.'
		'block.form' 'over.form.' 'under.form.' 'reverse.form.' 'erase.form.' 'in.form.'
		'magnify.form.' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form.' 'ygrid.form.' 'togglegrids.form.' 'out.form.' ).
	1 to: 21 do:  [:i |  (FormButtons at: i) writeOn: (names at: i)].
	SpecialBorderForm writeOn: 'specialborderform.form'.
	BorderForm writeOn: 'borderform.form'!
initialize
	"The forms for the menu are typically stored on files. In order to avoid
	reading them every time, they are stored in a collection that is a class
	variable, along with the offset, tool value, and initial visual state (on or
	off), that makes up the view of the form in the menu view."

	| offsets keys names formButton states |
	offsets _ OrderedCollection new: 21.
	#( 0 64 96 128 160 192 256 288 320 352 420) do: [:i | offsets addLast: i@0]. "First row"
	#( 0 64 96 128 160 192 256 304 352 420) do: [:i | offsets addLast: i@48].		"Second row"
	offsets _ offsets asArray.
	keys _ #($a $s $d $f $g $h $j $k $l $; $' $z $x $c $v $b $n $m $, $. $/ ).	"Keyboard"
	states _
		#(false false true false false false true false false false false false false
		false false false true false false false false ).		"Initial states of buttons"
	names _ 
		#('select.form.' 'singlecopy.form.' 'repeatcopy.form.' 'line.form.' 'curve.form.'
		'block.form' 'over.form.' 'under.form.' 'reverse.form.' 'erase.form.' 'in.form.'
		'magnify.form.' 'white.form' 'lightgray.form' 'gray.form' 'darkgray.form' 'black.form'
		'xgrid.form.' 'ygrid.form.' 'togglegrids.form.' 'out.form.' ).	"Files of button images"
	FormButtons _ OrderedCollection new.
	1 to: 21 do: 
		[:index | 
		formButton _ FormButtonCache new.
		formButton form: (Form readFromFileNamed: (names at: index)).
		formButton offset: (offsets at: index).
		formButton value: (keys at: index).
		formButton initialState: (states at: index).
		FormButtons addLast: formButton].
	SpecialBorderForm  _ Form readFromFileNamed: 'specialborderform.form'.
	BorderForm _ Form readFromFileNamed: 'borderform.form'

	"FormMenuView initialize"! !

FormMenuView initialize!
View subclass: #FormView
	instanceVariableNames: 'rule mask '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Views'!
FormView comment:
'I represent a view of a Form.'!

!FormView methodsFor: 'accessing'!
fillColor
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask!
fillColor: aForm 
	"Set the display mask for displaying the receiver's model to be the 
	argument, aForm."

	mask _ aForm!
mask
	"Answer an instance of class Form that is the mask used when displaying 
	the receiver's model (a Form) on the display screen (see BitBlt for the 
	meaning of this mask)."

	^ mask!
rule
	"Answer a number from 0 to 15 that indicates which of the sixteen 
	display rules (logical function of two boolean values) is to be used when 
	copying the receiver's model (a Form) onto the display screen."

	rule == nil
		ifTrue: [^self defaultRule]
		ifFalse: [^rule]!
rule: anInteger 
	"Set the display rule for the receiver to be the argument, anInteger."

	rule _ anInteger! !

!FormView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^  FormEditor! !

!FormView methodsFor: 'model access'!
changeValueAt: location put: anInteger
	"The receiver's model is a form which has an array of bits. Change the 
	bit at index, location, to be anInteger (either 1 or 0). Inform all objects 
	that depend on the model that it has changed."

	model pixelValueAt: location put: anInteger.
	model changed: self! !

!FormView methodsFor: 'window access'!
defaultWindow 
	"Refer to the comment in View|defaultWindow."

	^(Rectangle origin: 0 @ 0 extent: model extent)
		expandBy: borderWidth!
windowBox
	"For comaptibility with Control manager (see senders)"
	^ self insetDisplayBox! !

!FormView methodsFor: 'displaying'!
displayOn: aPort
	model displayOnPort: aPort at: self displayBox origin!
displayView 
	"Refer to the comment in View|displayView."

	| oldOffset |
	super displayView.
	insideColor == nil ifFalse: [Display fill: self insetDisplayBox fillColor: insideColor].
	oldOffset _ model offset.
	model offset: 0@0.
	model
		displayOn: Display
		transformation: self displayTransformation
		clippingBox: self insetDisplayBox
		rule: self rule
		fillColor: self fillColor.
	model offset: oldOffset!
uncacheBits
	"Placed vacuously here so that when ControlManager>>restore calls uncacheBits for a project with no windows, we don't hang.  1/24/96 sw"! !

!FormView methodsFor: 'updating'!
update: aFormView 
	"Refer to the comment in View|update:."

	self == aFormView ifFalse: [self display]! !

!FormView methodsFor: 'menu messages'!
accept
	"The receiver's model is set to the working version, the one in which 
	edits are carried out."

	^self!
cancel
	"Set the working form to be a copy of the model."

	^self! !

!FormView methodsFor: 'private'!
defaultRule 
	"The default display rule is 3=over or storing."

	^Form over! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

FormView class
	instanceVariableNames: ''!

!FormView class methodsFor: 'examples'!
exampleOne
	"Frame a Form (specified by the user) with a border of 2 bits in width and display it offset 60 x 40 from the cornor of the display screen. "
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleOne"!
exampleTwo
	"Frame a Form (specified by the user) that is scaled by 2. The border is 2 bits in width. Displays at location 60, 40."
	| f view |
	f _ Form fromUser.
	view _ self new model: f.
	view scaleBy: 2.0.
	view translateBy: 60 @ 40.
	view borderWidth: 2.
	view display.
	view release

	"FormView exampleTwo"! !Number subclass: #Fraction
	instanceVariableNames: 'numerator denominator '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!
Fraction comment:
'I represent some rational number as a fraction. All public arithmetic operations answer reduced fractions.'!

!Fraction methodsFor: 'arithmetic'!
* aFraction

	(aFraction isMemberOf: Fraction)
		ifTrue: [^(Fraction 
					numerator: numerator * aFraction 
	"Refer to the comment in Number|*." numerator
					denominator: denominator * aFraction denominator)
					reduced]
		ifFalse: [^self retry: #* coercing: aFraction]!
+ aFraction

	| commonDenominator newNumerator |
	(aFraction isMemberOf: Fraction)
		ifTrue: 
			[denominator = aFraction 
	"Refer to the comment in Number|+." denominator 
				ifTrue: [^(Fraction 
							numerator: numerator + aFraction numerator
							denominator: denominator) reduced].
			commonDenominator _ denominator lcm: aFraction denominator.
			newNumerator _ numerator 
								* (commonDenominator / denominator) 
								+ (aFraction numerator * 
									(commonDenominator / aFraction denominator)).
			^(Fraction 
				numerator: newNumerator 
				denominator: commonDenominator) reduced]
		ifFalse: [^self retry: #+ coercing: aFraction]!
- aFraction

	(aFraction isMemberOf: Fraction)
		ifTrue: [^self + aFraction 
	"Refer to the comment in Number|-." negated]
		ifFalse: [^self retry: #- coercing: aFraction]!
/ aFraction

	(aFraction isMemberOf: Fraction)
		ifTrue: [^self * aFraction 
	"Refer to the comment in Number|/." reciprocal]
		ifFalse: [^self retry: #/ coercing: aFraction]!
negated 
	"Refer to the comment in Number|negated."

	^Fraction numerator: numerator negated denominator: denominator!
reciprocal 
	"Refer to the comment in Number|reciprocal."

	numerator = 0 ifTrue: [self error: '0 has no reciprocal'].
	numerator = 1 ifTrue: [^denominator].
	numerator = -1 ifTrue: [^denominator negated].
	^Fraction numerator: denominator denominator: numerator! !

!Fraction methodsFor: 'comparing'!
< aFraction

	(aFraction isMemberOf: Fraction)
		ifTrue: [aFraction numerator = 0
				ifTrue: [^numerator < 0]
				ifFalse: [^self - aFraction < 0]]
		ifFalse: [^self retry: #< coercing: aFraction]!
= aFraction

	aFraction isNil ifTrue: [^false].
	(aFraction isMemberOf: Fraction)
		ifTrue: [aFraction numerator = 0
				ifTrue: [^numerator = 0]
				ifFalse: [^aFraction numerator = numerator 
							and: [aFraction denominator = denominator]]]
		ifFalse: [^self retry: #= coercing: aFraction]!
hash
	"Hash is reimplemented because = is implemented."

	^numerator bitXor: denominator! !

!Fraction methodsFor: 'truncation and round off'!
truncated 
	"Refer to the comment in Number|truncated."

	^numerator quo: denominator! !

!Fraction methodsFor: 'coercing'!
coerce: aNumber 
	"Refer to the comment in Number|coerce:."

	^aNumber asFraction!
generality 
	"Refer to the comment in Number|generality."

	^60! !

!Fraction methodsFor: 'converting'!
asFloat
	"Answer a Float that represents the same value as does the receiver."

	^numerator asFloat / denominator asFloat!
asFraction	
	"Answer the receiver itself."

	^self! !

!Fraction methodsFor: 'printing'!
printOn: aStream
	self asFloat printOn: aStream
	"aStream nextPut: $(.
	numerator printOn: aStream.
	aStream nextPut: $/.
	denominator printOn: aStream.
	aStream nextPut: $)"! !

!Fraction methodsFor: 'private'!
denominator

	^denominator!
numerator

	^numerator!
reduced

	| gcd numer denom |
	numerator = 0 ifTrue: [^0].
	gcd _ numerator gcd: denominator.
	numer _ numerator // gcd.
	denom _ denominator // gcd.
	denom = 1 ifTrue: [^numer].
	^Fraction numerator: numer denominator: denom!
setNumerator: n denominator: d

	d = 0
		ifTrue: [self error: 'denominator cannot be zero']
		ifFalse: 
			[numerator _ n asInteger.
			denominator _ d asInteger abs. "keep sign in numerator"
			d < 0 ifTrue: [numerator _ numerator negated]]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Fraction class
	instanceVariableNames: ''!

!Fraction class methodsFor: 'instance creation'!
numerator: numInteger denominator: denInteger 
	"Answer an instance of me (denInteger/numInteger)."

	^self new setNumerator: numInteger denominator: denInteger! !ListController subclass: #GeneralListController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!

!GeneralListController methodsFor: 'menu messages'!
aReadThis
	"When a list pane in a complex window has fairly simple action, you can use an instance of GeneralListController directly.  You don't need to make a separate class for your kind of list pane.
	The model makes and holds the YellowButtonMenu and the YellowButtonMessages and submits them to this instance using yellowButtonMenu: aSystemMenu yellowButtonMessages: anArray.  Having specialized menus is the usual reason for a new subclass for each pane.
	When the user clicks on a list item, redButtonActivity sends changeModelSelection: which sends toggleListIndex: to the model.
	"!
menuMessageReceiver
	"Send all menu messages to the model!!"
	^ model! !ListView subclass: #GeneralListView
	instanceVariableNames: 'controllerClass '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!

!GeneralListView methodsFor: 'everything'!
aReadThis
	"When a list pane in a complex window has fairl simple action, you can use an instance of GeneralListView directly.  You don't need to make a separate class for your kind of list pane.
	The usual reason for having a special class is to supply the default controller class.  Here we normally us GeneralListController.  However, the user can submit his own class to controllerClass: and use that."!
controllerClass: anObject
	controllerClass _ anObject!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	controllerClass == nil ifTrue: [self error: 'No one told me about my controller'].
	^controllerClass!
emphasizeView
	"Give the model a chance to update its parts"
	model changed: #emphasize.
! !OrderedCollection variableSubclass: #GraphicSymbol
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Symbols'!
GraphicSymbol comment:
'I represent a structured picture built from primitive display objects and other instances of me.'!

!GraphicSymbol methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the receiver on the Display where aTransformation is provided 
	as an argument, rule is anInteger and mask is aForm. No translation. 
	Information to be displayed must be confined to the area that intersects 
	with clipRect."

	self do: 
		[:element | 
		element
			displayOn: aDisplayMedium
			transformation: aTransformation
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the receiver where aTransformation is provided as an argument, 
	rule is anInteger and mask is aForm. No translation. Information to be 
	displayed must be confined to the area that intersects with clipRect."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !Object subclass: #GraphicSymbolInstance
	instanceVariableNames: 'transformation graphicSymbol '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Symbols'!
GraphicSymbolInstance comment:
'I represent a display transformation of a GraphicSymbol. Multiple copies of a GraphicSymbol can be displayed at different positions and scales on the screen by making appropriate, multiple, instances of me.'!

!GraphicSymbolInstance methodsFor: 'accessing'!
graphicSymbol
	"Answer the graphic symbol that the receiver displays."

	^graphicSymbol!
graphicSymbol: aGraphicSymbol 
	"Set the argument, aGraphicSymbol, to be the graphic symbol that the 
	receiver displays."

	graphicSymbol _ aGraphicSymbol! !

!GraphicSymbolInstance methodsFor: 'transforming'!
transformation
	"Answer the receiver's display transformation."

	^transformation!
transformation: aWindowingTransformation 
	"Set the argument, aWindowingTransformation, to be the receiver's 
	display transformation."

	transformation _ aWindowingTransformation! !

!GraphicSymbolInstance methodsFor: 'displaying'!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 
	"Display the graphic symbol on the Display according to the arguments 
	of this message."

	graphicSymbol
		displayOn: aDisplayMedium
		transformation: (aTransformation compose: transformation)
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm!
displayTransformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm
	"Display the graphic symbol according to the arguments of this message."

	self displayOn: Display transformation: aTransformation clippingBox: clipRect
		rule: anInteger fillColor: aForm! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

GraphicSymbolInstance class
	instanceVariableNames: ''!

!GraphicSymbolInstance class methodsFor: 'examples'!
example
	"Simply evaluate the method and two GraphicSymbolInstances, each
	displaying a transformation of the same graphic symbol, will be
	presented on the screen. Clears the screen to white."

	| gate instance1 instance2 trans1 trans2 line arc f|
	Display fillWhite.			"clear the Screen."
	f _ Form extent: 2@2.
	f fillBlack.
	gate_ GraphicSymbol new.		"make a logic gate out of lines and arcs."
	line_Line new.  line beginPoint: -20@-20.  line endPoint: 0@-20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: -20@20.  line endPoint: 0@20. line form: f.
	gate add: line.

	line_Line new.  line beginPoint: 0@-40.  line endPoint: 0@40. line form: f.
	gate add: line.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 1.
	arc form: f.
	gate add: arc.

	arc _ Arc new. arc center: 0@0 radius: 40 quadrant: 4.
	arc form: f.
	gate add: arc.

			"one instance at 1/2 scale."
	trans1_WindowingTransformation identity.	
	trans1_ trans1 scaleBy: 0.5@0.5.
	trans1_ trans1 translateBy: 100@100.

			"the other instance at 2 times scale"
	trans2_WindowingTransformation identity.	
	trans2_ trans2 scaleBy: 2.0@2.0.
	trans2_ trans2 translateBy: 200@200.

	instance1 _ GraphicSymbolInstance new.
	instance1 transformation: trans1.
	instance1 graphicSymbol: gate.

	instance2 _ GraphicSymbolInstance new.
	instance2 transformation: trans2.
	instance2 graphicSymbol: gate.

			"display both instances of the logic gate"
	instance1 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil.
	instance2 displayOn: Display
					transformation: WindowingTransformation identity
					clippingBox: Display boundingBox
					rule: Form under
					fillColor: nil

	"GraphicSymbolInstance example"! !SelectionMenu subclass: #HierarchicalMenu
	instanceVariableNames: 'deeperMenus '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!

!HierarchicalMenu methodsFor: 'deeper menu creation'!
deeperMenus: menuArray
	deeperMenus _ menuArray! !

!HierarchicalMenu methodsFor: 'marker management'!
manageMarker
	"startUp a deeper menu if the cursor goes out to the right"
	| aPoint |
	aPoint _ Sensor cursorPoint.
	(frame inside containsPoint: aPoint)
		ifTrue: [self markerOn: aPoint.  ^ selections at: selection].
	selection = 0 ifTrue: [^ nil].
	(aPoint x > frame inside right and: [(deeperMenus at: selection) notNil])
		ifTrue: [^ (deeperMenus at: selection) startUp].
	self markerOff.
	^ nil! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

HierarchicalMenu class
	instanceVariableNames: ''!
HierarchicalMenu class comment:
'Created by Dan Ingalls back in 1985-6, but not currently maintained or used.'!

!HierarchicalMenu class methodsFor: 'example'!
example  "HierarchicalMenu example"
	^ (HierarchicalMenu
		labelList: #('one' ('two...' 'buckle' 'my' 'shoe') 'three' ('four...' 'close' 'the' 'door'))
		selections: #('one' ('buckle' 'my' 'shoe') 'three' ('close' 'the' 'door')))
		startUpWithCaption: 'Give it a whirl'! !

!HierarchicalMenu class methodsFor: 'instance creation'!
labelList: labelList lines: lines selections: selections
	| topLabels topSelections deeperMenus item j |
	topLabels _ OrderedCollection new.
	topSelections _ OrderedCollection new.
	deeperMenus _ OrderedCollection new.
	j _ 0.
	1 to: labelList size do:
		[:i | item _ labelList at: i.
		(item isMemberOf: Array)
			ifTrue: [topLabels addLast: item first.
					deeperMenus addLast:
					(HierarchicalMenu labelList: (item copyFrom: 2 to: item size)
						selections: (selections at: i))]
			ifFalse: [topLabels addLast: item.
					deeperMenus addLast: nil].
		
		topSelections addLast: (selections at: i)].
	^ (super labelList: topLabels asArray lines: lines selections: topSelections asArray)
		deeperMenus: deeperMenus asArray! !StandardFileStream subclass: #HtmlFileStream
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: 'FilePool '
	category: 'System-Files'!

!HtmlFileStream methodsFor: 'as yet unclassified'!
aComment
	"This stream writes legal HTML.  Invoke it with:

((FileStream fileNamed: 'changes.html') asHtml) fileOutChanges

	Meant to masquerade as a StandardFileStream.  Use all the normal methods (for best looks, use method:, methodHeader:, methodBody:, for code).  Use verbatim: to put stuff directly.  Use command: to put out <br>, etc.  Command: it supplies the brackets <>, in normal streams it ignores the data, could be used to bold in Text by recognising 'b', '/b', etc.  Caller should use header and trailer."
	"Override nextPut and do the < > & character transformation.  nextPutAll: calls nextPut."

	"Reading expects HTML file and produces normal Smalltalk code."!
command: aString
	"Append HTML commands directly without translation.  Caller should not include < or >.  Note that font change info comes through here!!  4/5/96 tk"

	(aString includes: $<) ifTrue: [self error: 'Do not put < or > in arg'].
		"We do the wrapping with <> here!!  Don't put it in aString."
	^ self verbatim: '<', aString, '>'!
header
	"append the HTML header.  Be sure to call trailer after you put out the data.
	4/4/96 tk"
	| cr f |
	cr _ String with: Character cr.
	self command: 'HTML'; verbatim: cr.
	self command: 'HEAD'; verbatim: cr.
	self command: 'TITLE'.
	self nextPutAll: '"', self name, '"'.
	self command: '/TITLE'; verbatim: cr.
	self command: '/HEAD'; verbatim: cr.
	self command: 'BODY'; verbatim: cr.

	"Write out tab.gif because it is used when source code is written as html"
(StandardFileStream isAFileNamed: 'tab.gif') ifFalse: [
	f _ FileStream fileNamed: 'tab.gif'.
	f nextPutAll: 'GIF89a
ðÿÿÿ!!ù
,
@„�Y!!þclip2gif v.0.4 by Yves Piguet;'.
	f close].
!
nextChunk
	"Answer the contents of the receiver, up to the next terminator character (!!).  Imbedded terminators are doubled.  Undo and strip out all Html stuff in the stream and convert the characters back.  4/12/96 tk"
	| out char did rest |
	self skipSeparators.	"Absorb <...><...> also"
	out _ WriteStream on: (String new: 500).
	[self atEnd] whileFalse: [
		self peek = $< ifTrue: [self unCommand].	"Absorb <...><...>"
		(char _ self next) = $&
			ifTrue: [
				rest _ self upTo: $;.
				did _ out position.
				rest = 'lt' ifTrue: [out nextPut: $<].
				rest = 'gt' ifTrue: [out nextPut: $>].
				rest = 'amp' ifTrue: [out nextPut: $&].
				did = out position ifTrue: [
					self error: 'new HTML char encoding'.
					"Please add it to this code"]]
			ifFalse: [char = $!!	"terminator"
				ifTrue: [
					self peek = $!! ifFalse: [^ out contents].
					out nextPut: self next]	"pass on one $!!"
				ifFalse: [out nextPut: char]]
		].
	^ out contents!
nextPut: char
	"Put a character on the file, but translate it first. 4/6/96 tk"
	char = $< ifTrue: [^ super nextPutAll: '&lt;'].
	char = $> ifTrue: [^ super nextPutAll: '&gt;'].
	char = $& ifTrue: [^ super nextPutAll: '&amp;'].
	char asciiValue = 13 "return" ifTrue: [
			self command: 'br'].
	char = $	"tab" ifTrue: [self command: 'IMG SRC="tab.gif" ALT="    "'].
	^ super nextPut: char!
nextPutAll: aString
	"Write the whole string, translating as we go. 4/6/96 tk"
	"Slow, but faster than using aString asHtml?"

	aString do: [:each | self nextPut: each].!
skipSeparators
	"Bsides the normal spacers, also skip any <...>, html commands.
	4/12/96 tk"
	| did |
	[did _ self position.
		super skipSeparators.
		self unCommand.	"Absorb <...><...>"
		did = self position] whileFalse.	"until no change"
!
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.
!
verbatim: aString
	"Do not attempt to translate the characters.  Use this to override translation in nextPutAll:.  User may write HTML directly to the file with this."

	^ super nextPutAll: aString
	"very tricky!! depends on the fact that StandardFileStream nextPutAll: does not call nextPut, but does a direct write."! !Dictionary subclass: #IdentityDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Unordered'!

!IdentityDictionary methodsFor: 'private'!
scanFor: key from: start to: finish
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."

	| element |
	"this speeds up a common case: key is in the first slot"
	((element _ array at: start) == nil or: [element key == key])
		ifTrue: [ ^ start ].

	start + 1 to: finish do: [ :index |
		((element _ array at: index) == nil or: [element key == key])
			ifTrue: [ ^ index ].
	].
	^ 0! !SwitchController subclass: #IndicatorOnSwitchController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
IndicatorOnSwitchController comment:
'I am a SwitchController that keeps the view (typically a SwitchView) highlighted while the model (typically a Switch) carries out the selected behavior.'!

!IndicatorOnSwitchController methodsFor: 'basic control sequence'!
sendMessage 
	"Refer to the comment in SwitchController|sendMessage."

	arguments size = 0
		ifTrue: [view indicatorOnDuring: [model perform: selector]]
		ifFalse: [view indicatorOnDuring: 
					[model perform: selector withArguments: arguments]]! !DisplayObject subclass: #InfiniteForm
	instanceVariableNames: 'patternForm '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
InfiniteForm comment:
'I represent a Form obtained by replicating a pattern form indefinitely in all directions.'!

!InfiniteForm methodsFor: 'accessing'!
asForm
	^ patternForm!
offset 
	"Refer to the comment in DisplayObject|offset."

	^0 @ 0! !

!InfiniteForm methodsFor: 'displaying'!
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 |
	(patternForm class == Pattern)
		ifTrue:
			["Use patternForm as a mask for BitBlt"
			aDisplayMedium fill: clipRectangle 
				rule: ruleInteger fillColor: patternForm.
			^ self].
	(patternForm isKindOf: Form)
		ifFalse:
			["A Color-like thing.  Use patternForm as a mask for BitBlt"
			aDisplayMedium fill: clipRectangle 
				rule: ruleInteger fillColor: patternForm]
		ifTrue:
			["Do it iteratively"
			targetBox _ aDisplayMedium boundingBox intersect: clipRectangle.
			patternBox _ patternForm boundingBox.
			(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 |
					patternForm displayOn: aDisplayMedium
						at: x @ y
						clippingBox: clipRectangle
						rule: ruleInteger
						fillColor: aForm]]]!
displayOnPort: aPort at: aDisplayPoint
	"Only implemented for 16x16 patterns"
	aPort fill: aPort clipRect fillColor: patternForm rule: Form over! !

!InfiniteForm methodsFor: 'display box access'!
computeBoundingBox 
	"Refer to the comment in DisplayObject|computeBoundingBox."

	^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! !

!InfiniteForm methodsFor: 'private'!
form: aForm

	patternForm _ aForm! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InfiniteForm class
	instanceVariableNames: ''!

!InfiniteForm class methodsFor: 'instance creation'!
with: aForm 
	"Answer an instance of me whose pattern form is the argument, aForm."

	^self new form: aForm! !Object subclass: #InputSensor
	instanceVariableNames: ''
	classVariableNames: 'InterruptWatcherProcess InterruptSemaphore CurrentCursor '
	poolDictionaries: ''
	category: 'Kernel-Processes'!
InputSensor comment:
'I represent an interface to the user input devices. There is at least one instance of me named Sensor in the system.'!

!InputSensor methodsFor: 'keyboard'!
flushKeyboard
	"Remove all characters from the keyboard buffer."

	[self keyboardPressed]
		whileTrue: [self keyboard]!
kbdTest    "Sensor kbdTest"
	| char |
	[char = $x] whileFalse: 
		[[self keyboardPressed] whileFalse: [].
		char _ self characterForKeycode: self keyboard.
		char asciiValue printString , '  ' displayAt: 10@10]!
keyboard
	"Answer the next character from the keyboard."

	^ self characterForKeycode: self primKbdNext!
keyboardPeek
	"Answer the next character in the keyboard buffer without removing it, or nil if it is empty."

	^ self characterForKeycode: self primKbdPeek!
keyboardPressed
	"Answer true if keystrokes are available."

	^self primKbdPeek notNil! !

!InputSensor methodsFor: 'modifier keys'!
commandKeyPressed
	"Answer whether the command key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 64!
controlKeyPressed
	"Answer whether the control key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 16!
leftShiftDown
	"Answer whether the shift key on the keyboard is being held down. The name of this message is a throwback to the Alto, which had independent left and right shift keys."

	^ self primMouseButtons anyMask: 8!
optionKeyPressed
	"Answer whether the option key on the keyboard is being held down."

	^ self primMouseButtons anyMask: 32! !

!InputSensor methodsFor: 'mouse'!
anyButtonPressed
	"Answer whether a mouse button is being pressed."

	^self buttons > 0!
blueButtonPressed
	"Answer whether only the blue mouse button is being pressed."

	^self buttons = 1!
mousePoint
	"Answer a Point indicating the coordinates of the current mouse location."

	^self primMousePt!
noButtonPressed
	"Answer whether any mouse button is not being pressed."

	^self anyButtonPressed == false!
redButtonPressed
	"Answer whether only the red mouse button is being pressed."

	^self buttons = 4!
waitButton
	"Wait for the user to press any mouse button and then answer with the 
	current location of the cursor."

	[self anyButtonPressed] whileFalse.
	^self cursorPoint!
waitClickButton
	"Wait for the user to click (press and then release) any mouse button and 
	then answer with the current location of the cursor."

	self waitButton.
	^self waitNoButton!
waitNoButton
	"Wait for the user to release any mouse button and then answer with the 
	current location of the cursor."

	[self anyButtonPressed] whileTrue.
	^self cursorPoint!
yellowButtonPressed
	"Answer whether only the yellow mouse button is being pressed."

	^self buttons = 2! !

!InputSensor methodsFor: 'cursor'!
currentCursor
	"Answer the instance of Cursor currently displayed."

	^CurrentCursor!
currentCursor: newCursor 
	"Set newCursor to be the displayed Cursor form."

	CurrentCursor _ newCursor.
	Cursor currentCursor: CurrentCursor.!
cursorPoint
	"Answer a Point indicating the cursor location."

	^self mousePoint!
cursorPoint: aPoint 
	"Set aPoint to be the current cursor location."

	^self primCursorLocPut: aPoint! !

!InputSensor methodsFor: 'joystick'!
joystickButtons: index

	^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71f
	!
joystickOn: index

	^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) !!= 0
	!
joystickXY: index

	| inputWord x y |
	inputWord _ self primReadJoystick: index.
	x _ (inputWord bitAnd: 16r7ff) - 16r400.
	y _ ((inputWord bitShift: -11) bitAnd: 16r7ff) - 16r400.
	^ x@y
	!
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 asParagraph displayOn: f at: 10@10.
		f displayOn: Display at: 10@10.
	].
! !

!InputSensor methodsFor: 'user interrupts'!
installInterruptWatcher
	"Initialize the interrupt watcher process. Terminate the old process if any."
	"Sensor installInterruptWatcher"

	InterruptWatcherProcess == nil ifFalse: [InterruptWatcherProcess terminate].
	InterruptSemaphore _ Semaphore new.
	InterruptWatcherProcess _ [self userInterruptWatcher] newProcess.
	InterruptWatcherProcess priority: Processor lowIOPriority.
	InterruptWatcherProcess resume.
	self primInterruptSemaphore: InterruptSemaphore.!
setInterruptKey: anInteger
	"Register the given keycode as the user interrupt key."

	self primSetInterruptKey: anInteger.
!
userInterruptWatcher
	"Wait for user interrupts and open a notifier on the active process when one occurs."

	[true] whileTrue: [
		InterruptSemaphore wait.
		SoundPlayer shutDown.
		[ScheduledControllers interruptName: 'User Interrupt'] fork.
	].
! !

!InputSensor methodsFor: 'private'!
buttons

	^ self primMouseButtons bitAnd: 7!
characterForKeycode: keycode
	"Map the given keycode to a Smalltalk character object. Encoding:
		A keycode is 12 bits:   <4 modifer bits><8 bit ISO character>
		Modifier bits are:       <command><option><control><shift>"

	"NOTE: the command and option keys are specific to the Macintosh and may not have equivalents on other platforms."

	keycode = nil ifTrue: [ ^nil ].
	keycode class = Character ifTrue: [ ^keycode ].  "to smooth the transition!!"
	^ Character value: (keycode bitAnd: 16rFF)!
primCursorLocPut: aPoint
	"If the primitive fails, try again with a rounded point."

	<primitive: 91>
	^ self primCursorLocPutAgain: aPoint rounded!
primCursorLocPutAgain: aPoint
	"Do nothing if primitive is not implemented."

	<primitive: 91>
	^ self!
primInterruptSemaphore: aSemaphore 
	"Primitive. Install the argument as the semaphore to be signalled whenever the user presses the interrupt key. The semaphore will be signaled once each time the interrupt key is pressed."

	<primitive: 134>
	^self primitiveFailed!
primKbdNext
	<primitive: 108>
	^ nil!
primKbdPeek
	<primitive: 109>
	^ nil!
primMouseButtons
	<primitive: 107>
	^ 0!
primMousePt
	"Primitive. Poll the mouse to find out its position. Return a Point. Fail if
	event-driven tracking is used instead of polling. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 90>
	^ 0@0!
primReadJoystick: index
	"Return the joystick input word for the joystick with the given index in the range [1..16]. Returns zero if the index does not correspond to a currently installed joystick."

	<primitive: 146>
	^ 0

	!
primSetInterruptKey: anInteger
	"Primitive. Register the given keycode as the user interrupt key. The low byte of the keycode is the ISO character and its next four bits are the Smalltalk modifer bits <cmd><opt><ctrl><shift>."

	<primitive: 133>
	^self primitiveFailed! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InputSensor class
	instanceVariableNames: ''!

!InputSensor class methodsFor: 'public'!
default
	"Answer the default system InputSensor, Sensor."

	^ Sensor!
startUp
	
	self default installInterruptWatcher.! !Object subclass: #InputState
	instanceVariableNames: 'x y bitState lshiftState rshiftState ctrlState lockState metaState keyboardQueue deltaTime baseTime timeProtect redButtonQueue redButtonPollCnt '
	classVariableNames: 'RshiftKey InputProcess LshiftKey BitMin InputSemaphore BitMax MinPollCnt LockKey CtrlKey '
	poolDictionaries: ''
	category: 'Kernel-Processes'!
InputState comment:
'I represent the state of the user input devices.'!

!InputState methodsFor: 'initialize-release'!
install
	"Initialize and connect the receiver to the hardware. Terminate the old 
	input process if any."

	InputProcess == nil ifFalse: [InputProcess terminate].
	self initState.
	InputSemaphore _ Semaphore new.
	InputProcess _ [self run] newProcess.
	InputProcess priority: Processor lowIOPriority.
	InputProcess resume.
	self primInputSemaphore: InputSemaphore! !

!InputState methodsFor: 'keyboard'!
keyboardNext
	"Remove and answer the next key in the keyboard buffer."

	^keyboardQueue next!
keyboardPeek
	"Answer the next key in the keyboard buffer but do not remove it."

	^keyboardQueue peek!
leftShiftDown
	"Answer whether the left shift key is down."

	^lshiftState ~= 0! !

!InputState methodsFor: 'mouse'!
mouseButtons
	"Answer the status of the mouse buttons: an Integer between 0 and 7."

	"If queue has a new value and the front queue value has been polled enough, move on to the next mouse button movement.  Set a minimum number of times it must be polled before it will change." 
	(redButtonPollCnt _ redButtonPollCnt - 1) <= 0 ifTrue: [
		redButtonQueue size >= 2 ifTrue: [
				redButtonQueue removeFirst.  "remove old value"
				redButtonPollCnt _ MinPollCnt.
				bitState _ (bitState bitAnd: 8r376) bitOr: redButtonQueue first]
			ifFalse: [redButtonPollCnt _ -1.	"keep it pinned"]].
	^bitState bitAnd: 7!
mousePoint
	"Answer the coordinates of the mouse location."

	^self primMousePt! !

!InputState methodsFor: 'cursor'!
cursorPoint: aPoint 
	"Set the current cursor position to be aPoint.  But don't actually do it,
	since Macintosh cursors don't relocate too well."

	"self primCursorLocPut: aPoint.
	x _ aPoint x.
	y _ aPoint y"! !

!InputState methodsFor: 'time'!
currentTime
	"Answer the time on the system clock in milliseconds since midnight. "
	
	timeProtect critical: [deltaTime = 0
			ifFalse: 
				[baseTime _ baseTime + deltaTime.
				deltaTime _ 0]].
	^baseTime! !

!InputState methodsFor: 'private'!
bitState: mask incoming: value
	"Set bitState according to the incoming new value.  This covers the mouse buttons 1,2,4 and five keyset bits.  We queue up the red button bit, so that no mouse clicks are lost."
	mask = 1 ifFalse: ["yellow, blue, keyset"
		value = 1
			ifTrue: [bitState _ bitState bitOr: mask]
			ifFalse: [bitState _ bitState bitAnd: -1 - mask]]
	  ifTrue: ["Red button on mouse"
		"bitState must be always the same as the first value on the queue"
		redButtonQueue addLast: value.
		"poll the method mouseButtons will advance the queue"]!
initState

	timeProtect _ Semaphore forMutualExclusion.
	timeProtect critical: [deltaTime _ baseTime _ 0].
	x _ y _ 0.
	keyboardQueue _ SharedQueue new: 50.
	ctrlState _ lshiftState _ rshiftState _ lockState _ metaState _ 0.
	bitState _ 0.
	redButtonQueue _ OrderedCollection new: 20.
	redButtonPollCnt _ MinPollCnt.
	redButtonQueue add: (bitState bitAnd: 1).  "Must always agree"!
keyAt: index put: value

	| mask |
	index < 8r200
	  ifTrue:  "Not a potential special character"
		[value ~= 0 ifTrue:
			[(index = $. asciiValue and: [ctrlState ~= 0])
				ifTrue: [[ScheduledControllers interruptName: 'User Interrupt'] fork. ^self].
			"(index = $z asciiValue and: [ctrlState ~= 0])
				ifTrue: [ScheduledControllers scheduleFromKeyPress: ScheduledControllers bottomController.
						^ self].
			(index = $a asciiValue and: [ctrlState ~= 0])
				ifTrue: [ScheduledControllers scheduleFromKeyPress: ScheduledControllers penultimateController.
						^ self]."
			^keyboardQueue nextPut: (KeyboardEvent code: index meta: metaState)]]
	  ifFalse:
		[index = CtrlKey
		  ifTrue: [ctrlState _ value bitShift: 1]
		  ifFalse:
			[index = LshiftKey
			  ifTrue: [lshiftState _ value]
			  ifFalse:
				[index = RshiftKey
				  ifTrue: [rshiftState _ value]
				  ifFalse:
					[index = LockKey
					  ifTrue: [lockState _ value bitShift: 2]
					  ifFalse:
						[(index >= BitMin and: [index <= BitMax])
						  ifTrue:
							[mask _ 1 bitShift: index - BitMin.
							self bitState: mask incoming: value]
						  ifFalse:
							[value ~= 0 ifTrue:
								[keyboardQueue nextPut:
									(KeyboardEvent code: index meta: metaState)]]]]]].
		metaState _ (ctrlState bitOr: (lshiftState bitOr: rshiftState)) bitOr: lockState]!
nextEvent: type with: param
	"Process a single input event, aside from mouse X/Y.
	 2/8/96 sw: remove the hard-coded use of HFSMacVolume"

	| highTime lowTime |
	type = 0  "Delta time"
		ifTrue: 
			[timeProtect critical: [deltaTime _ deltaTime + param]]
		ifFalse:
			[type = 3	"Key down"
				ifTrue: [self keyAt: param put: 1]
				ifFalse:
					[type = 4	"Key up"
						ifTrue: [self keyAt: param put: 0]
						ifFalse:
							[type = 5	"Reset time"
								ifTrue:
									[InputSemaphore wait.
									highTime _ self primInputWord.
									InputSemaphore wait.
									lowTime _ self primInputWord.
									timeProtect critical:
										[baseTime _ (highTime bitShift: 16) + lowTime.
										 deltaTime _ 0]]
								ifFalse: [type = 7	"Diskette insert"
										ifTrue: ["[FileDirectory concreteFileDirectoryClass mount: param] forkAt: Processor userInterruptPriority"]
										ifFalse:
											[[Transcript show: 'Bad event type dectected in InputState nextEvent:with:'; cr] forkAt: Processor userInterruptPriority]]]]] !
primCursorLocPut: aPoint 
	"Primitive. Move the cursor to the screen location specified by the
	argument, aPoint. Fail if the argument is not a Point. Essential. See
	Object documentation whatIsAPrimitive."

	<primitive: 91>
	^self primCursorLocPutAgain: aPoint rounded!
primCursorLocPutAgain: aPoint 
	"Primitive. By this time, aPoint better be an integer or get out of here.
	See InputState|primCursorLocPut."

	<primitive: 91>
	^self primitiveFailed!
primInputSemaphore: aSemaphore 
	"Primitive. Install the argument, aSemaphore, as the object to be signalled
	whenever an input event occurs. The semaphore will be signaled once
	for every word placed in the input buffer by an I/O device. Fail if the
	argument is neither a Semaphore nor nil. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 93>
	^self primitiveFailed!
primInputWord
	"Primitive. Return the next word from the input buffer and remove the
	word from the buffer. This message should be sent just after the input
	semaphore finished a wait (was sent a signal by an I/O device). Fail if
	the input buffer is empty. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 95>
	^self primitiveFailed!
primMousePt
	"Primitive. Poll the mouse to find out its position. Answer a Point. Fail if
	event-driven tracking is used instead of polling. Optional. See Object
	documentation whatIsAPrimitive."

	<primitive: 90>
	^x @ y!
primSampleInterval: anInteger 
	"Primitive. Set the minimum time span between event driven mouse
	position samples. The argument, anInteger, is a number of milliseconds.
	Fail if the argument is not a SmallInteger. Essential. See Object
	documentation whatIsAPrimitive."

	<primitive: 94>
	^self primitiveFailed!
run
	"This is the loop that actually processes input events."

	| word type param |
	[true]
		whileTrue: 
			[InputSemaphore wait.
			"Test for mouse X/Y events here to avoid an activation."
			word _ self primInputWord.
			type _ word bitShift: -12.
			param _ word bitAnd: 4095.
			type = 1
				ifTrue: 
					[x _ param "Mouse X"]
				ifFalse: 
					[type = 2
						ifTrue: [y _ param "Mouse Y"]
						ifFalse: [self nextEvent: type with: param]]]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InputState class
	instanceVariableNames: ''!

!InputState class methodsFor: 'class initialization'!
initialize
	"Define parameters."

	BitMin _ 8r200.  "Min mouse/keyset bit code"
	BitMax _ 8r207.  "Max mouse/keyset bit code"
	LshiftKey _ 8r210.
	RshiftKey _ 8r211.
	CtrlKey _ 8r212.
	LockKey _ 8r213.
	MinPollCnt _ 3.

	"InputState initialize"!
process
	^ InputProcess!
semaphore
	^ InputSemaphore! !

InputState initialize!
StringHolderController subclass: #InspectCodeController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectCodeController comment:
'I am a kind of StringHolderController (a ParagraphEditor that adds the doIt, printIt, accept, and cancel commands). I modify the response to accept by treating the text in the view as an expression to be evaluated. The result of the evaluation is stored as the value of the model"s currently selected variable.'!

!InspectCodeController methodsFor: 'menu messages'!
accept

	| result |
	(model isUnlocked or: [model selectionUnmodifiable])
		ifTrue: [^view flash].
	self controlTerminate.
	result _ model doItReceiver class evaluatorClass new
				evaluate: (ReadStream on: paragraph string)
				in: model doItContext
				to: model doItReceiver
				notifying: self
				ifFail:  [self controlInitialize. ^nil].
	result == #failedDoit
		ifFalse: 
			[model replaceSelectionValue: result.
			self selectFrom: 1 to: paragraph text size.
			self deselect.
			self replaceSelectionWith: result printString asText.
			self selectAt: 1.
			super accept].
	self controlInitialize! !StringHolderView subclass: #InspectCodeView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectCodeView comment:
'I am a StringHolderView of the value of the selected variable of the object observed by an Inspector. InspectCodeController is my default controller.'!

!InspectCodeView methodsFor: 'controller access'!
defaultControllerClass

	^InspectCodeController! !BrowserListController subclass: #InspectListController
	instanceVariableNames: ''
	classVariableNames: 'InspectListYellowButtonMenu InspectListYellowButtonMessages '
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectListController comment:
'I am a kind of LockedListController for the listView of an InspectorView that creates a yellow button menu so that messages can be sent to the list selection (an object) to create and schedule an InspectView on it.'!

!InspectListController methodsFor: 'initialize-release'!
initialize

	super initialize.
	self initializeYellowButtonMenu! !

!InspectListController methodsFor: 'menu messages'!
browseClass
	"Create and schedule a class browser on the class of the current inspected.  1/25/96 sw"

	self controlTerminate.
	Browser newOnClass: self classOfSelection theNonMetaClass.
	self controlInitialize!
browseFull
	"Create and schedule a full Browser and then select the class of the master object being inspected.  1/25/96 sw"

	BrowserView browseFullForClass: self classOfSelection method: nil from: self!
classOfSelection
	"Answer the class of the receiver's current selection.  1/25/96 sw"

	model selectionUnmodifiable ifTrue: [^ model object class].
	^ model selection class!
inspectSelection
	"Create and schedule an Inspector on the receiver's model's currently 
	selected object."

	model selectionIndex = 0
		ifTrue: [^view flash].
	self controlTerminate.
	^model selection inspect!
referencesToSelection
	"Open a browser on all references to the selected instance variable, if that's what currently selected.  1/25/96 sw"

	| aClass sel |

	model selectionUnmodifiable ifTrue: [^ view flash].
	(aClass _ model object class) isVariable ifTrue: [^ view flash].
	self controlTerminate.

	sel _ aClass allInstVarNames at: model selectionIndex - 2.
	aClass browseAllAccessesTo: sel! !

!InspectListController methodsFor: 'private'!
changeModelSelection: anInteger 
	model toggleIndex: anInteger!
initializeYellowButtonMenu

	self 
		yellowButtonMenu: InspectListYellowButtonMenu
		yellowButtonMessages: InspectListYellowButtonMessages! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InspectListController class
	instanceVariableNames: ''!

!InspectListController class methodsFor: 'class initialization'!
initialize
	"1/25/96 sw: added references and browse items."

	InspectListYellowButtonMenu _ PopUpMenu labels: 'inspect
references
browse full
browse class'
	lines: #(1 2).
	InspectListYellowButtonMessages _ 
		#(inspectSelection referencesToSelection browseFull browseClass )

	"InspectListController initialize"! !

InspectListController initialize!
ListView subclass: #InspectListView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectListView comment:
'I am a ListView whose items are the instance variables of the object observed by the Inspect that I view. InspectListController is my default controller.'!

!InspectListView methodsFor: 'updating'!
update: aSymbol

	aSymbol == #inspectObject
		ifTrue: 
			[self list: model fieldList.
			selection _ model selectionIndex.
			self displayView].
	aSymbol == #selection ifTrue: [self moveSelectionBox: model selectionIndex]! !

!InspectListView methodsFor: 'controller access'!
defaultControllerClass

	^InspectListController! !

!InspectListView methodsFor: 'model access'!
model: anInspector

	super model: anInspector.
	self list: model fieldList.
	selection _ model selectionIndex! !StringHolder subclass: #Inspector
	instanceVariableNames: 'object selectionIndex '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
Inspector comment:
'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'!
baseFieldList
	"Answer an Array consisting of 'self'
	and the instance variable names of the inspected object."

	^ (Array with: 'self' with: 'all inst vars')
			, object class allInstVarNames!
fieldList
	"Answer the base field list plus an abbreviated list of indices."

	object class isVariable ifFalse: [^ self baseFieldList].
	^ self baseFieldList ,
		(object basicSize <= (self i1 + self i2)
			ifTrue: [(1 to: object basicSize)
						collect: [:i | i printString]]
			ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize)
						collect: [:i | i printString]])!
i1
	"This is the max index shown before skipping to the 
	last i2 elements of very long arrays"
	^ 100!
i2
	"This is the number of elements to show at the end
	of very long arrays"
	^ 10!
inspect: anObject 
	"Initialize the receiver so that it is inspecting anObject. There is no 
	current selection."

	self initialize.
	object _ anObject.
	selectionIndex _ 0.
	contents _ ''!
object
	"Answer the object being inspected by the receiver."

	^object!
object: anObject 
	"Set anObject to be the object being inspected by the receiver."

	anObject == object
		ifTrue: [self update]
		ifFalse:
			[self inspect: anObject.
			self changed: #inspectObject]!
update
	"Reshow contents, assuming selected value may have changed."

	selectionIndex = 0
		ifFalse:
			[contents _ self selection printString.
			self changed: #selection]! !

!Inspector methodsFor: 'selecting'!
replaceSelectionValue: anObject 
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. The value of the selected variable is set to the value, 
	anObject."
	| basicIndex |
	selectionIndex = 1 ifTrue: [^ object].
	object class isVariable
		ifFalse: [^ object instVarAt: selectionIndex - 2 put: anObject].
	basicIndex _ selectionIndex - 2 - object class instSize.
	(object basicSize <= (self i1 + self i2)  or: [basicIndex <= self i1])
		ifTrue: [^object basicAt: basicIndex put: anObject]
		ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex
					put: anObject]!
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 = 1 ifTrue: [^ object].
	selectionIndex = 2 ifTrue: [^ object longPrintString].
	(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]!
selectionIndex
	"The receiver has a list of variables of its inspected object. One of these 
	is selected. Answer the index into the list of the selected variable."

	^selectionIndex!
selectionUnmodifiable
	"Answer if the current selected variable is modifiable via acceptance in the code pane.  For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable"

	^ selectionIndex <= 2!
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.
			contents _ self selection printString].
	self changed: #selection.! !

!Inspector methodsFor: 'code'!
doItReceiver
	"Answer the object that should be informed of the result of evaluating a
	text selection."

	^object! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Inspector class
	instanceVariableNames: ''!

!Inspector class methodsFor: 'instance creation'!
inspect: anObject 
	"Answer an instance of me to provide an inspector for anObject."

	^self new inspect: anObject! !StringHolder subclass: #InspectorTrash
	instanceVariableNames: 'inspectedObject '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectorTrash comment:
'This is here only to allow the trash area at the bottom of an inspector.  It is basically a StringHolder except that it knows what about the object being inspect and so can accept doIt and printIt with that object as the receiver.'!

!InspectorTrash methodsFor: 'code'!
doItReceiver
	^ inspectedObject!
inspectedObject
	^ inspectedObject!
inspectedObject: io
	inspectedObject _ io! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InspectorTrash class
	instanceVariableNames: ''!

!InspectorTrash class methodsFor: 'instance creation'!
for: x
	^ self new inspectedObject: x! !StandardSystemView subclass: #InspectorView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Inspector'!
InspectorView comment:
'I am a StandardSystemView that provides initialization methods (messages to myself) to create and schedule the interface to an object Inspector. I have two subViews, an InspectListView and an InspectCodeView.'!

!InspectorView methodsFor: 'miscellaneous'!
initialExtent
	"Answer the desired extent for the receiver when it is first opened on the screen.  5/22/96 sw"

	^ 250 @ 200! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InspectorView class
	instanceVariableNames: ''!

!InspectorView class methodsFor: 'instance creation'!
dictionaryInspector: anInspector 
	"Answer an instance of me on the model, anInspector. The instance 
	consists of an InspectListView and an InspectCodeView."

	| anInspectorView anInspectorListView aCodeView |
	anInspectorView _ View new.
		anInspectorView model: anInspector.
		anInspectorListView _ InspectListView new.
		anInspectorListView model: anInspector;
				controller: DictionaryListController new.
		anInspectorListView window: (0 @ 0 extent: 40 @ 40).
		anInspectorListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	anInspectorView addSubView: anInspectorListView.
	aCodeView _ self buildCodeView: anInspector.
	anInspectorView
		addSubView: aCodeView
		align: aCodeView viewport topLeft
		with: anInspectorListView viewport topRight.
	^anInspectorView!
formDictionaryInspector: anInspector 
	"Answer an instance of me on the model, anInspector. The instance 
	consists of an InspectListView and an InspectFormView  6/28/96 sw."

	| anInspectorView anInspectorListView aFormView |
	anInspectorView _ View new.
		anInspectorView model: anInspector.
		anInspectorListView _ InspectListView new.
		anInspectorListView model: anInspector;
				controller: DictionaryListController new.
		anInspectorListView window: (0 @ 0 extent: 40 @ 40).
		anInspectorListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.
	anInspectorView addSubView: anInspectorListView.
	aFormView _ self buildFormView: anInspector.
	anInspectorView
		addSubView: aFormView
		align: aFormView viewport topLeft
		with: anInspectorListView viewport topRight.
	^anInspectorView!
inspector: anInspector 
	"Answer an instance of me on the model, anInspector. The instance 
	consists of an InspectListView and an InspectCodeView."

	| anInspectorView anInspectorListView aCodeView |
	anInspectorView _ View new.
	anInspectorView model: anInspector.
	anInspectorListView _ self buildInspectListView: anInspector.
	anInspectorView addSubView: anInspectorListView.
	aCodeView _ self buildCodeView: anInspector.
	anInspectorView
		addSubView: aCodeView
		align: aCodeView viewport topLeft
		with: anInspectorListView viewport topRight.
	^anInspectorView!
inspectorWithTrash: anInspector 
	"Create an inspector with an extra 'trash' view at the bottom,
	where you can type expressions that don't interfere with
	inspecting the various selectable fields."

	| inspectorView aTrashView threeView |
	threeView _ View new model: anInspector object.
	inspectorView _ self inspector: anInspector.
	threeView addSubView: inspectorView.
	aTrashView _ self buildTrashView: anInspector.
	threeView
		addSubView: aTrashView
		align: aTrashView viewport topLeft
		with: inspectorView viewport bottomLeft.
	^ threeView!
open: anInspectView
	"Create and schedule an instance of me on the model, anInspector. "
	self open: anInspectView withLabel: anInspectView model class name!
open: anInspectView withLabel: aLabel
	"Create and schedule an instance of me on the model, anInspector. "
	| topView |
	topView _ self new.
	topView addSubView: anInspectView.
	topView label: aLabel.
	topView minimumSize: 180 @ 120.
	topView controller open! !

!InspectorView class methodsFor: 'private'!
buildCodeView: anInspector
	| inspectCodeView |

	inspectCodeView _ InspectCodeView new.
	inspectCodeView model: anInspector.
	inspectCodeView window: (0 @ 0 extent: 75 @ 40).
	inspectCodeView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	^ inspectCodeView!
buildFormView: anInspector
	"Build a view which will show a form in the right side of the Inspector.   6/28/96 sw"

	| inspectFormView |

	inspectFormView _ FormInspectView new.
	inspectFormView model: anInspector.
	inspectFormView window: (0 @ 0 extent: 75 @ 40).
	inspectFormView borderWidthLeft: 2 right: 2 top: 2 bottom: 2.
	^ inspectFormView!
buildInspectListView: anInspector

	| anInspectListView |

	anInspectListView _ InspectListView new.
	anInspectListView model: anInspector.
	anInspectListView window: (0 @ 0 extent: 40 @ 40).
	anInspectListView borderWidthLeft: 2 right: 0 top: 2 bottom: 2.

	^ anInspectListView!
buildScheduledView: anInspector
	"This is old code referred to in benchmarks - may be deleted"
	| anInspectorView topView |
	anInspectorView _ self inspector: anInspector.
	topView _ StandardSystemView new.
	topView model: anInspector.
	topView addSubView: anInspectorView.
	topView label: anInspector object class name.
	topView minimumSize: 180 @ 120.
	^topView!
buildTrashView: anInspector
	| inspectTrashView |

	inspectTrashView _ StringHolderView new.
	inspectTrashView model: (InspectorTrash for: anInspector object).
	inspectTrashView controller turnLockingOff.
	inspectTrashView window: (0 @ 0 extent: 115 @ 20).
	inspectTrashView borderWidthLeft: 2 right: 2 top: 0 bottom: 2.

	^ inspectTrashView! !InstructionStream subclass: #InstructionPrinter
	instanceVariableNames: 'stream oldPC '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Methods'!
InstructionPrinter comment:
'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.'!

!InstructionPrinter methodsFor: 'initialize-release'!
printInstructionsOn: aStream 
	"Append to the stream, aStream, a description of each bytecode in the 
	instruction stream."
	
	| end |
	stream _ aStream.
	end _ self method endPC.
	oldPC _ pc.
	[pc <= end]
		whileTrue: [super interpretNextInstructionFor: self]! !

!InstructionPrinter methodsFor: 'instruction decoding'!
blockReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'blockReturn'!
doDup
	"Print the Duplicate Top Of Stack bytecode."

	self print: 'dup'!
doPop
	"Print the Remove Top Of Stack bytecode."

	self print: 'pop'!
jump: offset
	"Print the Unconditional Jump bytecode."

	self print: 'jumpTo: ' , (pc + offset) printString!
jump: offset if: condition 
	"Print the Conditional Jump bytecode."

	self print: 
		(condition
			ifTrue: ['jumpTrue: ']
			ifFalse: ['jumpFalse: '])
			, (pc + offset) printString!
methodReturnConstant: value 
	"Print the Return Constant bytecode."

	self print: 'return: ' , value printString!
methodReturnReceiver
	"Print the Return Self bytecode."

	self print: 'returnSelf'!
methodReturnTop
	"Print the Return Top Of Stack bytecode."

	self print: 'returnTop'!
popIntoLiteralVariable: anAssociation 
	"Print the Remove Top Of Stack And Store Into Literal Variable bytecode."

	self print: 'popIntoLit: ' , anAssociation key!
popIntoReceiverVariable: offset 
	"Print the Remove Top Of Stack And Store Into Instance Variable 
	bytecode."

	self print: 'popIntoRcvr: ' , offset printString!
popIntoTemporaryVariable: offset 
	"Print the Remove Top Of Stack And Store Into Temporary Variable 
	bytecode."

	self print: 'popIntoTemp: ' , offset printString!
pushActiveContext
	"Print the Push Active Context On Top Of Its Own Stack bytecode."

	self print: 'pushThisContext: '!
pushConstant: value
	"Print the Push Constant, value, on Top Of Stack bytecode."

	self print: 'pushConstant: ' , value printString!
pushLiteralVariable: anAssociation
	"Print the Push Contents Of anAssociation On Top Of Stack bytecode."

	self print: 'pushLit: ' , anAssociation key!
pushReceiver
	"Print the Push Active Context's Receiver on Top Of Stack bytecode."

	self print: 'self'!
pushReceiverVariable: offset
	"Print the Push Contents Of the Receiver's Instance Variable Whose Index 
	is the argument, offset, On Top Of Stack bytecode."

	self print: 'pushRcvr: ' , offset printString!
pushTemporaryVariable: offset
	"Print the Push Contents Of Temporary Variable Whose Index Is the 
	argument, offset, On Top Of Stack bytecode."

	self print: 'pushTemp: ' , offset printString!
send: selector super: supered numArgs: numberArguments
	"Print the Send Message With Selector, selector, bytecode. The argument, 
	supered, indicates whether the receiver of the message is specified with 
	'super' in the source method. The arguments of the message are found in 
	the top numArguments locations on the stack and the receiver just 
	below them."

	self print: (supered ifTrue: ['superSend: '] ifFalse: ['send: ']) , selector!
storeIntoLiteralVariable: anAssociation 
	"Print the Store Top Of Stack Into Literal Variable Of Method bytecode."

	self print: 'storeIntoLit: ' , anAssociation key!
storeIntoReceiverVariable: offset 
	"Print the Store Top Of Stack Into Instance Variable Of Method bytecode."

	self print: 'storeIntoRcvr: ' , offset printString!
storeIntoTemporaryVariable: offset 
	"Print the Store Top Of Stack Into Temporary Variable Of Method 
	bytecode."

	self print: 'storeIntoTemp: ' , offset printString! !

!InstructionPrinter methodsFor: 'printing'!
print: instruction 
	"Append to the receiver a description of the bytecode, instruction." 

	| code |
	stream print: oldPC; space.
	stream nextPut: $<.
	oldPC to: pc - 1 do: 
		[:i | 
		code _ (self method at: i) radix: 16.
		stream nextPut: 
			(code size < 5
				ifTrue: [$0]
				ifFalse: [code at: 4]).
		stream nextPut: code last; space].
	stream skip: -1.
	stream nextPut: $>.
	stream space.
	stream nextPutAll: instruction.
	stream cr.
	oldPC _ pc
	"(InstructionPrinter compiledMethodAt: #print:) symbolic."
! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InstructionPrinter class
	instanceVariableNames: ''!

!InstructionPrinter class methodsFor: 'printing'!
printClass: class 
	"Create a file whose name is the argument followed by '.bytes'. Store on 
	the file the symbolic form of the compiled methods of the class."
	| file |
	file _ FileStream newFileNamed: class name , '.bytes'.
	class selectors do: 
		[:sel | 
		file cr; nextPutAll: sel; cr.
		(self on: (class compiledMethodAt: sel)) printInstructionsOn: file].
	file close
	"InstructionPrinter printClass: Parser."
! !Object subclass: #InstructionStream
	instanceVariableNames: 'sender pc '
	classVariableNames: 'SpecialConstants '
	poolDictionaries: ''
	category: 'Kernel-Methods'!
InstructionStream comment:
'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'!
willJumpIfFalse
	"Answer whether the next bytecode is a jump-if-false."

	| byte |
	byte _ self method at: pc.
	^(byte between: 152 and: 159) or: [byte between: 172 and: 175]!
willReturn
	"Answer whether the next bytecode is a return."

	^(self method at: pc) between: 120 and: 125!
willSend
	"Answer whether the next bytecode is a message-send."

	| byte |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^false].
	byte >= 176 ifTrue: [^true].	"special send or short send"
	^byte between: 131 and: 134	"long sends"!
willStorePop
	"Answer whether the next bytecode is a store-pop."

	| byte |
	byte _ self method at: pc.
	^byte = 130 or: [byte between: 96 and: 111]! !

!InstructionStream methodsFor: 'decoding'!
interpretJump

	| byte |
	byte _ self method at: pc.
	(byte between: 144 and: 151) ifTrue:
		[pc _ pc + 1. ^byte - 143].
	(byte between: 160 and: 167) ifTrue:
		[pc _ pc + 2. ^(byte - 164) * 256 + (self method at: pc - 1)].
	^nil!
interpretNextInstructionFor: client 
	"Send to the argument, client, a message that specifies the type of the 
	next instruction."

	| byte type offset method |
	method _ self method.  
	byte _ method at: pc.
	type _ byte // 16.  
	offset _ byte \\ 16.  
	pc _ pc+1.
	type=0 ifTrue: [^client pushReceiverVariable: offset].
	type=1 ifTrue: [^client pushTemporaryVariable: offset].
	type=2 ifTrue: [^client pushConstant: (method literalAt: offset+1)].
	type=3 ifTrue: [^client pushConstant: (method literalAt: offset+17)].
	type=4 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+1)].
	type=5 ifTrue: [^client pushLiteralVariable: (method literalAt: offset+17)].
	type=6 
		ifTrue: [offset<8
					ifTrue: [^client popIntoReceiverVariable: offset]
					ifFalse: [^client popIntoTemporaryVariable: offset-8]].
	type=7
		ifTrue: [offset=0 ifTrue: [^client pushReceiver].
				offset<8 ifTrue: [^client pushConstant: (SpecialConstants at: offset)].
				offset=8 ifTrue: [^client methodReturnReceiver].
				offset<12 ifTrue: [^client methodReturnConstant: 
												(SpecialConstants at: offset-8)].
				offset=12 ifTrue: [^client methodReturnTop].
				offset=13 ifTrue: [^client blockReturnTop].
				offset>13 ifTrue: [^self error: 'unusedBytecode']].
	type=8 ifTrue: [^self interpretExtension: offset in: method for: client].
	type=9
		ifTrue:  "short jumps"
			[offset<8 ifTrue: [^client jump: offset+1].
			^client jump: offset-8+1 if: false].
	type=10 
		ifTrue:  "long jumps"
			[byte_ method at: pc.  pc_ pc+1.
			offset<8 ifTrue: [^client jump: offset-4*256 + byte].
			^client jump: (offset bitAnd: 3)*256 + byte if: offset<12].
	type=11 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+1) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+1)].
	type=12 
		ifTrue: 
			[^client 
				send: (Smalltalk specialSelectorAt: offset+17) 
				super: false
				numArgs: (Smalltalk specialNargsAt: offset+17)].
	type>12
		ifTrue: 
			[^client send: (method literalAt: offset+1) 
					super: false
					numArgs: type-13]! !

!InstructionStream methodsFor: 'scanning'!
addSelectorTo: set 
	"If this instruction is a send, add its selector to set."

	| byte literalNumber |
	byte _ self method at: pc.
	byte < 128 ifTrue: [^self].
	byte >= 176
		ifTrue: 
			["special byte or short send"
			byte >= 208
				ifTrue: [set add: (self method literalAt: (byte bitAnd: 15) + 1)]
				ifFalse: [set add: (Smalltalk specialSelectorAt: byte - 176 + 1)]]
		ifFalse: 
			[(byte between: 131 and: 134)
				ifTrue: 
					[literalNumber _ byte odd
								ifTrue: [(self method at: pc + 1) \\ 32]
								ifFalse: [self method at: pc + 2].
					set add: (self method literalAt: literalNumber + 1)]]!
followingByte
	"Answer the next bytecode."

	^self method at: pc + 1!
method
	"Answer the compiled method that supplies the receiver's bytecodes."

	^sender		"method access when used alone (not as part of a context)"!
nextByte
	"Answer the next bytecode."

	^self method at: pc!
pc
	"Answer the index of the next bytecode."

	^pc!
scanFor: scanBlock 
	"Answer the index of the first bytecode for which scanBlock answer true 
	when supplied with that bytecode."

	| method end byte type |
	method _ self method.
	end _ method endPC.
	[pc <= end]
		whileTrue: 
			[(scanBlock value: (byte _ method at: pc)) ifTrue: [^true].
			type _ byte // 16.
			pc _ 
				type = 8
					ifTrue: ["extensions"
							pc + (#(2 2 2 2 3 2 3 1 1 1 ) at: byte \\ 16 + 1)]
					ifFalse: [type = 10
								ifTrue: [pc + 2"long jumps"]
								ifFalse: [pc + 1]]].
	^false! !

!InstructionStream methodsFor: 'private'!
interpretExtension: offset in: method for: client

	| numberArguments literalNumber type offset2 |
	"pc has already been incremented by 1"
	offset < 3
		ifTrue: 
			["extended pushes and pops"
			type _ (method at: pc) // 64.
			offset2 _ (method at: pc) \\ 64.
			pc _ pc + 1.
			offset = 0
				ifTrue: 
					[type = 0 ifTrue: [^client pushReceiverVariable: offset2].
					type = 1 ifTrue: [^client pushTemporaryVariable: offset2].
					type = 2 
						ifTrue: [^client pushConstant: (method literalAt: offset2 + 1)].
					type = 3
						ifTrue: [^client pushLiteralVariable: 
									(method literalAt: offset2 + 1)]].
			offset = 1
				ifTrue: 
					[type = 0 ifTrue: [^client storeIntoReceiverVariable: offset2].
					type = 1 ifTrue: [^client storeIntoTemporaryVariable: offset2].
					type = 2 ifTrue: [self error: 'illegalStore'].
					type = 3 
						ifTrue: [^client storeIntoLiteralVariable: 
									(method literalAt: offset2 + 1)]].
			offset = 2
				ifTrue: 
					[type = 0 ifTrue: [^client popIntoReceiverVariable: offset2].
					type = 1 ifTrue: [^client popIntoTemporaryVariable: offset2].
					type = 2 ifTrue: [self error: 'illegalStore'].
					type = 3 
						ifTrue: [^client popIntoLiteralVariable: 
									(method literalAt: offset2 + 1)]]].
	offset < 7
		ifTrue: 
			["extended sends"
			offset odd
				ifTrue: 
					[numberArguments _ (method at: pc) // 32.
					literalNumber _ (method at: pc) \\ 32.
					pc _ pc + 1]
				ifFalse: 
					[numberArguments _ method at: pc.
					literalNumber _ method at: pc + 1.
					pc _ pc + 2].
			^client
				send: (method literalAt: literalNumber + 1)
				super: offset > 4
				numArgs: numberArguments].
	offset = 7 ifTrue: [^client doPop].
	offset = 8 ifTrue: [^client doDup].
	offset = 9 ifTrue: [^client pushActiveContext].
	self error: 'unusedBytecode'!
method: method pc: startpc

	sender _ method. 
	"allows this class to stand alone as a method scanner"
	pc _ startpc! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

InstructionStream class
	instanceVariableNames: ''!

!InstructionStream class methodsFor: 'class initialization'!
initialize
	"Initialize an array of special constants returned by single-bytecode returns."

	SpecialConstants _ 
		(Array with: true with: false with: nil)
			, (Array with: -1 with: 0 with: 1 with: 2)	
	"InstructionStream initialize."
! !

!InstructionStream class methodsFor: 'instance creation'!
on: method 
	"Answer an instance of me on the argument, method."

	^self new method: method pc: method initialPC! !

InstructionStream initialize!
Number subclass: #Integer
	instanceVariableNames: ''
	classVariableNames: 'SinArray '
	poolDictionaries: ''
	category: 'Numeric-Numbers'!
Integer 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'!

!Integer methodsFor: 'testing'!
benchmark "Time millisecondsToRun: [10 benchmark]
	11950 (AST 1.0 3/31 on 8100 (arith & spl prims in primary dispatch)
	15100 (AST 1.0 3/20 on 8100 (checkProcessSwitch out of inner loop)
	17033 (AST 1.0 3/15 on 8100)
	35483 (AST 1.0 3/1 on 8100)
	4110 (PPS interpreter on 8100)
	10880 (APDA interpreter on Duo)"
    | size flags i prime k count iter |
    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!
even 
	"Refer to the comment in Number|even."

	^((self digitAt: 1) bitAnd: 1) = 0!
isInteger
	"True for all subclasses of Integer."

	^ true!
isPowerOfTwo
	^ (self bitAnd: self-1) = 0! !

!Integer methodsFor: 'arithmetic'!
* aNumber
	"Refer to the comment in Number * " 
	aNumber isInteger
		ifTrue: [^ self digitMultiply: aNumber 
					neg: self negative ~~ aNumber negative]
		ifFalse: [^self retry: #* coercing: aNumber]!
+ aNumber
	"Refer to the comment in Number + "
	(aNumber isInteger)
		ifTrue: [self negative == aNumber negative
					ifTrue: [^(self digitAdd: aNumber) normalize]
					ifFalse: [^self digitSubtract: aNumber]]
		ifFalse: [^self retry: #+ coercing: aNumber]!
- aNumber
	"Refer to the comment in Number - "
	(aNumber isInteger)
		ifTrue: [self negative == aNumber negative
					ifTrue: [^ self digitSubtract: aNumber]
					ifFalse: [^ (self digitAdd: aNumber) normalize]]
		ifFalse: [^self retry: #- coercing: aNumber]!
/ aNumber
	"Refer to the comment in Number / "
	| quoRem |
	(aNumber isInteger)
		ifTrue: 
			[quoRem _ self digitDiv: aNumber 
							neg: self negative ~~ aNumber negative.
			(quoRem at: 2) = 0
				ifTrue: [^(quoRem at: 1) normalize]
				ifFalse: [^(Fraction numerator: self denominator: aNumber) reduced]]
		ifFalse: [^self retry: #/ coercing: aNumber]!
// 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]!
alignedTo: anInteger
	"Answer the smallest number not less than receiver that is a multiple of anInteger."

	^(self+anInteger-1//anInteger)*anInteger

"5 alignedTo: 2"
"12 alignedTo: 3"!
quo: aNumber 
	"Refer to the comment in Number quo: "
	| ng quo |
	(aNumber isInteger)
		ifTrue: 
			[ng _ self negative == aNumber negative == false.
			quo _ (self digitDiv: aNumber neg: ng) at: 1.
			^ quo normalize]
		ifFalse: [^self retry: #quo: coercing: aNumber]! !

!Integer methodsFor: 'comparing'!
< anInteger
	(anInteger isInteger)
		ifTrue: [self negative == anInteger negative
					ifTrue: [self negative
								ifTrue: [^(self digitCompare: anInteger) > 0]
								ifFalse: [^(self digitCompare: anInteger) < 0]]
					ifFalse: [^self negative]]
		ifFalse: [^self retry: #< coercing: anInteger]!
= arg
	arg isNumber
		ifFalse: [^ false].
	arg isInteger
		ifTrue: [arg negative == self negative
					ifTrue: [^ (self digitCompare: arg) = 0]
					ifFalse: [^ false]]
		ifFalse: [^ self retry: #= coercing: arg]!
> anInteger
	(anInteger isInteger)
		ifTrue: [self negative == anInteger negative
					ifTrue: [self negative
								ifTrue: [^(self digitCompare: anInteger) < 0]
								ifFalse: [^(self digitCompare: anInteger) > 0]]
					ifFalse: [^anInteger negative]]
		ifFalse: [^self retry: #> coercing: anInteger]!
hash
	"Hash is reimplemented because = is implemented."

	^(self lastDigit bitShift: 8) + (self digitAt: 1)! !

!Integer methodsFor: 'truncation and round off'!
atRandom
	"Return a random integer from 1 to self.  Heavy users should use Interval atRandom or atRandom: directly."
	^ (1 to: self) atRandom!
ceiling 
	"Refer to the comment in Number|ceiling."!
floor 
	"Refer to the comment in Number|floor."!
normalize 
	"SmallInts OK; LgInts override"
	^ self!
rounded 
	"Refer to the comment in Number|rounded."!
truncated 
	"Refer to the comment in Number|truncated."! !

!Integer 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]! !

!Integer methodsFor: 'mathematical functions'!
degreeCos
	"Return the cosine of self as an angle in degrees"
	^ (90 + self) degreeSin!
degreeSin
	"Return the sine of self as an angle in degrees"
	self < 0 ifTrue: [^ 0.0 - (0 - self) degreeSin].
	self > 360 ifTrue: [^ (self \\ 360) degreeSin].
	self > 180 ifTrue: [^ 0.0 - (self - 180) degreeSin].
	self > 90 ifTrue: [^ (180 - self) degreeSin].
	" now 0<= self <= 90 "
	^ SinArray at: self+1!
factorial
	"Answer the factorial of the receiver. Create an error notification if the 
	receiver is less than 0."

	self = 0 ifTrue: [^1].
	self < 0
		ifTrue: [self error: 'factorial invalid for: ' , self printString]
		ifFalse: [^self * (self - 1) factorial]!
gcd: anInteger 
	"Answer the greatest common divisor of the receiver and n. Uses Roland 
	Silver's algorithm (see Knuth, Vol. 2)."

	| m n d t |
	m _ self abs max: anInteger abs.
	n _ self abs min: anInteger abs.
	m \\ n = 0 ifTrue: [^n].
	"easy test, speeds up rest"
	d _ 0.
	[n even and: [m even]]
		whileTrue: 
			[d _ d + 1.
			n _ n bitShift: -1.
			m _ m bitShift: -1].
	[n even]
		whileTrue: [n _ n bitShift: -1].
	[m even]
		whileTrue: [m _ m bitShift: -1].
	[m = n]
		whileFalse: 
			[m > n
				ifTrue: 
					[m _ m - n]
				ifFalse: 
					[t _ m.
					m _ n - m.
					n _ t].
			"Make sure larger gets replaced"
			[m even]
				whileTrue: [m _ m bitShift: -1]].
	d = 0 ifTrue: [^m].
	^m bitShift: d!
lcm: n 
	"Answer the least common multiple of the receiver and n."

	^self // (self gcd: n) * n! !

!Integer methodsFor: 'bit manipulation'!
<< shiftAmount  "left shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: shiftAmount!
>> shiftAmount  "left shift"
	shiftAmount < 0 ifTrue: [self error: 'negative arg'].
	^ self bitShift: 0 - shiftAmount!
allMask: mask 
	"Treat the argument as a bit mask. Answer whether all of the bits that 
	are 1 in the argument are 1 in the receiver."

	^mask = (self bitAnd: mask)!
anyMask: mask 
	"Treat the argument as a bit mask. Answer whether any of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 ~= (self bitAnd: mask)!
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)!
bitInvert32
	"Answer the 32-bit complement of the receiver."

	^ self bitXor: 16rFFFFFFFF!
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)!
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!
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)!
highBit
	"Answer the index of the high order bit of this number."
	| realLength lastDigit |
	realLength _ self digitLength.
	[(lastDigit _ self digitAt: realLength) = 0]
		whileTrue:
		[(realLength _ realLength - 1) = 0 ifTrue: [^ 0]].
	^ lastDigit highBit + (8 * (realLength - 1))!
noMask: mask 
	"Treat the argument as a bit mask. Answer whether none of the bits that 
	are 1 in the argument are 1 in the receiver."

	^0 = (self bitAnd: mask)! !

!Integer methodsFor: 'converting'!
asCharacter
	"Answer the Character whose value is the receiver."

	^Character value: self!
asFloat
	"Answer a Float that represents the value of the receiver."

	| factor sum |
	sum _ 0.0.
	factor _ self sign asFloat.
	1 to: self size do: 
		[:i | 
		sum _ (self digitAt: i) * factor + sum.
		factor _ factor * 256.0].
	^sum!
asFraction
	"Answer a Fraction that represents value of the the receiver."

	^Fraction numerator: self denominator: 1!
asInteger
	"Answer with the receiver itself."

	^self

! !

!Integer methodsFor: 'coercing'!
coerce: aNumber 
	"Refer to the comment in Number|coerce:."

	^ aNumber asInteger!
coerceToPoint
	"Coerce the receiver into a point by taking the high order part as the vertical coordinate and the low order part as the horizontal coordinate.  The part divisin is at 65536."

	| x y |
	x _ self bitAnd: 16rFFFF.
	y _ self bitShift: -16.
	(x >= 16r8000) ifTrue: [ x _ x - 16r10000 ].
	(y >= 16r8000) ifTrue: [ y _ y - 16r10000 ].
	^ Point x: x y: y
!
generality 
	"Refer to the comment in Number|generality."

	^40! !

!Integer methodsFor: 'printing'!
asStringWithCommas  "123456789 asStringWithCommas"
	| digits |
	digits _ self abs printString.
	^ String streamContents:
		[:strm | 1 to: digits size do: 
			[:i | strm nextPut: (digits at: i).
			(i < digits size and: [(i - digits size) \\ 3 = 0])
				ifTrue: [strm nextPut: $,]]]!
hex
	^ self printStringBase: 16!
hex8  "16r3333 hex8"
	| hex |
	hex _ self hex.  "16rNNN"
	hex size < 11
		ifTrue: [^ hex copyReplaceFrom: 4 to: 3
						 with: ('00000000' copyFrom: 1 to: 11-hex size)]
		ifFalse: [^ hex]!
isLiteral

	^true!
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: [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]!
radix: radix 
	"Answer a String representing the receiver as a base radix integer."

	^ self printStringBase: radix! !

!Integer methodsFor: 'system primitives'!
lastDigit
	"Answer the last digit of the integer."

	^self digitAt: self digitLength!
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]! !

!Integer methodsFor: 'private'!
copyto: x
	| stop |
	stop _ self digitLength min: x digitLength.
	^ x replaceFrom: 1 to: stop with: self startingAt: 1!
digitAdd: arg
	| len arglen accum sum |
	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!
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!
digitDiv: arg neg: ng 
	"Answer with an array of (quotient, remainder)."
	| quo rem ql d div dh dnh dl qhi qlo i j k l hi lo r3 a t |
	l _ self digitLength - arg digitLength + 1.
	l <= 0 ifTrue: [^Array with: 0 with: self].
	d _ 8 - arg lastDigit highBit.
	div _ arg digitLshift: d.  div _ div growto: div digitLength + 1.
	"shifts so high order word is >=128"
	rem _ self digitLshift: d.
	rem digitLength = self digitLength ifTrue:
		[rem _ rem growto: self digitLength + 1].
	"makes a copy and shifts"
	quo _ Integer new: l neg: ng.
	dl _ div digitLength - 1.
	"Last actual byte of data"
	ql _ l.
	dh _ div digitAt: dl.
	dnh _
		 dl = 1
			ifTrue: [0]
			ifFalse: [div digitAt: dl - 1].
	1 to: ql do: 
		[:k | 
		"maintain quo*arg+rem=self"
		"Estimate rem/div by dividing the leading to bytes of rem by dh."
		"The estimate is q = qhi*16+qlo, where qhi and qlo are nibbles."
		j _ rem digitLength + 1 - k.
		"r1 _ rem digitAt: j."
		(rem digitAt: j) = dh
			ifTrue: [qhi _ qlo _ 15"i.e. q=255"]
			ifFalse: 
				["Compute q = (r1,r2)//dh, t = (r1,r2)\\dh.  
				Note that r1,r2 are bytes, not nibbles.  
				Be careful not to generate intermediate results exceeding 13 bits."
				"r2 _ (rem digitAt: j - 1)."
				t _ ((rem digitAt: j) bitShift: 4) + ((rem digitAt: j - 1) bitShift: -4).
				qhi _ t // dh.
				t _ (t \\ dh bitShift: 4) + ((rem digitAt: j - 1) bitAnd: 15).
				qlo _ t // dh.
				t _ t \\ dh.
				"Next compute (hi,lo) _ q*dnh"
				hi _ qhi * dnh.
				lo _ qlo * dnh + ((hi bitAnd: 15) bitShift: 4).
				hi _ (hi bitShift: -4) + (lo bitShift: -8).
				lo _ lo bitAnd: 255.
				"Correct overestimate of q.  
				Max of 2 iterations through loop -- see Knuth vol. 2"
				r3 _ 
					j < 3 ifTrue: [0]
						 ifFalse: [rem digitAt: j - 2].
				[(t < hi or: [t = hi and: [r3 < lo]]) and: 
						["i.e. (t,r3) < (hi,lo)"
						qlo _ qlo - 1.
						lo _ lo - dnh.
						lo < 0
							ifTrue: 
								[hi _ hi - 1.
								lo _ lo + 256].
						hi >= dh]]
					whileTrue: [hi _ hi - dh].
				qlo < 0
					ifTrue: 
						[qhi _ qhi - 1.
						qlo _ qlo + 16]].
		"Subtract q*div from rem"
		l _ j - dl.
		a _ 0.
		1 to: div digitLength do: 
			[:i | 
			hi _ (div digitAt: i) * qhi.
			lo _ 
				a + (rem digitAt: l) 
					- ((hi bitAnd: 15) bitShift: 4) 
					- ((div digitAt: i) * qlo).
			rem digitAt: l put: (lo bitAnd: 255).
			a _ (lo bitShift: -8) - (hi bitShift: -4).
			l _ l + 1].
		a < 0
			ifTrue: 
				["Add div back into rem, decrease q by 1"
				qlo _ qlo - 1.
				l _ j - dl.
				a _ 0.
				1 to: div digitLength do: 
					[:i | 
					a _ (a bitShift: -8) + (rem digitAt: l) + (div digitAt: i).
					rem digitAt: l put: (a bitAnd: 255).
					l _ l + 1]].
		quo digitAt: quo digitLength + 1 - k put: (qhi bitShift: 4) + qlo].
	rem _ rem digitRshift: d bytes: 0 lookfirst: dl.
	^Array with: quo with: rem!
digitLogic: arg op: op length: len
	| result i neg1 neg2 rneg z1 z2 rz b1 b2 b |
	neg1 _ self negative.
	neg2 _ arg negative.
	rneg _ 
		((neg1 ifTrue: [-1] ifFalse: [0])
			perform: op 
			with: (neg2
					ifTrue: [-1]
					ifFalse: [0])) < 0.
	result _ Integer new: len neg: rneg.
	rz _ z1 _ z2 _ true.
	1 to: result digitLength do: 
		[:i | 
		b1 _ self digitAt: i.
		neg1 
			ifTrue: [b1 _ z1
						ifTrue: [b1 = 0
									ifTrue: [0]
									ifFalse: 
										[z1 _ false.
										256 - b1]]
						ifFalse: [255 - b1]].
		b2 _ arg digitAt: i.
		neg2 
			ifTrue: [b2 _ z2
						ifTrue: [b2 = 0
									ifTrue: [0]
									ifFalse: 
										[z2 _ false.
										256 - b2]]
						ifFalse: [255 - b2]].
		b _ b1 perform: op with: b2.
		b = 0
			ifTrue: 
				[result digitAt: i put: 0]
			ifFalse: 
				[result 
					digitAt: i 
					put: (rneg
							ifTrue: [rz ifTrue: 
											[rz _ false.
											256 - b]
										ifFalse: [255 - b]]
						ifFalse: [b])]].
	^ result normalize!
digitLshift: shiftCount
	| carry rShift mask len result digit byteShift bitShift highBit |
	(highBit _ self highBit) = 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!
digitMultiply: arg neg: ng
	| prod prodLen carry digit i j k ab |
	(arg digitLength = 1 and: [(arg digitAt: 1) = 0]) ifTrue: [^0].
	prodLen _ self digitLength + arg digitLength.
	prod _ Integer new: prodLen neg: ng.
	"prod starts out all zero"
	1 to: self digitLength do: 
		[:i | 
		(digit _ self digitAt: i) ~= 0
			ifTrue: 
				[k _ i.
				carry _ 0.
				"Loop invariant: 0<=carry<=0377, k=i+j-1"
				1 to: arg digitLength do: 
					[:j | 
					ab _ ((arg digitAt: j) * digit) + carry
							+ (prod digitAt: k).
					carry _ ab bitShift: -8.
					prod digitAt: k put: (ab bitAnd: 255).
					k _ k + 1].
				prod digitAt: k put: carry]].
	^ prod normalize!
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 i r f m digit count |
	n _ 0 - anInteger.
	x _ 0.
	f _ n + 8.
	i _ a.
	m _ 255 bitShift: 0 - f.
	digit _ self digitAt: i.
	[((digit bitShift: n) bitOr: x) = 0 and: [i ~= 1]] whileTrue:
		[x _ digit bitShift: f "Can't exceed 8 bits".
		i _ i - 1.
		digit _ self digitAt: i].
	i <= b ifTrue: [^Integer new: 0 neg: self negative].  "All bits lost"
	r _ Integer new: i - b neg: self negative.
	count _ i.
	x _ (self digitAt: b + 1) bitShift: n.
	b + 1 to: count do:
		[:i | digit _ self digitAt: i + 1.
		r digitAt: i - b put: (((digit bitAnd: m) bitShift: f) bitOr: x) 
			"Avoid values > 8 bits".
		x _ digit bitShift: n].
	^r!
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 _ 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 bitAnd: 255).
		z _ z bitShift: -8].
	^ sum normalize!
growby: n

	^self growto: self digitLength + n!
growto: n

	^self copyto: (self species new: n)! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Integer class
	instanceVariableNames: ''!

!Integer class methodsFor: 'instance creation'!
byte1: byte1 byte2: byte2 byte3: byte3 byte4: byte4 
	"Depending on high-order byte copy directly into a LargeInteger,
	or build up a SmallInteger by shifting"
	| value |
	byte4 < 16r20 ifTrue:
		[^ (byte4 bitShift: 24)
		 + (byte3 bitShift: 16)
		 + (byte2 bitShift: 8)
		 + byte1].
	value _ LargePositiveInteger new: 4.
	value digitAt: 4 put: byte4.
	value digitAt: 3 put: byte3.
	value digitAt: 2 put: byte2.
	value digitAt: 1 put: byte1.
	^ value!
new: length neg: neg
	"Answer an instance of a large integer whose size is length. neg is a flag 
	determining whether the integer is negative or not."

	neg 
		ifTrue: [^LargeNegativeInteger new: length]
		ifFalse: [^LargePositiveInteger new: length]!
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!
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! !

!Integer class methodsFor: 'initialization'!
initialize  "Integer initialize"
	SinArray _ (0 to: 90) collect: [:x | x asFloat degreesToRadians sin].
	"Return integral values for 90-degree multiples"
	SinArray at: 1 put: 0.
	SinArray at: 91 put: 1! !

Integer initialize!
SequenceableCollection subclass: #Interval
	instanceVariableNames: 'start stop step '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
Interval comment:
'I represent a finite arithmetic progression.'!

!Interval methodsFor: 'accessing'!
at: anInteger 
	"Answer the anInteger'th element."

	(anInteger >= 1 and: [anInteger <= self size])
		ifTrue: [^start + (step * (anInteger - 1))]
		ifFalse: [self errorSubscriptBounds: anInteger]!
at: anInteger put: anObject 
	"Storing into an Interval is not allowed."

	self error: 'you can not store into an interval'!
atPin: anInteger 
	"Answer the anInteger'th element.  Return first or last if out of bounds.  6/18/96 tk"

anInteger >= 1
	ifTrue: [anInteger <= self size
		ifTrue: [^start + (step * (anInteger - 1))]
		ifFalse: [^ self last]]
	ifFalse: [^ self first]!
atWrap: anInteger 
	"Answer the anInteger'th element.  If index is out of bounds, let it wrap around from the end to the beginning unil it is in bounds.  6/18/96 tk"

^ self at: (anInteger - self increment \\ self size + self increment)!
first 
	"Refer to the comment in SequenceableCollection|first."

	^start!
increment
	"Answer the receiver's interval increment."

	^step!
last 
	"Refer to the comment in SequenceableCollection|last."

	^stop - (stop - start \\ step)!
size

	step < 0
		ifTrue: [start < stop
				ifTrue: [^0]
				ifFalse: [^stop - start // step + 1]]
		ifFalse: [stop < start
				ifTrue: [^0]
				ifFalse: [^stop - start // step + 1]]! !

!Interval 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]!
hash
	"Hash is reimplemented because = is implemented."

	^(((start hash bitShift: 2)
		bitOr: stop hash)
		bitShift: 1)
		bitOr: self size!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!Interval methodsFor: 'adding'!
add: newObject 
	"Adding to an Interval is not allowed."

	self shouldNotImplement! !

!Interval methodsFor: 'removing'!
remove: newObject 
	"Removing from an Interval is not allowed."

	self error: 'elements cannot be removed from an Interval'! !

!Interval methodsFor: 'copying'!
copy
	"Return a copy of me. Override the superclass because my species is
	Array and copy, as inherited from SequenceableCollection, uses
	copyFrom:to:, which creates a new object of my species."

	^self shallowCopy! !

!Interval 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!
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]]!
reverseDo: aBlock 
	"Evaluate aBlock for each element of my interval, in reverse order."

	| aValue |
	aValue _ stop.
	step < 0
		ifTrue: [[start >= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]
		ifFalse: [[start <= aValue]
				whileTrue: 
					[aBlock value: aValue.
					aValue _ aValue - step]]! !

!Interval 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: $)!
storeOn: aStream 
	"This is possible because we know numbers store and print the same."

	self printOn: aStream! !

!Interval methodsFor: 'private'!
setFrom: startInteger to: stopInteger by: stepInteger

	start _ startInteger.
	stop _ stopInteger.
	step _ stepInteger!
species

	^Array! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Interval class
	instanceVariableNames: ''!

!Interval class methodsFor: 'instance creation'!
from: startInteger to: stopInteger 
	"Answer an instance of me, starting at startNumber, ending at 
	stopNumber, and with an interval increment of 1."

	^self new
		setFrom: startInteger
		to: stopInteger
		by: 1!
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 new
		setFrom: startInteger
		to: stopInteger
		by: stepInteger!
new
	"Primitive. Create and answer with a new instance of the receiver
	(a class) with no indexable fields. Fail if the class is indexable. Override
	SequenceableCollection new. Essential. See Object documentation
	whatIsAPrimitive."

	<primitive: 70>
	self isVariable ifTrue: [ ^ self new: 0 ].
	"space must be low"
	Smalltalk signalLowSpace.
	^ self new  "retry if user proceeds"
!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	| newInterval |
	newInterval _ self from: aCollection first to: aCollection last by:
		(aCollection last - aCollection first)//(aCollection size - 1).
	aCollection ~= newInterval
		ifTrue: [self error: 'The argument is not an arithmetic progression'].
	^newInterval

"	Interval newFrom: {1. 2. 3}
	{33. 5. -23} as: Interval
	{33. 5. -22} as: Interval    (an error)
	(-4 to: -12 by: -1) as: Interval
"! !Array variableSubclass: #IOWeakArray
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Object Storage'!

!IOWeakArray methodsFor: 'as yet unclassified'!
storeDataOn: aDataStream
    "Store myself on a DataStream. Answer self. Since I'm an IOWeakArray, use
     nextPutWeak: to write out my contents.
     This is a low-level DataStream/ReferenceStream method. See also
     objectToStoreOnDataStream.
     NOTE: This method must send 'aDataStream beginInstance:size:'
        and then put a number of objects (via aDataStream nextPut:/nextPutWeak:).
     Cf. readDataFrom:size:, which must read back what this puts
        when given the size that it gave to beginInstance:size:. -- 11/15/92 jhm
     ISSUE: Should this use nextPut: or nextPutWeak: to write any named instance
        variables? I don't yet have any, so it's moot for now."
    | cntInstVars cntIndexedVars |

    cntInstVars _ self class instSize.
    cntIndexedVars _ self basicSize.
    aDataStream
        beginInstance: self class
        size: cntInstVars + cntIndexedVars.
    1 to: cntInstVars do:
        [:i | aDataStream nextPut: (self instVarAt: i)].
    1 to: cntIndexedVars do:
        [:i | aDataStream nextPutWeak: (self basicAt: i)]! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

IOWeakArray class
	instanceVariableNames: ''!

!IOWeakArray class methodsFor: 'imported from V'!
classComment
"An IOWeakArray is like an Array except that it acts like a weak object (holds weak
pointers) on a ReferenceStream.

In an objectToStoreOnDataStream (externalize) method, putting some objects into an
IOWeakArray is a practical way to write them via ReferenceStream>>nextPutWeak:.
    -- 11/15/92 jhm
"! !Object subclass: #KeyboardEvent
	instanceVariableNames: 'keyCharacter metaState '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Kernel-Processes'!
KeyboardEvent comment:
'I represent a keyboard event consisting of a non-meta key being struck plus the state of the meta keys at that moment. Only InputState creates instances of me.'!

!KeyboardEvent methodsFor: 'accessing'!
keyCharacter
	"Answer the keyboard character of the receiver."

	^keyCharacter!
metaState
	"Answer the state of the special keyboard characters: control, shift, lock."

	^metaState! !

!KeyboardEvent methodsFor: 'testing'!
hasCtrl
	"Answer whether a control key was pressed."

	^metaState anyMask: 2!
hasLock
	"Answer whether the shift key is locked."

	^metaState anyMask: 4!
hasShift
	"Answer whether a shift key was pressed."

	^metaState anyMask: 1! !

!KeyboardEvent methodsFor: 'private'!
key: anInteger meta: meta

	keyCharacter _ anInteger asCharacter.
	metaState _ meta! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

KeyboardEvent class
	instanceVariableNames: ''!

!KeyboardEvent class methodsFor: 'instance creation'!
code: code meta: meta 
	"Answer an instance of me, with code the regular key and meta the 
	special keys: control, shift, lock."

	^ self new key: code meta: meta! !LargePositiveInteger variableByteSubclass: #LargeNegativeInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!

!LargeNegativeInteger methodsFor: 'arithmetic'!
abs
	^ self negated!
negated
	^ self copyto: (LargePositiveInteger new: self digitLength)! !

!LargeNegativeInteger methodsFor: 'converting'!
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 _ 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]! !

!LargeNegativeInteger methodsFor: 'testing'!
negative
	^ true!
positive
	^ false! !

!LargeNegativeInteger methodsFor: 'printing'!
printOn: aStream base: b 
	"Refer to the comment in Integer|printOn:base:."

	aStream nextPut: $-.
	super printOn: aStream base: b! !Integer variableByteSubclass: #LargePositiveInteger
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Numbers'!
LargePositiveInteger comment:
'I represent a positive large integer, integers greater than 16383.'!

!LargePositiveInteger methodsFor: 'arithmetic'!
* anInteger 
	"Primitive. Multiply the receiver by the argument and answer with an
	Integer result. Fail if either the argument or the result is not a
	SmallInteger or a LargePositiveInteger less than 65536. Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 29>
	^super * anInteger!
+ 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 65536. Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 21>
	^super + anInteger!
- 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 65536. Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 22>
	^super - anInteger!
/ 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 65536. Optional. See
	Object documentation whatIsAPrimitive. "

	<primitive: 30>
	^super / anInteger!
// 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 65536.
	Optional. See Object documentation whatIsAPrimitive. "

	<primitive: 32>
	^super // anInteger!
abs!
negated 
	^ (self copyto: (LargeNegativeInteger new: self digitLength))
		normalize  "Need to normalize to catch SmallInteger minVal"!
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 65536. Optional. See
	Object documentation whatIsAPrimitive."

	<primitive: 33>
	^super quo: anInteger!
\\ 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
	65536. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 31>
	^super \\ anInteger! !

!LargePositiveInteger 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!
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!
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!
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! !

!LargePositiveInteger methodsFor: 'testing'!
negative

	^false!
positive

	^true! !

!LargePositiveInteger methodsFor: 'comparing'!
< anInteger 
	"Primitive. Compare the receiver with the argument and answer true if
	the receiver is less than the argument. Otherwise answer false. Fail if the
	argument is not a SmallInteger or a LargePositiveInteger less than 65536.
	Optional. See Object documentation whatIsAPrimitive."

	<primitive: 23>
	^super < anInteger!
<= 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 65536. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 25>
	^super <= anInteger!
= 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!
> 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
	65536. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 24>
	^super > anInteger!
>= 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 65536. Optional. See Object documentation whatIsAPrimitive."

	<primitive: 26>
	^super >= anInteger!
~= 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! !

!LargePositiveInteger methodsFor: 'converting'!
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 _ 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'!
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]!
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!
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!
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! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

LargePositiveInteger class
	instanceVariableNames: ''!
LargePositiveInteger class comment:
'My instances represent integers beyond the range of SmallInteger, encoded as an array of 8-bit digits.  Care must be taken, when new results are computed, that any value that COULD BE a SmallInteger IS a SmallInteger (see normalize).  Several algorithms here were written for a SmallInteger range of 15 bits or less, and should be updated to take advantage of the current 31-bit range.'!

!LargePositiveInteger class methodsFor: 'testing'!
test: n  "Time millisecondsToRun: [LargePositiveInteger test: 100] 1916"
	| f f1 |
	"Test and time mult, div, add, subtract"
	f _ n factorial.
	f1 _ f*(n+1).
	n timesRepeat: [f1 _ f1 - f].
	f1 = f ifFalse: [self halt].
	n timesRepeat: [f1 _ f1 + f].
	f1 // f = (n+1) ifFalse: [self halt].
	f1 negated = (Number readFrom: '-' , f1 printString) ifFalse: [self halt].

	"Check normalization and conversion to/from SmallInts"
	(SmallInteger maxVal + 1 - 1) == SmallInteger maxVal ifFalse: [self halt].
	(SmallInteger maxVal + 3 - 6) == (SmallInteger maxVal-3) ifFalse: [self halt].
	(SmallInteger minVal - 1 + 1) == SmallInteger minVal ifFalse: [self halt].
	(SmallInteger minVal - 3 + 6) == (SmallInteger minVal+3) ifFalse: [self halt].

	"Check bitShift from and back to SmallInts"
	1 to: 257 do: [:i | ((i bitShift: i) bitShift: 0-i) == i ifFalse: [self halt]].
! !ParseNode subclass: #LeafNode
	instanceVariableNames: 'key code '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
LeafNode comment:
'I represent a leaf node of the compiler parse tree. I am abstract.
	
Types (defined in class ParseNode):
	1 LdInstType (which uses class VariableNode)
	2 LdTempType (which uses class VariableNode)
	3 LdLitType (which uses class LiteralNode)
	4 LdLitIndType (which uses class VariableNode)
	5 SendType (which uses class SelectorNode)'!

!LeafNode methodsFor: 'initialize-release'!
key: object code: byte

	key _ object.
	code _ byte!
key: object index: i type: type

	self key: object code: (self code: i type: type)!
name: ignored key: object code: byte

	key _ object.
	code _ byte!
name: literal key: object index: i type: type

	self key: object
		index: i
		type: type! !

!LeafNode methodsFor: 'accessing'!
key

	^key! !

!LeafNode methodsFor: 'code generation'!
code

	^code!
emitForEffect: stack on: strm

	^self!
emitLong: mode on: aStream 
	"Emit extended variable access."
	| type index |
	code < 256
		ifTrue: [code < 16
				ifTrue: 
					[type _ 0.
					index _ code]
				ifFalse: 
					[code < 32
						ifTrue: 
							[type _ 1.
							index _ code - 16]
						ifFalse: 
							[code < 96
								ifTrue: 
									[type _ code // 32 + 1.
									index _ code \\ 32]
								ifFalse: [self error: 
										'Sends should be handled in SelectorNode']]]]
		ifFalse: 
			[index _ code \\ 256.
			type _ code // 256 - 1].
	aStream nextPut: mode.
	aStream nextPut: type * 64 + index!
reserve: encoder 
	"If this is a yet unused literal of type -code, reserve it."

	code < 0 ifTrue: [code _ self code: (encoder litIndex: key) type: 0 - code]!
sizeForEffect: encoder

	^0!
sizeForValue: encoder

	self reserve: encoder.
	code < 256 
		ifTrue: [^1].
	^2! !

!LeafNode methodsFor: 'private'!
code: index type: type

	index isNil 
		ifTrue: [^type negated].
	(CodeLimits at: type) > index 
		ifTrue: [^(CodeBases at: type) + index].
	^type * 256 + index! !Path subclass: #Line
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
Line comment:
'I represent the line segment specified by two points.'!

!Line methodsFor: 'accessing'!
beginPoint
	"Answer the first end point of the receiver."

	^self first!
beginPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 1 put: aPoint.
	^aPoint!
endPoint
	"Answer the last end point of the receiver."

	^self last!
endPoint: aPoint 
	"Set the first end point of the receiver to be the argument, aPoint. 
	Answer aPoint."

	self at: 2 put: aPoint.
	^aPoint! !

!Line methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm 
	"The form associated with this Path will be displayed, according  
	to one of the sixteen functions of two logical variables (rule), at  
	each point on the Line. Also the source form will be first anded  
	with aForm as a mask. Does not effect the state of the Path."

	collectionOfPoints size < 2 ifTrue: [self error: 'a line must have two points'].
	aDisplayMedium
		drawLine: self form
		from: self beginPoint + aPoint
		to: self endPoint + aPoint
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm

	| newPath newLine |
	newPath _ aTransformation applyTo: self.
	newLine _ Line new.
	newLine beginPoint: newPath firstPoint.
	newLine endPoint: newPath secondPoint.
	newLine form: self form.
	newLine
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm!
displayOnPort: aPort at: aPoint 
	aPort sourceForm: self form; combinationRule: Form under; fillColor: nil.
	aPort drawFrom: collectionOfPoints first + aPoint
		to: collectionOfPoints last + aPoint! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Line class
	instanceVariableNames: ''!

!Line class methodsFor: 'instance creation'!
from: beginPoint to: endPoint withForm: aForm 
	"Answer an instance of me with end points begingPoint and endPoint; 
	the source form for displaying the line is aForm."

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: beginPoint.
	newSelf add: endPoint.
	newSelf form: aForm.
	^newSelf!
new

	| newSelf | 
	newSelf _ super new: 2.
	newSelf add: 0@0.
	newSelf add: 0@0.
	^newSelf! !

!Line class methodsFor: 'examples'!
example
	"Designate two places on the screen by clicking any mouse button. A
	straight path with a square black form will be displayed connecting the
	two selected points."

	| aLine aForm |  
	aForm _ Form extent: 20@20.		"make a form one quarter of inch square"
	aForm fillBlack.							"turn it black"
	aLine _ Line new.
	aLine form: aForm.						"use the black form for display"
	aLine beginPoint: Sensor waitButton. Sensor waitNoButton.
	aForm displayOn: Display at: aLine beginPoint.	
	aLine endPoint: Sensor waitButton.
	aLine displayOn: Display.				"display the line"

	"Line example"! !Path subclass: #LinearFit
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Paths'!
LinearFit comment:
'I represent a piece-wise linear approximation to a set of points in the plane.'!

!LinearFit methodsFor: 'displaying'!
displayOn: aDisplayMedium at: aPoint clippingBox: clipRect rule: anInteger fillColor: aForm
 
	| pt line |
	line _ Line new.
	line form: self form.
	1 to: self size - 1 do: 
		[:i | 
		line beginPoint: (self at: i).
		line endPoint: (self at: i + 1).
		line displayOn: aDisplayMedium
			at: aPoint
			clippingBox: clipRect
			rule: anInteger
			fillColor: aForm]!
displayOn: aDisplayMedium transformation: aTransformation clippingBox: clipRect rule: anInteger fillColor: aForm 

	| newLinearFit transformedPath |
	"get the scaled and translated Path."
	transformedPath _ aTransformation applyTo: self.
	newLinearFit _ LinearFit new.
	transformedPath do: [:point | newLinearFit add: point].
	newLinearFit form: self form.
	newLinearFit
		displayOn: aDisplayMedium
		at: 0 @ 0
		clippingBox: clipRect
		rule: anInteger
		fillColor: aForm! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

LinearFit class
	instanceVariableNames: ''!

!LinearFit class methodsFor: 'examples'!
example
	"Select points on a Path using the red button. Terminate by selecting
	any other button. Creates a Path from the points and displays it as a
	piece-wise linear approximation." 

	| aLinearFit aForm flag |
	aLinearFit _ LinearFit new.
	aForm _ Form extent: 1 @ 40.
	aForm  fillBlack.
	aLinearFit form: aForm.
	flag _ true.
	[flag] whileTrue:
		[Sensor waitButton.
		 Sensor redButtonPressed
			ifTrue: [aLinearFit add: Sensor waitButton. Sensor waitNoButton.
					aForm displayOn: Display at: aLinearFit last]
			ifFalse: [flag_false]].
	aLinearFit displayOn: Display

	"LinearFit example"! !Object subclass: #Link
	instanceVariableNames: 'nextLink '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
Link comment:
'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.'!

!Link methodsFor: 'accessing'!
nextLink
	"Answer the link to which the receiver points."

	^nextLink!
nextLink: aLink 
	"Store the argument, aLink, as the link to which the receiver refers. 
	Answer aLink."

	^nextLink _ aLink! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

Link class
	instanceVariableNames: ''!

!Link class methodsFor: 'instance creation'!
nextLink: aLink 
	"Answer an instance of me referring to the argument, aLink."

	^self new nextLink: aLink! !SequenceableCollection subclass: #LinkedList
	instanceVariableNames: 'firstLink lastLink '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
LinkedList comment:
'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.'!

!LinkedList methodsFor: 'accessing'!
first
	"Answer the first link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^firstLink!
last
	"Answer the last link. Create an error notification if the receiver is 
	empty."

	self emptyCheck.
	^lastLink!
size
	"Answer how many elements the receiver contains."

	| tally |
	tally _ 0.
	self do: [:each | tally _ tally + 1].
	^tally! !

!LinkedList methodsFor: 'testing'!
isEmpty

	^firstLink == nil! !

!LinkedList methodsFor: 'adding'!
add: aLink 
	"Add aLink to the end of the receiver's list. Answer aLink."

	^self addLast: aLink!
addFirst: aLink 
	"Add aLink to the beginning of the receiver's list. Answer aLink."

	self isEmpty ifTrue: [lastLink _ aLink].
	aLink nextLink: firstLink.
	firstLink _ aLink.
	^aLink!
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! !

!LinkedList methodsFor: 'removing'!
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!
removeFirst
	"Remove the first element and answer it. If the receiver is empty, create 
	an error notification."

	| oldLink |
	self emptyCheck.
	oldLink _ firstLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [firstLink _ oldLink nextLink].
	oldLink nextLink: nil.
	^oldLink!
removeLast
	"Remove the receiver's last element and answer it. If the receiver is 
	empty, create an error notification."

	| oldLink aLink |
	self emptyCheck.
	oldLink _ lastLink.
	firstLink == lastLink
		ifTrue: [firstLink _ nil. lastLink _ nil]
		ifFalse: [aLink _ firstLink.
				[aLink nextLink == oldLink] whileFalse:
					[aLink _ aLink nextLink].
				 aLink nextLink: nil.
				 lastLink _ aLink].
	oldLink nextLink: nil.
	^oldLink! !

!LinkedList methodsFor: 'enumerating'!
do: aBlock

	| aLink |
	aLink _ firstLink.
	[aLink == nil] whileFalse:
		[aBlock value: aLink.
		 aLink _ aLink nextLink]! !ScrollController subclass: #ListController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!
ListController comment:
'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'!
isControlActive

	^super isControlActive & sensor blueButtonPressed not! !

!ListController methodsFor: 'marker adjustment'!
computeMarkerRegion 
	"Refer to the comment in ScrollController|computeMarkerRegion."

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height = 0
		ifTrue: [^ 0@0 extent: 10@scrollBar inside height].
	^ 0@0 extent: 10@
			((viewList clippingRectangle height asFloat /
						viewList compositionRectangle height *
							scrollBar inside height)
					rounded min: scrollBar inside height)!
markerDelta

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height == 0 ifTrue: [
		^ (marker top - scrollBar inside top) - scrollBar inside height
	].
	^ (marker top - scrollBar inside top) -
		((viewList clippingRectangle top -
				viewList compositionRectangle top) asFloat /
			viewList compositionRectangle height asFloat *
			scrollBar inside height asFloat) rounded
!
mmarkerDelta

	| viewList |
	viewList _ view list.
	viewList compositionRectangle height == 0 ifTrue: [
		^ (marker top - self mscrollGrayRect top) - (self mscrollGrayRect height - marker height)
	].
	^ (marker top - self mscrollGrayRect top) -
		((viewList clippingRectangle top -
				viewList compositionRectangle top) asFloat /
			(viewList compositionRectangle height - viewList clippingRectangle height) asFloat *
			(self mscrollGrayRect height - marker height) asFloat) rounded
! !

!ListController methodsFor: 'scrolling'!
scrollAmount 
	"Refer to the comment in ScrollController|scrollAmount."

	^sensor cursorPoint y - scrollBar inside top!
scrollView: anInteger 
	"Scroll the view and highlight the selection if it just came into view"
	| wasClipped |
	wasClipped _ view isSelectionBoxClipped.
	(view scrollBy: anInteger)
		ifTrue: [view isSelectionBoxClipped ifFalse:
					[wasClipped ifTrue:  "Selection came into view"
						[view displaySelectionBox]].
				^ true]
		ifFalse: [^ false]!
viewDelta 
	"Refer to the comment in ScrollController|viewDelta."

	| viewList |
	viewList _ view list.
	^(viewList clippingRectangle top -
			viewList compositionRectangle top -
			((marker top - scrollBar inside top) asFloat /
				scrollBar inside height asFloat *
				viewList compositionRectangle height asFloat))
		roundTo: viewList lineGrid! !

!ListController methodsFor: 'selecting'!
redButtonActivity
	| noSelectionMovement oldSelection selection nextSelection pt scrollFlag |
	noSelectionMovement _ true.
	scrollFlag _ false.
	oldSelection _ view selection.
	[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 ifFalse:
					[view moveSelectionBox: (nextSelection _ selection).
					nextSelection ~= oldSelection
						ifTrue: [noSelectionMovement _ false]]].
	nextSelection ~~ nil & (nextSelection = oldSelection
			ifTrue: [noSelectionMovement]
			ifFalse: [true]) ifTrue: [self changeModelSelection: nextSelection].
	scrollFlag ifTrue: [self moveMarker]! !

!ListController methodsFor: 'private'!
changeModelSelection: anInteger
	model toggleListIndex: anInteger! !ListController subclass: #ListControllerOfMany
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!
ListControllerOfMany comment:
'This class supports the control of lists with multiple selections'!

!ListControllerOfMany methodsFor: 'selecting'!
redButtonActivity
	| selection firstHit turningOn lastSelection pt scrollFlag |
	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]! !

!ListControllerOfMany methodsFor: 'scrolling'!
scrollView: anInteger 
	"Need to minimize the selections which get recomputed"
	| oldLimit |
	oldLimit _ anInteger > 0
		ifTrue: [view firstShown]
		ifFalse: [view lastShown].
	(view scrollBy: anInteger)
		ifTrue: [anInteger > 0  "Highlight selections brought into view"
					ifTrue: [view highlightFrom: view firstShown
								to: (oldLimit-1 min: view lastShown)]
					ifFalse: [view highlightFrom: (oldLimit+1 max: view firstShown)
								to: view lastShown].
				^ true]
		ifFalse: [^ false]! !Paragraph subclass: #ListParagraph
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
ListParagraph comment:
'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 methodsFor: 'composition'!
composeAll
	"No composition is necessary once the ListParagraph is created."
	
	lastLine isNil ifTrue: [lastLine _ 0].	
		"Because composeAll is called once in the process of creating the ListParagraph."
	^compositionRectangle width! !

!ListParagraph methodsFor: 'private'!
trimLinesTo: lastLineInteger
	"Since ListParagraphs are not designed to be changed, we can cut back the
		lines field to lastLineInteger."
	lastLine _ lastLineInteger.
	lines _ lines copyFrom: 1 to: lastLine!
withArray: anArray 
	"Modifies self to contain the list of strings in anArray"
	| startOfLine endOfLine lineIndex aString item interval |
	lines _ Array new: 20.
	lastLine _ 0.
	startOfLine _ 1.
	endOfLine _ 1.
	lineIndex _ 0.
	anArray do: 
		[:item | 
		endOfLine _ startOfLine + item size.		"this computation allows for a cr after each line..."
												"...but later we will adjust for no cr after last line"
		lineIndex _ lineIndex + 1.
		self lineAt: lineIndex put: (TextLineInterval
				start: startOfLine
				stop: endOfLine
				internalSpaces: 0
				paddingWidth: 0).
		startOfLine _ endOfLine + 1].
	endOfLine _ endOfLine - 1.		"endOfLine is now the total size of the text"
	self trimLinesTo: lineIndex.
	aString _ String new: endOfLine.
	anArray with: lines do: 
		[:item :interval | 
		aString
			replaceFrom: interval first
			to: interval last - 1
			with: item
			startingAt: 1.
		interval last <= endOfLine ifTrue: [aString at: interval last put: Character cr]].
	lineIndex > 0 ifTrue: [(lines at: lineIndex) stop: endOfLine].	"adjust for no cr after last line"
	self text: aString asText.
	self updateCompositionHeight! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

ListParagraph class
	instanceVariableNames: ''!

!ListParagraph class methodsFor: 'instance creation'!
withArray: anArray
	"Convert an array of strings into a ListParagraph."

	^super new withArray: anArray!
withArray: anArray lineSpacing: spacing
	"Convert an array of strings into a ListParagraph."
	^ (super new gridWithLead: spacing) withArray: anArray! !View subclass: #ListView
	instanceVariableNames: 'list selection topDelimiter bottomDelimiter lineSpacing isEmpty '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!
ListView comment:
'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: 'initialize-release'!
initialize 
	"Refer to the comment in View|initialize."

	super initialize.
	topDelimiter _ '------------'.
	bottomDelimiter _ '------------'.
	lineSpacing _ 0.
	isEmpty _ true.
	self list: Array new! !

!ListView methodsFor: 'list access'!
list
	"Answer the list of items the receiver displays."

	^list!
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 _ Array with: topDelimiter with: bottomDelimiter.
	arrayCopy _ arrayCopy copyReplaceFrom: 2 to: 1 with: anArray."
	arrayCopy _ arrayCopy copyWithout: nil.
	list _ ListParagraph withArray: arrayCopy lineSpacing: lineSpacing.
	selection _ 0.
	self positionList!
reset
	"Set the list of items displayed to be empty."

	isEmpty _ true.
	self list: Array new!
resetAndDisplayView
	"Set the list of items displayed to be empty and redisplay the receiver."

	isEmpty
		ifFalse: 
			[self reset.
			self displayView]!
selection: selIndex
	selection _ selIndex! !

!ListView methodsFor: 'delimiters'!
bottomDelimiter
	"Answer the string used to indicate the bottom of the list."

	^bottomDelimiter!
bottomDelimiter: aString 
	"Set the string used to indicate the bottom of the list."

	bottomDelimiter _ aString!
noBottomDelimiter
	"Set the string used to indicate the bottom of the list to be nothing."

	bottomDelimiter _ nil!
noTopDelimiter
	"Set the string used to indicate the top of the list to be nothing."

	topDelimiter _ nil!
topDelimiter
	"Answer the string used to indicate the top of the list."

	^topDelimiter!
topDelimiter: aString 
	"Set the string used to indicate the top of the list."

	topDelimiter _ aString! !

!ListView methodsFor: 'line spacing'!
lineSpacing
	"Answer the integer representing the amount of extra space between line 
	items."

	^lineSpacing!
lineSpacing: anInteger 
	"Set anInteger to be the amount of extra space between line items."

	lineSpacing _ anInteger! !

!ListView methodsFor: 'displaying'!
deEmphasizeSelectionBox
	self displaySelectionBox!
display 
	"Refer to the comment in View.display."
	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[selection isNil ifTrue: [selection _ 0].
			self positionList].
	super display!
displaySelectionBox
	"If the receiver has a selection and that selection is visible on the display 
	screen, then highlight it."
	selection ~= 0 ifTrue:
		[Display reverse: (self selectionBox intersect: self clippingBox)]!
displayView 
	"Refer to the comment in View|displayView."

	self clearInside.
	list foregroundColor: self foregroundColor
		backgroundColor: self backgroundColor.
	list displayOn: Display!
scrollBy: anInteger 
	"Scroll up by this amount adjusted by lineSpacing and list limits"
	| maximumAmount minimumAmount amount wasClipped |
	maximumAmount _ 0 max:
		list clippingRectangle top - list compositionRectangle top.
	minimumAmount _ 0 min:
		list clippingRectangle bottom - list compositionRectangle bottom.
	amount _ (anInteger min: maximumAmount) max: minimumAmount.
	amount ~= 0
		ifTrue: [list scrollBy: amount negated.  ^ true]
		ifFalse: [^ false]  "Return false if no scrolling took place"!
scrollSelectionIntoView
	"Selection is assumed to be on and clipped out of view.
	Uses controller scrollView to keep selection right"
	| delta |
	(delta _ self insetDisplayBox bottom - self selectionBox bottom) < 0
		ifTrue: [^ controller scrollView: delta - (list lineGrid-1)]. "up"
	(delta _ self insetDisplayBox top - self selectionBox top) > 0
		ifTrue: [^ controller scrollView: delta + 1] "down"! !

!ListView methodsFor: 'deEmphasizing'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	^ self deEmphasizeSelectionBox!
emphasizeView 
	"List emphasis is its own inverse."
	^ self deEmphasizeView! !

!ListView methodsFor: 'controller access'!
defaultControllerClass 
	"Refer to the comment in View|defaultControllerClass."

	^ListController! !

!ListView methodsFor: 'display box access'!
boundingBox 
	"Refer to the comment in View|boundingBox."

	^list boundingBox! !

!ListView methodsFor: 'clipping box access'!
clippingBox
	"Answer the rectangle in which the model can be displayed--this is the 
	insetDisplayBox inset by the height of a line for an item."

	^self insetDisplayBox insetBy: 
		(Rectangle
			left: 0
			right: 0
			top: 0
			bottom: self insetDisplayBox height \\ list lineGrid)! !

!ListView methodsFor: 'selecting'!
deselect
	"If the receiver has a selection, then it is highlighted. Remove the 
	highlighting."

	selection ~= 0 ifTrue: [Display reverse: (self selectionBox intersect: self clippingBox)]!
findSelection: aPoint 
	"Determine which selection is displayed in an area containing the point, 
	aPoint. Answer the selection if one contains the point, answer nil 
	otherwise."

	| trialSelection |
	(self clippingBox containsPoint: aPoint) ifFalse: [^nil].
	trialSelection _ aPoint y - list compositionRectangle top // list lineGrid + 1.
	topDelimiter == nil ifFalse: [trialSelection _ trialSelection - 1].
	(trialSelection < 1) | (trialSelection > self maximumSelection)
		ifTrue: [^ nil]
		ifFalse: [^ trialSelection]!
isSelectionBoxClipped
	"Answer whether there is a selection and whether the selection is visible 
	on the screen."

	^selection ~= 0 & (self selectionBox intersects: self clippingBox) not!
maximumSelection
	"Answer which selection is the last possible one."
	^ list numberOfLines
		- (topDelimiter == nil ifTrue: [0] ifFalse: [1])
		- (bottomDelimiter == nil ifTrue: [0] ifFalse: [1])!
minimumSelection
	"Answer which selection is the first possible one."
	^ 1!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."

	selection ~= anInteger
		ifTrue: 
			[self deselect.
			selection _ anInteger.
			self displaySelectionBox].
	self isSelectionBoxClipped
		ifTrue: [self scrollSelectionIntoView]!
selection
	"Answer the receiver's current selection."

	^selection!
selectionBox
	"Answer the rectangle in which the current selection is displayed."

	^(self insetDisplayBox left @ (list compositionRectangle top + self selectionBoxOffset) 
		extent: self insetDisplayBox width @ list lineGrid)
		insetBy: (Rectangle left: 1 right: 1 top: 1 bottom: 0)!
selectionBoxOffset
	"Answer an integer that determines the y position for the display box of 
	the current selection."

	^ (selection - 1 + (topDelimiter == nil ifTrue: [0] ifFalse: [1]))
		* list lineGrid! !

!ListView methodsFor: 'updating'!
update: aSymbol 
	"Refer to the comment in View|update:."

	aSymbol == #list
		ifTrue: 
			[self list: model list.
			self displayView.
			^self].
	aSymbol == #listIndex
		ifTrue: 
			[self moveSelectionBox: model listIndex.
			^self]! !

!ListView methodsFor: 'private'!
firstShown
	"Return the index of the top item currently visible"
	| trial |
	trial _ self findSelection: self insetDisplayBox topLeft.
	^ trial == nil
		ifTrue: [1]
		ifFalse: [trial]!
lastShown
	"Return the index of the bottom item currently visible"
	| trial bottomMargin |
	bottomMargin _ self insetDisplayBox height \\ list lineGrid.
	trial _ self findSelection: self insetDisplayBox bottomLeft - (0@bottomMargin).
	trial == nil
		ifTrue: [trial _ self findSelection: self insetDisplayBox bottomLeft
					- (0@(list lineGrid+bottomMargin))].
	^ trial == nil
		ifTrue: [list numberOfLines - 2]
		ifFalse: [trial]!
positionList

	list wrappingBox: self wrappingBox clippingBox: self clippingBox !
wrappingBox

	| aRectangle |
	aRectangle _ self insetDisplayBox. 
	selection = 0
		ifTrue: [^aRectangle topLeft + (4 @ 0) extent: list compositionRectangle extent]
		ifFalse: [^aRectangle left + 4 @ 
					(aRectangle top - 
						(self selectionBoxOffset 
							min: ((list height - aRectangle height 
									+ list lineGrid truncateTo: list lineGrid)
							max: 0))) 
					extent: list compositionRectangle extent]! !

!ListView methodsFor: 'lock access'!
lock
	"Refer to the comment in view|lock.  Must do at least what display would do to lock the view."

	(self isUnlocked and: [self clippingBox ~= list clippingRectangle])
		ifTrue:  "Recompose the list if the window changed"
			[self positionList].
	super lock! !ListView subclass: #ListViewOfMany
	instanceVariableNames: 'selections '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Support'!
ListViewOfMany comment:
'Just like ListView, except that multiple entries can be selected.
The model is required to support the messages selecitonAt: and
selectionAt:put: to communicate which items are selected.
The normal listIndex logic is ignored for the most part, except in 
the use of some routines inherited from ListView.'!

!ListViewOfMany methodsFor: 'displaying'!
deEmphasizeView 
	"Refer to the comment in View|deEmphasizeView."
	selection _ 0.
	1 to: self maximumSelection do:
		[:i | selection _ i.
		(model listSelectionAt: i) ifTrue: [self deEmphasizeSelectionBox]].
	selection _ 0!
highlightFrom: start to: stop
	(start == nil or: [stop == nil]) ifTrue: [^ self displayView].
	start to: stop do:
		[:i | selection _ i.
		(model listSelectionAt: selection) ifTrue: [self displaySelectionBox]].
	selection _ 0! !

!ListViewOfMany methodsFor: 'selecting'!
moveSelectionBox: anInteger 
	"Presumably the selection has changed to be anInteger. Deselect the 
	previous selection and display the new one, highlighted."
	selection ~= anInteger
		ifTrue: 
			[selection _ anInteger.
			self displaySelectionBox]!
selection
	"Have to override normal controller smarts about deselection"
	^ 0! !

!ListViewOfMany methodsFor: 'updating'!
update: aSymbol 
	aSymbol == #allSelections
		ifTrue: [^ self displayView; emphasizeView].
	^ super update: aSymbol! !Dictionary subclass: #LiteralDictionary
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
LiteralDictionary comment:
'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'!

!LiteralDictionary methodsFor: 'as yet unclassified'!
scanFor: key from: start to: finish
	"Scan the key array for the first slot containing either a nil (indicating an empty slot) or an element that matches the key. Answer the index of that slot or zero if no slot is found within the given range of indices."

	| element |
	"this speeds up a common case: key is in the first slot"
	((element _ array at: start) == nil or:
	 [(element key class == key class) and:
	 [element key = key]])
		ifTrue: [ ^ start ].

	start + 1 to: finish do: [ :index |
		((element _ array at: index) == nil or:
		 [(element key class == key class) and:
		 [element key = key]])
			ifTrue: [ ^ index ].
	].
	^ 0
! !LeafNode subclass: #LiteralNode
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Compiler'!
LiteralNode comment:
'I am a parse tree leaf representing a literal string or number.'!

!LiteralNode methodsFor: 'code generation'!
emitForValue: stack on: strm

	code < 256
		ifTrue: [strm nextPut: code]
		ifFalse: [self emitLong: LdInstLong on: strm].
	stack push: 1! !

!LiteralNode methodsFor: 'testing'!
isConstantNumber
	^ key isNumber!
isSpecialConstant
	^ code between: LdTrue and: LdMinus1+3!
literalValue

	^key! !

!LiteralNode methodsFor: 'printing'!
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: [key storeOn: aStream]! !

!LiteralNode methodsFor: 'equation translation'!
collectVariables
	^#()!
copyReplacingVariables: varDict 
	^self copy!
specificMatch: aTree using: matchDict 
	^key = aTree key! !

!LiteralNode methodsFor: 'C translation'! !SwitchController subclass: #LockedSwitchController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Interface-Menus'!
LockedSwitchController comment:
'I am a SwitchController that will not take control if the model is locked. Rather the view is "flashed" (complemented twice in succession).'!

!LockedSwitchController methodsFor: 'control defaults'!
isControlWanted
	sensor flushKeyboard.
	self viewHasCursor ifFalse: [^ false].
	sensor redButtonPressed ifFalse: [^ false].
	^ model okToChange  "Dont change selection if model is locked"! !Magnitude subclass: #LookupKey
	instanceVariableNames: 'key '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Support'!
LookupKey comment:
'I represent a key for looking up entries in a data structure. Subclasses of me, such as Association, typically represent dictionary entries.'!

!LookupKey methodsFor: 'accessing'!
key
	"Answer the lookup key of the receiver."

	^key!
key: anObject 
	"Store the argument, anObject, as the lookup key of the receiver."

	key _ anObject! !

!LookupKey methodsFor: 'comparing'!
< aLookupKey 
	"Refer to the comment in Magnitude|<."

	^key < aLookupKey key!
= aLookupKey

	self species = aLookupKey species
		ifTrue: [^key = aLookupKey key]
		ifFalse: [^false]!
hash
	"Hash is reimplemented because = is implemented."

	^key hash!
hashMappedBy: map
	"Answer what my hash would be if oops changed according to map."

	^key hashMappedBy: map! !

!LookupKey methodsFor: 'printing'!
printOn: aStream

	key printOn: aStream! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

LookupKey class
	instanceVariableNames: ''!

!LookupKey class methodsFor: 'instance creation'!
key: aKey 
	"Answer an instance of me with the argument as the lookup up."

	^self new key: aKey! !FileDirectory subclass: #MacFileDirectory
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'System-Files'!
MacFileDirectory comment:
'Represents a minimal, flat directory, for use with the simplest implementation of files.  2/5/96 sw'!

!MacFileDirectory methodsFor: 'file creation'!
fileClass
	^ StandardFileStream! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MacFileDirectory class
	instanceVariableNames: ''!

!MacFileDirectory class methodsFor: 'initialization'!
pathNameDelimiter
	^ $:!
setMacFileNamed: fileName type: typeString creator: creatorString
	"Set the Macintosh file type and creator info for the file with the given name. Fails if the file does not exist or if the type and creator type arguments are not strings of length 4."
	"Mac specific; noop on other platforms."

 	<primitive: 169>
	self primitiveFailed.! !Object subclass: #Magnitude
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Numeric-Magnitudes'!
Magnitude comment:
'I am an abstract representation of objects that measure something linear. Examples are dates, times, and numbers.'!

!Magnitude methodsFor: 'comparing'!
< aMagnitude 
	"Answer whether the receiver is less than the argument."

	^self subclassResponsibility!
<= aMagnitude 
	"Answer whether the receiver is less than or equal to the argument."

	^(self > aMagnitude) not!
= aMagnitude 
	"Compare the receiver with the argument and answer with true if the 
	receiver is equal to the argument. Otherwise answer false."

	^self subclassResponsibility!
> aMagnitude 
	"Answer whether the receiver is greater than the argument."

	^aMagnitude < self!
>= aMagnitude 
	"Answer whether the receiver is greater than or equal to the argument."

	^(self < aMagnitude) not!
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]!
hash
	"Hash must be redefined whenever = is redefined."

	^self subclassResponsibility!
hashMappedBy: map
	"My hash is independent of my oop."

	^self hash! !

!Magnitude methodsFor: 'testing'!
max: aMagnitude 
	"Answer the receiver or the argument, whichever has the greater 
	magnitude."

	self > aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]!
min: aMagnitude 
	"Answer the receiver or the argument, whichever has the lesser 
	magnitude."

	self < aMagnitude
		ifTrue: [^self]
		ifFalse: [^aMagnitude]!
min: aMin max: aMax 

	^ (self min: aMin) max: aMax! !Collection subclass: #MappedCollection
	instanceVariableNames: 'domain map '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Collections-Sequenceable'!
MappedCollection comment:
'I represent an access mechanism for a sequencable collection re-ordering or filtering its elements.'!

!MappedCollection methodsFor: 'accessing'!
at: anIndex

	^domain at: (map at: anIndex)!
at: anIndex put: anObject

	^domain at: (map at: anIndex) put: anObject!
atPin: anIndex 
	"Return this element of an indexable object.  Return the first or last element if index is out of bounds.  6/18/96 tk"

	^domain at: (map atPin: anIndex)!
atWrap: anIndex 
	"Return this element of an indexable object.  If index is out of bounds, let it wrap around from the end to the beginning unil it is in bounds.  6/18/96 tk"

	^domain at: (map atWrap: anIndex)!
contents
	"Answer the receiver's domain for mapping, a Dictionary or 
	SequenceableCollection."

	^map collect: [:mappedIndex | domain at: mappedIndex]!
size

	^map size! !

!MappedCollection methodsFor: 'adding'!
add: newObject

	self shouldNotImplement! !

!MappedCollection methodsFor: 'copying'!
copy
	"This returns another MappedCollection whereas copyFrom:to: will return
	an object like my domain."

	^MappedCollection collection: domain map: map! !

!MappedCollection methodsFor: 'enumerating'!
collect: aBlock 
	"Refer to the comment in Collection|collect:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		aStream nextPut: (aBlock value: domainValue)].
	^aStream contents!
do: aBlock 
	"Refer to the comment in Collection|do:."

	map do:
		[:mapValue | aBlock value: (domain at: mapValue)]!
select: aBlock 
	"Refer to the comment in Collection|select:."

	| aStream |
	aStream _ WriteStream on: (self species new: self size).
	self do:
		[:domainValue | 
		(aBlock value: domainValue)
			ifTrue: [aStream nextPut: domainValue]].
	^aStream contents! !

!MappedCollection methodsFor: 'printing'!
storeOn: aStream

	aStream nextPut: $(.
	domain storeOn: aStream.
	aStream nextPutAll: ' mappedBy: '.
	map storeOn: aStream.
	aStream nextPut: $)! !

!MappedCollection methodsFor: 'private'!
setCollection: aCollection map: aDictionary

	domain _ aCollection.
	map _ aDictionary!
species

	^domain species! !
"-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "!

MappedCollection class
	instanceVariableNames: ''!

!MappedCollection class methodsFor: 'instance creation'!
collection: aCollection map: aSequenceableCollection 
	"Answer an instance of me that maps aCollection by 
	aSequenceableCollection."

	^self basicNew setCollection: aCollection map: aSequenceableCollection!
new

	self error: 'MappedCollections must be created using the collection:map: message'!
newFrom: aCollection 
	"Answer an instance of me containing the same elements as aCollection."

	^ self collection: aCollection map: (1 to: aCollection size)

"	MappedCollection newFrom: {1. 2. 3}
	{4. 3. 8} as: MappedCollection
"! !DisplayObject subclass: #MaskedForm
	instanceVariableNames: 'theForm mask transparentPixelValue colorMap rawColorMap '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Graphics-Display Objects'!
MaskedForm comment:
'A transparent Form.  It consists of theForm and a one-bit-deep mask.  When a MaskedForm is displayed, theForm is transparent where the mask is white, and opaque where the mask is black.  
	The user may specify a mask explicitly.  Or the user may submit only theForm and a color that stands for transparent.  Thus a MaskedForm can do blue-screening (also called chroma-keying).
	When a user submits theForm with a mask, she must say what happens to the colored bits in the transparent area.  They can be removed or not.  If the user does not remove the overlap, the bits will be combined using OR with the background, producing strange colors.
	Think of theForm as unchanged, but we have to change it behind the user''s back for speed.  When the users asks for it, we change it back.

<<ColorMap support in next version.  Problem: colorMap belongs to sourceForm, but is used by BitBlt.  Messages are sent to destForm or to Bitblt, so sourceForm never gets to install the colorMap.>> 
	In addition to MaskedForm''s normal use, the user may submit a colorMap.  (Normally one does not need to do this.)  If you have an 8-bit deep Form that was created with colors other than the standard 256 colors we supply, the user can submit a 256 long Array of Colors.  MaskedForm will choose the closest 256 colors it can and display the form using those.  transparentPixelValue and transparentColor are in terms of the original unmapped Form.  The original Form is transformed by the map at each display.  Using a map preserves the colors in case you later want to display the Form at a different depth.

Instance variables:
	theForm		Internal rep of the Form to be displayed.  This may different from the Form submitted, but the original Form is recomputed upon request by using ''form''.
	mask			A one-bit form. white=transparent, black=opaque.
	transparentPixelValue	The bit value in the original Form that should be treated as transparent. 
	colorMap		An array of Colors.  Size = 2^(maskedForm depth).  Stored as a copy, so it can''t change without our knowing about it.  If you want to change an entry in the colorMap, make the change in your own array and then call colorMap:  again. 
	rawColorMap	A cached internal rep to be sent to BitBlt.

Messages:
	colorAt: x@y put: aColor  Write a Color into a pixel.  (Checks if writing over transparent and changes the mask.)
	pixelValueAt: x@y put: i 	Write a raw pixelValue into a pixel.
	transparentColor: aColor   	Change the transparent color.  Alters the mask as needed. 
	transparentPixelValue: i		Specify the transparent color by its internal bit pattern.
	form	Returns the original form.  It is in terms of the colorMap, if one was specified.  Transparent pixels once again have the chosen transparent color in them.
	colorMap:	Install a new color map (normally not needed).  A colorMap is an array of Colors.  It is depth independent, except that its length should be at least 2^N where N is the pixel depth of the Form.  (We try to get away with colorMap being an Array instead of an instance of a separate class.)  The map is copied from the one you submit.  If you change an entry, you must submit the map again using colorMap:.

Class messages: 
	form: f mask: m removeOverlap: true		create a MaskedForm.  Remove the colored pixels in this form from its transparent area.
	form: f transparentColor: aColor		create a MaskedForm
	transparentBorder: aForm		Answer an instance of me that looks like aForm, but is transparent in regions near the edge.
	transparentFromUser: f 		Displays the Form and asks the user to click on the color that should be transparent.
'!

!MaskedForm methodsFor: 'access'!
basicForm
	"Return the form part of me, regardless of how the transparent color has been replaced with 0.  9/6/96 tk"
	^ theForm!
borderWidth: anInteger

	theForm borderWidth: anInteger.
	mask borderWidth: anInteger!
colorMap
	"Map the pixelValues in theForm to the colors is this array.  6/28/96 tk"

	^ colorMap!
colorMap: anArray
	"Map the pixelValues in theForm through the colors is this array.  Array should be 2^(theForm depth) long.  If s