variable arity and dynamic extent issues for multimethod blocks aka

Stop me if you've heard this one before...

Being new to Smalltalk (in my case, I'm learning it to use Croquet), the
fist thing I tried to do is implement multi-argument dispatch blocks aka
multimethods, aka generic functions.

I'm amazed at how easy nearly everything was. But I did have two things I
couldn't figure out:

1) I want to have NextBlock be the next more general method within the
body of each method. This raised a lot of issues:

a) How do I bind NextBlock around the execution of each each block. The
mechanism I chose was to use a global variable and ensure: to dynamically
bind it. Alternatives welcome.

b) I couldn't figure out how define a block with indeterminate arity --
i.e. one that would take any number of arguments. In Common Lisp this is
done with an &rest argument. So I'm looking for the equivalent of
(lambda (&rest args) (apply f args))
Like:
[ what goes here? :args | f :valueWithArguments args ]

See  computeEffectiveMethodFromApplicableMeth
ods, below.

2) I'm gathering a lot of stuff into arrays with dynamic extent. It seems
wasteful. Is the Squeak compiler sufficiently smart to stack allocate
these? Should I care? Is there a better way?

Here's the complete code, with comments and a test suite. Pretty compact.
Smalltalk's pretty ...  All comments welcome. (Even including, "Stop
thinking in Lisp! Do XXXX instead!")


----------- Feel free to use this in any way you like. -----------------

Dictionary subclass: #MultiBlock
instanceVariableNames: 'cache '
classVariableNames: ''
poolDictionaries: ''
category: 'Multi-Blocks'!

!MultiBlock methodsFor: 'testing' stamp: 'hrs 10/10/2004 19:41'!
isApplicableSignature: methodSig to: argClasses
methodSig size = argClasses size ifFalse: [^false].
argClasses with: methodSig do:
[:argClass :methodClass | (argClass includesBehavior: methodClass)
ifFalse: [^false]].
^true	! !


!MultiBlock methodsFor: 'accessing' stamp: 'hrs 10/10/2004 20:12'!
at: signature put: block
"Add or replace a method.

e.g., myFunc at: #(Class1 Class2 ...) put: [:callNext :arg1 :arg2  ...|
body]

Within the body of the method, callNext is a block with the same
signature as the whole generic function. It executes the next more
general
method that applies to the given arguments."
self reset.
^super at: signature put: block
! !

!MultiBlock methodsFor: 'accessing' stamp: 'hrs 10/10/2004 19:46'!
computeApplicableMethods: classArray
| applicable |
applicable _ OrderedCollection new.
self keysAndValuesDo: [:key :value |  (self isApplicableSignature: key
to: classArray)
ifTrue: [applicable add: (Array with: key with: value)]].
^(applicable sortBy: [:a :b | self isMoreSpecific: a first than: b first
relativeTo: classArray])
collect: [:elt | elt second]
! !


!MultiBlock methodsFor: 'comparing' stamp: 'hrs 10/10/2004 19:42'!
isMoreSpecific: sig1 than: sig2 relativeTo: args
"Should the method with sig1 be chosen ahead of the one with sig2 for the
given args.
Both methods are known to be applicable.

There's lots of ways to do this. This implementation follows the default
in Lisp. We look at the classes
from left to right. At the first place they differ, we pick the the class
that apears earlier in the ordered
superclasses of the class of the actual argument.

Dylan always treats all arguments equally: If m1 is more specific in the
first arg bug m2 is more
specific in the second arg, then the ordering is ambiguous and an error
is signalled. (Lisp's mechanism
is not ambiguous but it's not clear that such behavior is actually useful.)

Both Lisp and Dylan have multiple inheritance. If we were to combine
Dylan's mechanism with Smalltalks
single inheritance, methods would always be totally statically ordered
(sig1 <= sig2)."
| c1 c2|
1 to: args size do: [:i | c1_sig1 at: i. c2_sig2 at: i.
c1~=c2 ifTrue:
"In multiple inheritance we would return true if c1 occurs
earliear than c2 in
the linearized class precedence list of (args at: i)."
[^c1 includesBehavior: c2]]! !


!MultiBlock methodsFor: 'updating' stamp: 'hrs 10/10/2004 20:25'!
 computeEffectiveMethodFromApplicableMeth
ods: methodBlockArray
"Converts a sequence of supplied method blocks to a single effective
method block.
The simple way to do this would be just ^methodBlockArray first.
However, we want nextBlock to be bound to the next less specific method
block during the evaluation of each
method block."
| remainingMethods nextEffectiveMethod thisMethod oldNextBlock  |
remainingMethods _ methodBlockArray allButFirst.
remainingMethods isEmpty
ifTrue: [nextEffectiveMethod _ [:args | Error signal: 'No next method']]
ifFalse: [nextEffectiveMethod _ self
 computeEffectiveMethodFromApplicableMeth
ods: remainingMethods].
thisMethod _ methodBlockArray at: 1.
^[:args |
oldNextBlock_NextBlock.
NextBlock_nextEffectiveMethod.
[thisMethod valueWithArguments: args]
ensure: [NextBlock_oldNextBlock]] ! !

!MultiBlock methodsFor: 'updating' stamp: 'hrs 10/10/2004 20:26'!
effectiveMethodFor: classArray
^cache at: classArray
ifAbsent: [cache at: classArray
put: (self
 computeEffectiveMethodFromApplicableMeth
ods:
(self
computeApplicableMethods: classArray))]! !

!MultiBlock methodsFor: 'updating' stamp: 'hrs 10/10/2004 20:22'!
reset
cache _ Dictionary new! !


!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:29'!
value
^(self effectiveMethodFor: #()) value: #()! !

!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:30'!
value: arg1
^(self effectiveMethodFor:
(Array with: arg1 class))
value: (Array with: arg1)! !

!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:30'!
value: arg1 value: arg2
^(self effectiveMethodFor:
(Array with: arg1 class
with: arg2 class))
value: (Array with: arg1
with: arg2)! !

!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:31'!
value: arg1 value: arg2 value: arg3
^(self effectiveMethodFor:
(Array with: arg1 class
with: arg2 class
with: arg3 class))
value: (Array with: arg1
with: arg2
with: arg3)! !

!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:32'!
value: arg1 value: arg2 value: arg3 value: arg4
^(self effectiveMethodFor:
(Array with: arg1 class
with: arg2 class
with: arg3 class
with: arg4 class))
value: (Array with: arg1
with: arg2
with: arg3
with: arg4)! !

!MultiBlock methodsFor: 'evaluating' stamp: 'hrs 10/10/2004 20:32'!
valueWithArguments: argArray
^(self effectiveMethodFor: (argArray collect: [:arg | arg class])) value:
argArray! !


TestCase subclass: #MultiBlockTest
instanceVariableNames: 'f g sig sigObjectObject
sigSmallIntegerSmallInteger sigSmallIntegerObject sigObjectSmallInteger
sigCharacterSmallInteger '
classVariableNames: ''
poolDictionaries: ''
category: 'Multi-Blocks'!

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:14'!
setUp

sig _ #(). "An empty (nullary) signature."

sigObjectObject _ Array with: Object with: Object.
sigSmallIntegerSmallInteger _ Array with: SmallInteger with: SmallInteger.
sigCharacterSmallInteger _ Array with: Character with: SmallInteger.
sigSmallIntegerObject _ Array with: SmallInteger with: Object.
sigObjectSmallInteger _ Array with: Object with: SmallInteger.
! !

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:38'!
testBinary
f _ MultiBlock new.
f at: sigObjectObject 					put: [:x :y |  'obj=', x asString, ' obj=', y
asString].
f at: sigSmallIntegerSmallInteger 	put: [:x :y |  'int=', x asString, '
int=', y asString].
f at: sigCharacterSmallInteger 		put: [:x :y |  'char=', x asString, '
int=', y asString].

self assert: (f value: 'astring' value: 'bstring') = 'obj=astring
obj=bstring'.
self assert: (f value: 1 value: 2) = 'int=1 int=2'.
self assert: (f value: $a value: 2) = 'char=a int=2'.
self assert: (f value: $a value: 'two') = 'obj=a obj=two'.
self assert: (f value: 1 value: $a) = 'obj=1 obj=a'.
self assert: (f value: 'astring' value: 2) = 'obj=astring obj=2'.! !

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:44'!
testHandlesChanges
f _ MultiBlock new.
f at: sigObjectObject put: [:t1 :t2 | 'first method'].
self assert: (f value: 1 value: 2) = 'first method'.

f at: sigObjectObject put: [:t1 :t2 | 'second method'].
self assert: (f value: 1 value: 2) = 'second method'.! !

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:40'!
testLeftToRightMostSpecificFirst
"Dylan says this should raise an error indicating that the choice of
method is ambiguous.
The results shown here follow Common Lisp."
f _ MultiBlock new.
f at: sigObjectSmallInteger 		put: [:x :y |  'obj=', x asString, ' int=',
y asString].
f at: sigSmallIntegerObject 		put: [:x :y |  'int=', x asString, ' obj=',
y asString].
self assert: (f value: 1 value: $a) = 'int=1 obj=a'.! !

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:52'!
testNextBlock
"NextBlock is the equivalent of 'super' for multimethod. It is is the
next less specific block.
Unfortunately, the current implementation has a quirk:
You call it with a list of arguments as a single variable, instead of
being spread out."
f _ MultiBlock new.
f at: sigObjectObject 					put: [:x :y |  'obj=', x asString, ' obj=', y
asString].
f at: sigSmallIntegerSmallInteger 	put: [:x :y |  'int=', x asString, '
int=', y asString, ' > ',
(NextBlock value: (Array with: x with: y))].
f at: sigObjectSmallInteger			put: [:x :y |  'obj=', x asString, ' int=',
y asString, ' > ',
(NextBlock value: (Array with: x with: y))].
self assert: (f value: 1 value: 2) = 'int=1 int=2 > obj=1 int=2 > obj=1
obj=2'
! !

!MultiBlockTest methodsFor: 'Running' stamp: 'hrs 10/11/2004 20:22'!
testNullary
f _ MultiBlock new.
f at: sig put: ['no args'].
self assert: f value = 'no args'.
self should: [f value: 3] raise: Error
! !