Hi all,

My displacement activity this afternoon turned out to be in Squeak.  If
anyone can find a use for this, help yourself...

Ian

'From Squeak3.6beta of ''4 July 2003'' [latest update: #5373] on 16 August 2003 at 7:24:57 pm'!
"Change Set:		MultiMethods
Date:			16 August 2003
Author:			Ian Piumarta

Does for Smalltalk blocks what generic functions do for functions in
Cecil, Dylan, etc.  See the class side of GenericBlock for some stupid
examples.
-------------- next part --------------
'From Squeak3.6beta of ''4 July 2003'' [latest update: #5373] on 16 August 2003 at 7:24:57 pm'!
"Change Set:		MultiMethods
Date:			16 August 2003
Author:			Ian Piumarta

Does for Smalltalk blocks what generic functions do for functions in Cecil, Dylan, etc.  See the class side of GenericBlock for some stupid examples.

Released under the ALYL (Any License You Like), with the following exceptions: (1) If you work at La Maison Blanche then a donation of $10,000,000 to a registered charity (of your choice) is required for each copy deployed."!

Error subclass: #DispatchError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!DispatchError commentStamp: 'ikp 8/16/2003 18:06' prior: 0!
I am signaled when a GenericBlock cannot be evaluated for some reason.!

DispatchError subclass: #AmbiguousMethodError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!AmbiguousMethodError commentStamp: 'ikp 8/16/2003 18:06' prior: 0!
I am signaled when a GenericBlock finds two or more methods that are equally specific for the actual argument types.!

Object subclass: #Foo
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!
Foo subclass: #Bar
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!
Set subclass: #GenericBlock
	instanceVariableNames: 'cache '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!GenericBlock commentStamp: 'ikp 8/16/2003 18:51' prior: 0!
I represent a block that has multiple bodies.  When I am evaluated I choose one of my bodies to run, according to the arity and types of the actual arguments at the moment of evaluation.  You instantiate me with #new and then add type-specific bodies to me with #at:put:, like this:

	aGenericBlock at: { Class1. Class2. ... ClassN } put: [ :a1 :a2 ... :aN | ... ]

The number of classes in the 'signature' must match the arity of the block body.  If not then I will signal an (unrecoverable) error.  (If you need to eliminate a particular argument from the dispatch process, just give its type as 'Object'.)

You can then evaluate me by sending me the usual #value[:[value:[value:[...]]]] messages.  I will choose one of my block bodies to run according to the types of the actual arguments.  I will choose the body that has the 'most-specific' match to the actual argument types.  If I cannot find any match then I will signal a NoApplicableMethodError.  If I can find two or more equally-specific matches then I will signal an AmbiguousMethodError.

Specificity is determined according to the aggregate 'distance' in the class hierarchy between the actual argument types and the formal argument types declared for each body using #at:put:.  The 'most-specific' match is the one that minimises that distance.

Since all arguments have equal share in the decision process, there is no 'artbitration' possible when I find two equally-specific bodies.  In such cases I cannot choose and must signal an AmbiguousMethodError.  This is the same rule used for multimethod dispatch to a 'generic function' in languages like Cecil and Dylan.  It is different to the rule used in (e.g.) CLOS, where left-to-right priority is assigned to the arguments when determining specificity -- meaning there can be no ambiguity.

Warning: I take about 50 times longer to evaluate than does a regular BlockContext.!

Object subclass: #GenericMethod
	instanceVariableNames: 'signature block '
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!GenericMethod commentStamp: 'ikp 8/16/2003 18:46' prior: 0!
I am one body within a GenericBlock.  My instance variables contain:

	signature		-- a GenericType containing my formal parameter types
	block			-- a block to be run when I am selected for evaluation by a GenericBlock.
!

OrderedCollection subclass: #GenericType
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!GenericType commentStamp: 'ikp 8/16/2003 18:47' prior: 0!
I am the type (signature) of a GenericMethod.!

DispatchError subclass: #NoApplicableMethodError
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'MultiMethods'!

!NoApplicableMethodError commentStamp: 'ikp 8/16/2003 18:06' prior: 0!
I am signaled when a GenericBlock cannot find any method applicable to the actual argument types.!


!GenericBlock methodsFor: 'initialize-release' stamp: 'ikp 8/16/2003 13:37'!
initialise

	self flushCache! !

!GenericBlock methodsFor: 'accessing' stamp: 'ikp 8/16/2003 13:48'!
at: signature put: aBlock

	| method |
	self flushCache.
	method _ GenericMethod signature: signature block: aBlock.
	self remove: method ifAbsent: [].
	^self add: method! !

!GenericBlock methodsFor: 'evaluating' stamp: 'ikp 8/16/2003 17:51'!
value

	^(self bindBlock: (GenericType new))
		value! !

!GenericBlock methodsFor: 'evaluating' stamp: 'ikp 8/16/2003 17:45'!
value: arg1

	^(self bindBlock: (GenericType with: arg1 class))
		value: arg1! !

!GenericBlock methodsFor: 'evaluating' stamp: 'ikp 8/16/2003 17:45'!
value: arg1 value: arg2

	^(self bindBlock: (GenericType with: arg1 class with: arg2 class))
		value: arg1
		value: arg2! !

!GenericBlock methodsFor: 'evaluating' stamp: 'ikp 8/16/2003 17:49'!
value: arg1 value: arg2 value: arg3

	^(self bindBlock: (GenericType with: arg1 class with: arg2 class with: arg3 class))
		value: arg1
		value: arg2
		value: arg3! !

!GenericBlock methodsFor: 'dispatch' stamp: 'ikp 8/16/2003 17:11'!
applicableMethods: type

	^self select: [ :m | m isApplicable: type]! !

!GenericBlock methodsFor: 'dispatch' stamp: 'ikp 8/16/2003 17:35'!
bindBlock: type

	| methods |
	^cache
		at: type
		ifAbsent:
			[methods _ self sortedMethods: type.
			 methods size == 1
				ifFalse:
					[methods isEmpty
						ifTrue: [^NoApplicableMethodError signal].
					 (methods first strictOrder: methods second)
						ifFalse: [^AmbiguousMethodError signal]].
			 cache at: type put: methods first block]! !

!GenericBlock methodsFor: 'dispatch' stamp: 'ikp 8/16/2003 19:01'!
sortedMethods: type

	^(SortedCollection sortBlock: [:a :b | a partialOrder: b])
		addAll: (self applicableMethods: type);
		yourself! !

!GenericBlock methodsFor: 'private' stamp: 'ikp 8/16/2003 17:31'!
flushCache

	cache _ Dictionary new.! !


!GenericBlock class methodsFor: 'instance creation' stamp: 'ikp 8/16/2003 13:08'!
new

	^super new initialise! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 18:00'!
example
	"GenericBlock example"

	| foo bar g |
	foo _ Foo new.
	bar _ Bar new.
	g _ GenericBlock new.						self example: g with: foo with: bar.
	g at: { Foo. Foo } put: [:a :b | 'FooFoo '].		self example: g with: foo with: bar.
	g at: { Foo. Bar } put: [:a :b | 'FooBar '].		self example: g with: foo with: bar.
	g at: { Bar. Foo } put: [:a :b | 'BarFoo '].		self example: g with: foo with: bar.
	g at: { Bar. Bar } put: [:a :b | 'BarBar '].		self example: g with: foo with: bar.! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 18:38'!
example2
	"GenericBlock example2"

	| foo bar g |
	foo _ Foo new.
	bar _ Bar new.
	g _ GenericBlock new.										self example2: g with: foo with: bar.
	g at: { } put: ['thunk '].										self example2: g with: foo with: bar.
	g at: { Foo. } put: [:a | 'Foo '].								self example2: g with: foo with: bar.
	g at: { Bar. } put: [:a | 'Bar '].								self example2: g with: foo with: bar.
	g at: { Foo. Bar } put: [:a :b | 'FooBar '].						self example2: g with: foo with: bar.
	g at: { Foo. Bar } put: [:a :b | 'FooBar '].						self example2: g with: foo with: bar.
	g at: { Object. Object } put: [:a :b | 'Top '].					self example2: g with: foo with: bar.
	g at: { Bar. Bar. Foo } put: [:a :b :c | 'FooManchu '].			self example2: g with: bar with: foo.
	g at: { Bar. Foo. Bar } put: [:a :b :c | 'FooManchu '].			self example2: g with: bar with: foo.
	g at: { Object. Object. Object } put: [:a :b :c | 'Top '].			self example2: g with: bar with: foo.
	g at: { Bar. Bar. Bar } put: [:a :b :c | 'Sheep? '].				self example2: g with: foo with: bar.
	g at: { Foo. Foo. Foo } put: [:a :b :c | 'Crazy? '].				self example2: g with: foo with: bar.! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 19:23'!
example2: g with: a with: b

	[Transcript cr.
	 Transcript show: (g value).	 		 				Transcript show: (g value).
	 Transcript show: (g value: a).	 		 			Transcript show: (g value: a).
	 Transcript show: (g value: b).	 		 			Transcript show: (g value: b).
	 Transcript show: (g value: a value: a value: a).	Transcript show: (g value: a value: a value: a).
	 Transcript show: (g value: b value: b value: b).	Transcript show: (g value: b value: b value: b).
	 Transcript show: (g value: a value: a).	 			Transcript show: (g value: a value: a).
	 Transcript show: (g value: a value: b).	 			Transcript show: (g value: a value: b)]
		on: DispatchError
		do: [:ex | Transcript show: ex class printString].! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 18:26'!
example3
	"GenericBlock example3"

	| g |
	g _ GenericBlock new.
	g at: { } put: ['thunk '].
	g at: { Foo. } put: [:a | 'Foo '].
	g at: { Bar. } put: [:a :b | 'Mistake!! '].! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 19:03'!
example4
	"GenericBlock example4"

	| c b1 b10 g x |
	c _ 300000.
	g _ GenericBlock new.
	b1 _ [:o | o + 1].
	b10 _ [:f | f + 10].
	x _ 0.	Transcript cr; show: (Time millisecondsToRun: [[(x _ b1 value: x) < c] whileTrue]).
	g at: { Object } put: b1.
	x _ 0.	Transcript cr; show: (Time millisecondsToRun: [[(x _ g value: x) < c] whileTrue]).
	x _ 0.0.	Transcript cr; show: (Time millisecondsToRun: [[(x _ g value: x) < c] whileTrue]).
	g at: { Float } put: b10.
	x _ 0.	Transcript cr; show: (Time millisecondsToRun: [[(x _ g value: x) < c] whileTrue]).
	x _ 0.0.	Transcript cr; show: (Time millisecondsToRun: [[(x _ g value: x) < c] whileTrue]).
	! !

!GenericBlock class methodsFor: 'examples' stamp: 'ikp 8/16/2003 19:23'!
example: g with: a with: b

	[Transcript cr.
	 Transcript show: (g value: a value: a).	 Transcript show: (g value: a value: a).
	 Transcript show: (g value: a value: b).	 Transcript show: (g value: a value: b).
	 Transcript show: (g value: b value: a).	 Transcript show: (g value: b value: a).
	 Transcript show: (g value: b value: b).	 Transcript show: (g value: b value: b)]
		on: DispatchError
		do: [:ex | Transcript show: ex class printString].! !


!GenericMethod methodsFor: 'initialize-release' stamp: 'ikp 8/16/2003 18:25'!
signature: sig block: aBlock

	sig size == aBlock numArgs ifFalse: [self error: 'This block expects the wrong number of aguments.'].
	signature _ sig.
	block _ aBlock! !

!GenericMethod methodsFor: 'comparing' stamp: 'ikp 8/16/2003 17:15'!
= other

	^self signature = other signature! !

!GenericMethod methodsFor: 'comparing' stamp: 'ikp 8/16/2003 17:14'!
hash

	^self signature hash! !

!GenericMethod methodsFor: 'comparing' stamp: 'ikp 8/16/2003 17:15'!
partialOrder: other

	| lt gt |
	lt _ self signature isSubtypeOf: other signature.
	gt _ other signature isSubtypeOf: self signature.
	^(lt not & gt) not! !

!GenericMethod methodsFor: 'comparing' stamp: 'ikp 8/16/2003 17:15'!
strictOrder: other

	| lt gt |
	lt _ self signature isSubtypeOf: other signature.
	gt _ other signature isSubtypeOf: self signature.
	^lt & gt not! !

!GenericMethod methodsFor: 'testing' stamp: 'ikp 8/16/2003 17:14'!
isApplicable: type

	^type isSubtypeOf: self signature! !

!GenericMethod methodsFor: 'accessing' stamp: 'ikp 8/16/2003 14:59'!
block

	^block! !

!GenericMethod methodsFor: 'accessing' stamp: 'ikp 8/16/2003 13:54'!
signature

	^signature! !

!GenericMethod methodsFor: 'printing' stamp: 'ikp 8/16/2003 17:14'!
printOn: aStream

	aStream nextPutAll: 'GenericMethod('.
	self signature do: [ :t | t printOn: aStream.  aStream space].
	aStream nextPut: $)! !


!GenericMethod class methodsFor: 'instance creation' stamp: 'ikp 8/16/2003 17:13'!
signature: sig block: aBlock

	^self new signature: (GenericType withAll: sig) block: aBlock! !


!GenericType methodsFor: 'testing' stamp: 'ikp 8/16/2003 14:30'!
isSubtypeOf: other

	self size == other size ifFalse: [^false].
	self with: other do: [ :a :b | (a includesBehavior: b) ifFalse: [^false]].
	^true! !