steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

multi-methods: fix (1+ and 1- were recently removed) 

multi-methods: fix tests (ambiguity and incorrect stack effect)
Mitchell N Charity 2009-08-17 14:52:15 -04:00
parent a742145fd9
commit 661bef0ed0
2 changed files with 12 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
unmaintained/multi-methods/multi-methods.factor
View File

@ -21,7 +21,7 @@ SYMBOL: total
: canonicalize-specializer-1 ( specializer -- specializer' ) : canonicalize-specializer-1 ( specializer -- specializer' )
[ [
[ class? ] filter [ class? ] filter
[ length <reversed> [ 1+ neg ] map ] keep zip [ length <reversed> [ 1 + neg ] map ] keep zip
[ length args [ max ] change ] keep [ length args [ max ] change ] keep
] ]
[ [
@ -104,7 +104,7 @@ SYMBOL: total
{ 0 [ [ dup ] ] } { 0 [ [ dup ] ] }
{ 1 [ [ over ] ] } { 1 [ [ over ] ] }
{ 2 [ [ pick ] ] } { 2 [ [ pick ] ] }
[ 1- picker [ dip swap ] curry ] [ 1 - picker [ dip swap ] curry ]
} case ; } case ;
: (multi-predicate) ( class picker -- quot ) : (multi-predicate) ( class picker -- quot )

19
unmaintained/multi-methods/tests/syntax.factor
View File

@ -2,8 +2,9 @@ IN: multi-methods.tests
USING: multi-methods tools.test math sequences namespaces system USING: multi-methods tools.test math sequences namespaces system
kernel strings definitions prettyprint debugger arrays kernel strings definitions prettyprint debugger arrays
hashtables continuations classes assocs accessors see ; hashtables continuations classes assocs accessors see ;
RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
GENERIC: first-test ( -- ) multi-methods:GENERIC: first-test ( -- )
[ t ] [ \ first-test generic? ] unit-test [ t ] [ \ first-test generic? ] unit-test
@ -13,14 +14,14 @@ SINGLETON: paper INSTANCE: paper thing
SINGLETON: scissors INSTANCE: scissors thing SINGLETON: scissors INSTANCE: scissors thing
SINGLETON: rock INSTANCE: rock thing SINGLETON: rock INSTANCE: rock thing
GENERIC: beats? ( obj1 obj2 -- ? ) multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
METHOD: beats? { paper scissors } t ; METHOD: beats? { paper scissors } 2drop t ;
METHOD: beats? { scissors rock } t ; METHOD: beats? { scissors rock } 2drop t ;
METHOD: beats? { rock paper } t ; METHOD: beats? { rock paper } 2drop t ;
METHOD: beats? { thing thing } f ; METHOD: beats? { thing thing } 2drop f ;
: play ( obj1 obj2 -- ? ) beats? 2nip ; : play ( obj1 obj2 -- ? ) beats? ;
[ { } 3 play ] must-fail [ { } 3 play ] must-fail
[ t ] [ error get no-method? ] unit-test [ t ] [ error get no-method? ] unit-test
@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ;
SYMBOL: some-var SYMBOL: some-var
GENERIC: hook-test ( -- obj ) multi-methods:GENERIC: hook-test ( obj -- obj )
METHOD: hook-test { array { some-var array } } reverse ; METHOD: hook-test { array { some-var array } } reverse ;
METHOD: hook-test { { some-var array } } class ; METHOD: hook-test { { some-var array } } class ;
@ -57,7 +58,7 @@ TUPLE: busted-1 ;
TUPLE: busted-2 ; INSTANCE: busted-2 busted TUPLE: busted-2 ; INSTANCE: busted-2 busted
TUPLE: busted-3 ; TUPLE: busted-3 ;
GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
METHOD: busted-sort { busted-1 busted-2 } ; METHOD: busted-sort { busted-1 busted-2 } ;
METHOD: busted-sort { busted-2 busted-3 } ; METHOD: busted-sort { busted-2 busted-3 } ;