diff --git a/extra/multi-methods/multi-methods-tests.factor b/extra/multi-methods/multi-methods-tests.factor
deleted file mode 100755
index 8910e64092..0000000000
--- a/extra/multi-methods/multi-methods-tests.factor
+++ /dev/null
@@ -1,98 +0,0 @@
-IN: multi-methods.tests
-USING: multi-methods tools.test kernel math arrays sequences
-prettyprint strings classes hashtables assocs namespaces
-debugger continuations ;
-
-[ { 1 2 3 4 5 6 } ] [
- { 6 4 5 1 3 2 } [ <=> ] topological-sort
-] unit-test
-
-[ -1 ] [
- { fixnum array } { number sequence } classes<
-] unit-test
-
-[ 0 ] [
- { number sequence } { number sequence } classes<
-] unit-test
-
-[ 1 ] [
- { object object } { number sequence } classes<
-] unit-test
-
-[
- {
- { { object integer } [ 1 ] }
- { { object object } [ 2 ] }
- { { POSTPONE: f POSTPONE: f } [ 3 ] }
- }
-] [
- {
- { { integer } [ 1 ] }
- { { } [ 2 ] }
- { { f f } [ 3 ] }
- } congruify-methods
-] unit-test
-
-GENERIC: first-test
-
-[ t ] [ \ first-test generic? ] unit-test
-
-MIXIN: thing
-
-TUPLE: paper ; INSTANCE: paper thing
-TUPLE: scissors ; INSTANCE: scissors thing
-TUPLE: rock ; INSTANCE: rock thing
-
-GENERIC: beats?
-
-METHOD: beats? { paper scissors } t ;
-METHOD: beats? { scissors rock } t ;
-METHOD: beats? { rock paper } t ;
-METHOD: beats? { thing thing } f ;
-
-: play ( obj1 obj2 -- ? ) beats? 2nip ;
-
-[ { } 3 play ] must-fail
-[ t ] [ error get no-method? ] unit-test
-[ ] [ error get error. ] unit-test
-[ t ] [ T{ paper } T{ scissors } play ] unit-test
-[ f ] [ T{ scissors } T{ paper } play ] unit-test
-
-[ t ] [ { beats? paper scissors } method-spec? ] unit-test
-[ ] [ { beats? paper scissors } see ] unit-test
-
-GENERIC: legacy-test
-
-M: integer legacy-test sq ;
-M: string legacy-test " hey" append ;
-
-[ 25 ] [ 5 legacy-test ] unit-test
-[ "hello hey" ] [ "hello" legacy-test ] unit-test
-
-SYMBOL: some-var
-
-HOOK: hook-test some-var
-
-[ t ] [ \ hook-test hook-generic? ] unit-test
-
-METHOD: hook-test { array array } reverse ;
-METHOD: hook-test { array } class ;
-METHOD: hook-test { hashtable number } assoc-size ;
-
-{ 1 2 3 } some-var set
-[ { f t t } ] [ { t t f } hook-test ] unit-test
-[ fixnum ] [ 3 hook-test ] unit-test
-5.0 some-var set
-[ 0 ] [ H{ } hook-test ] unit-test
-
-MIXIN: busted
-
-TUPLE: busted-1 ;
-TUPLE: busted-2 ; INSTANCE: busted-2 busted
-TUPLE: busted-3 ;
-
-GENERIC: busted-sort
-
-METHOD: busted-sort { busted-1 busted-2 } ;
-METHOD: busted-sort { busted-2 busted-3 } ;
-METHOD: busted-sort { busted busted } ;
diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor
index 115432b14d..0276e1422c 100755
--- a/extra/multi-methods/multi-methods.factor
+++ b/extra/multi-methods/multi-methods.factor
@@ -3,13 +3,74 @@
USING: kernel math sequences vectors classes classes.algebra
combinators arrays words assocs parser namespaces definitions
prettyprint prettyprint.backend quotations arrays.lib
-debugger io compiler.units kernel.private effects ;
+debugger io compiler.units kernel.private effects accessors
+hashtables sorting shuffle ;
IN: multi-methods
-GENERIC: generic-prologue ( combination -- quot )
+! PART I: Converting hook specializers
+: canonicalize-specializer-0 ( specializer -- specializer' )
+ [ \ f or ] map ;
-GENERIC: method-prologue ( combination -- quot )
+SYMBOL: args
+SYMBOL: hooks
+
+SYMBOL: total
+
+: canonicalize-specializer-1 ( specializer -- specializer' )
+ [
+ [ class? ] subset
+ [ length <reversed> [ 1+ neg ] map ] keep zip
+ [ length args [ max ] change ] keep
+ ]
+ [
+ [ pair? ] subset
+ [ keys [ hooks get push-new ] each ] keep
+ ] bi append ;
+
+: canonicalize-specializer-2 ( specializer -- specializer' )
+ [
+ >r
+ {
+ { [ dup integer? ] [ ] }
+ { [ dup word? ] [ hooks get index ] }
+ } cond args get + r>
+ ] assoc-map ;
+
+: canonicalize-specializer-3 ( specializer -- specializer' )
+ >r total get object <array> dup <enum> r> update ;
+
+: canonicalize-specializers ( methods -- methods' hooks )
+ [
+ [ >r canonicalize-specializer-0 r> ] assoc-map
+
+ 0 args set
+ V{ } clone hooks set
+
+ [ >r canonicalize-specializer-1 r> ] assoc-map
+
+ hooks [ natural-sort ] change
+
+ [ >r canonicalize-specializer-2 r> ] assoc-map
+
+ args get hooks get length + total set
+
+ [ >r canonicalize-specializer-3 r> ] assoc-map
+
+ hooks get
+ ] with-scope ;
+
+: drop-n-quot ( n -- quot ) \ drop <repetition> >quotation ;
+
+: prepare-method ( method n -- quot )
+ [ 1quotation ] [ drop-n-quot ] bi* prepend ;
+
+: prepare-methods ( methods -- methods' prologue )
+ canonicalize-specializers
+ [ length [ prepare-method ] curry assoc-map ] keep
+ [ [ get ] curry ] map concat [ ] like ;
+
+! Part II: Topologically sorting specializers
: maximal-element ( seq quot -- n elt )
dupd [
swapd [ call 0 < ] 2curry subset empty?
@@ -32,6 +93,10 @@ GENERIC: method-prologue ( combination -- quot )
} cond 2nip
] 2map [ zero? not ] find nip 0 or ;
+: sort-methods ( alist -- alist' )
+ [ [ first ] bi@ classes< ] topological-sort ;
+
+! PART III: Creating dispatch quotation
: picker ( n -- quot )
{
{ 0 [ [ dup ] ] }
@@ -52,209 +117,171 @@ GENERIC: method-prologue ( combination -- quot )
unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
] if ;
+: multi-dispatch-quot ( methods generic -- quot )
+ "default-multi-method" word-prop 1quotation swap
+ [ >r multi-predicate r> ] assoc-map reverse alist>quot ;
+
+! Generic words
+PREDICATE: generic < word
+ "multi-methods" word-prop >boolean ;
+
: methods ( word -- alist )
"multi-methods" word-prop >alist ;
-: make-method-def ( quot classes generic -- quot )
+: make-generic ( generic -- quot )
[
- swap [ declare ] curry %
- "multi-combination" word-prop method-prologue %
- %
+ [ methods prepare-methods % sort-methods ] keep
+ multi-dispatch-quot %
] [ ] make ;
-TUPLE: method word def classes generic loc ;
+: update-generic ( word -- )
+ dup make-generic define ;
+! Methods
PREDICATE: method-body < word
- "multi-method" word-prop >boolean ;
+ "multi-method-generic" word-prop >boolean ;
M: method-body stack-effect
- "multi-method" word-prop method-generic stack-effect ;
+ "multi-method-generic" word-prop stack-effect ;
M: method-body crossref?
drop t ;
-: method-word-name ( classes generic -- string )
+: method-word-name ( specializer generic -- string )
+ [ word-name % "-" % unparse % ] "" make ;
+
+: method-word-props ( specializer generic -- assoc )
[
- word-name %
- "-(" % [ "," % ] [ word-name % ] interleave ")" %
- ] "" make ;
+ "multi-method-generic" set
+ "multi-method-specializer" set
+ ] H{ } make-assoc ;
-: <method-word> ( quot classes generic -- word )
- #! We xref here because the "multi-method" word-prop isn't
- #! set yet so crossref? yields f.
- [ make-method-def ] 2keep
+: <method> ( specializer generic -- word )
+ [ method-word-props ] 2keep
method-word-name f <word>
- dup rot define
- dup xref ;
+ [ set-word-props ] keep ;
-: <method> ( quot classes generic -- method )
- [ <method-word> ] 3keep f \ method construct-boa
- dup method-word over "multi-method" set-word-prop ;
+: with-methods ( word quot -- )
+ over >r >r "multi-methods" word-prop
+ r> call r> update-generic ; inline
+
+: reveal-method ( method classes generic -- )
+ [ set-at ] with-methods ;
+
+: method ( classes word -- method )
+ "multi-methods" word-prop at ;
+
+: create-method ( classes generic -- method )
+ 2dup method dup [
+ 2nip
+ ] [
+ drop [ <method> dup ] 2keep reveal-method
+ ] if ;
TUPLE: no-method arguments generic ;
: no-method ( argument-count generic -- * )
>r narray r> \ no-method construct-boa throw ; inline
-: argument-count ( methods -- n )
- dup assoc-empty? [ drop 0 ] [
- keys [ length ] map supremum
- ] if ;
-
-: multi-dispatch-quot ( methods generic -- quot )
- >r [
- [
- >r multi-predicate r> method-word 1quotation
- ] assoc-map
- ] keep argument-count
- r> [ no-method ] 2curry
- swap reverse alist>quot ;
-
-: congruify-methods ( alist -- alist' )
- dup argument-count [
- swap >r object pad-left [ \ f or ] map r>
- ] curry assoc-map ;
-
-: sorted-methods ( alist -- alist' )
- [ [ first ] bi@ classes< ] topological-sort ;
-
: niceify-method [ dup \ f eq? [ drop f ] when ] map ;
M: no-method error.
"Type check error" print
nl
- "Generic word " write dup no-method-generic pprint
+ "Generic word " write dup generic>> pprint
" does not have a method applicable to inputs:" print
- dup no-method-arguments short.
+ dup arguments>> short.
nl
"Inputs have signature:" print
- dup no-method-arguments [ class ] map niceify-method .
+ dup arguments>> [ class ] map niceify-method .
nl
- "Defined methods in topological order: " print
- no-method-generic
- methods congruify-methods sorted-methods keys
+ "Available methods: " print
+ generic>> methods keys
[ niceify-method ] map stack. ;
-TUPLE: standard-combination ;
+: make-default-method ( generic -- quot )
+ [ 0 swap no-method ] curry ;
-M: standard-combination method-prologue drop [ ] ;
+: <default-method> ( generic -- method )
+ [ { } swap <method> ] keep
+ [ drop ] [ make-default-method define ] 2bi ;
-M: standard-combination generic-prologue drop [ ] ;
+: define-default-method ( generic -- )
+ dup <default-method> "default-multi-method" set-word-prop ;
-: make-generic ( generic -- quot )
- dup "multi-combination" word-prop generic-prologue swap
- [ methods congruify-methods sorted-methods ] keep
- multi-dispatch-quot append ;
-
-TUPLE: hook-combination var ;
-
-M: hook-combination method-prologue
- drop [ drop ] ;
-
-M: hook-combination generic-prologue
- hook-combination-var [ get ] curry ;
-
-: update-generic ( word -- )
- dup make-generic define ;
-
-: define-generic ( word combination -- )
- over "multi-combination" word-prop over = [
- 2drop
- ] [
- dupd "multi-combination" set-word-prop
- dup H{ } clone "multi-methods" set-word-prop
- update-generic
- ] if ;
-
-: define-standard-generic ( word -- )
- T{ standard-combination } define-generic ;
-
-: GENERIC:
- CREATE define-standard-generic ; parsing
-
-: define-hook-generic ( word var -- )
- hook-combination construct-boa define-generic ;
-
-: HOOK:
- CREATE scan-word define-hook-generic ; parsing
-
-: method ( classes word -- method )
- "multi-methods" word-prop at ;
-
-: with-methods ( word quot -- )
- over >r >r "multi-methods" word-prop
- r> call r> update-generic ; inline
-
-: define-method ( quot classes generic -- )
- >r [ bootstrap-word ] map r>
- [ <method> ] 2keep
- [ set-at ] with-methods ;
-
-: forget-method ( classes generic -- )
+: forget-method ( specializer generic -- )
[ delete-at ] with-methods ;
: method>spec ( method -- spec )
- dup method-classes swap method-generic prefix ;
+ [ "multi-method-specializer" word-prop ]
+ [ "multi-method-generic" word-prop ] bi prefix ;
+
+: define-generic ( word -- )
+ dup "multi-methods" word-prop [
+ drop
+ ] [
+ [ H{ } clone "multi-methods" set-word-prop ]
+ [ define-default-method ]
+ [ update-generic ]
+ tri
+ ] if ;
+
+! Syntax
+: GENERIC:
+ CREATE define-generic ; parsing
: parse-method ( -- quot classes generic )
- parse-definition dup 2 tail over second rot first ;
+ parse-definition [ 2 tail ] [ second ] [ first ] tri ;
-: METHOD:
- location
- >r parse-method [ define-method ] 2keep prefix r>
- remember-definition ; parsing
+: create-method-in ( specializer generic -- method )
+ create-method dup save-location f set-word ;
+
+: CREATE-METHOD
+ scan-word scan-object swap create-method-in ;
+
+: (METHOD:) CREATE-METHOD parse-definition ;
+
+: METHOD: (METHOD:) define ; parsing
! For compatibility
: M:
- scan-word 1array scan-word parse-definition
- -rot define-method ; parsing
+ scan-word 1array scan-word create-method-in
+ parse-definition
+ define ; parsing
! Definition protocol. We qualify core generics here
USE: qualified
QUALIFIED: syntax
-PREDICATE: generic < word
- "multi-combination" word-prop >boolean ;
+syntax:M: generic definer drop \ GENERIC: f ;
-PREDICATE: standard-generic < word
- "multi-combination" word-prop standard-combination? ;
-
-PREDICATE: hook-generic < word
- "multi-combination" word-prop hook-combination? ;
-
-syntax:M: standard-generic definer drop \ GENERIC: f ;
-
-syntax:M: standard-generic definition drop f ;
-
-syntax:M: hook-generic definer drop \ HOOK: f ;
-
-syntax:M: hook-generic definition drop f ;
-
-syntax:M: hook-generic synopsis*
- dup definer.
- dup seeing-word
- dup pprint-word
- dup "multi-combination" word-prop
- hook-combination-var pprint-word stack-effect. ;
+syntax:M: generic definition drop f ;
PREDICATE: method-spec < array
unclip generic? >r [ class? ] all? r> and ;
syntax:M: method-spec where
- dup unclip method [ method-loc ] [ second where ] ?if ;
+ dup unclip method [ ] [ first ] ?if where ;
syntax:M: method-spec set-where
- unclip method set-method-loc ;
+ unclip method set-where ;
syntax:M: method-spec definer
- drop \ METHOD: \ ; ;
+ unclip method definer ;
syntax:M: method-spec definition
- unclip method dup [ method-def ] when ;
+ unclip method definition ;
syntax:M: method-spec synopsis*
- dup definer.
- unclip pprint* pprint* ;
+ unclip method synopsis* ;
syntax:M: method-spec forget*
- unclip forget-method ;
+ unclip method forget* ;
+
+syntax:M: method-body definer
+ drop \ METHOD: \ ; ;
+
+syntax:M: method-body synopsis*
+ dup definer.
+ [ "multi-method-generic" word-prop pprint-word ]
+ [ "multi-method-specializer" word-prop pprint* ] bi ;
diff --git a/extra/multi-methods/tests/canonicalize.factor b/extra/multi-methods/tests/canonicalize.factor
new file mode 100644
index 0000000000..d5baf4914c
--- /dev/null
+++ b/extra/multi-methods/tests/canonicalize.factor
@@ -0,0 +1,66 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings ;
+
+[ { POSTPONE: f integer } ] [ { f integer } canonicalize-specializer-0 ] unit-test
+
+: setup-canon-test
+ 0 args set
+ V{ } clone hooks set ;
+
+: canon-test-1
+ { integer { cpu x86 } sequence } canonicalize-specializer-1 ;
+
+[ { { -2 integer } { -1 sequence } { cpu x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ ] with-scope
+] unit-test
+
+[ { { 0 integer } { 1 sequence } { 2 x86 } } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ ] with-scope
+] unit-test
+
+[ { integer sequence x86 } ] [
+ [
+ setup-canon-test
+ canon-test-1
+ canonicalize-specializer-2
+ args get hooks get length + total set
+ canonicalize-specializer-3
+ ] with-scope
+] unit-test
+
+: example-1
+ {
+ { { { cpu x86 } { os linux } } "a" }
+ { { { cpu ppc } } "b" }
+ { { string { os windows } } "c" }
+ } ;
+
+[
+ {
+ { { object x86 linux } "a" }
+ { { object ppc object } "b" }
+ { { string object windows } "c" }
+ }
+ V{ cpu os }
+] [
+ example-1 canonicalize-specializers
+] unit-test
+
+[
+ {
+ { { object x86 linux } [ drop drop "a" ] }
+ { { object ppc object } [ drop drop "b" ] }
+ { { string object windows } [ drop drop "c" ] }
+ }
+ [ \ cpu get \ os get ]
+] [
+ example-1 prepare-methods
+] unit-test
diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor
new file mode 100644
index 0000000000..60ddd32875
--- /dev/null
+++ b/extra/multi-methods/tests/definitions.factor
@@ -0,0 +1,37 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings words compiler.units quotations ;
+
+\ GENERIC: must-infer
+\ create-method-in must-infer
+\ define-default-method must-infer
+
+DEFER: fake
+\ fake H{ } clone "multi-methods" set-word-prop
+
+[ "fake-{ }" ] [ { } \ fake method-word-name ] unit-test
+
+[ H{ { "multi-method-generic" fake } { "multi-method-specializer" { } } } ]
+[ { } \ fake method-word-props ] unit-test
+
+[ t ] [ { } \ fake <method> method-body? ] unit-test
+
+[
+ [ ] [ \ fake define-default-method ] unit-test
+
+ [ { } [ ] ] [ \ fake methods prepare-methods >r sort-methods r> ] unit-test
+
+ [ t ] [ { } \ fake multi-dispatch-quot quotation? ] unit-test
+
+ [ t ] [ \ fake make-generic quotation? ] unit-test
+
+ [ ] [ \ fake update-generic ] unit-test
+
+ DEFER: testing
+
+ [ ] [ \ testing define-generic ] unit-test
+
+ [ t ] [ \ testing generic? ] unit-test
+
+ [ t ] [ \ testing "default-multi-method" word-prop method-body? ] unit-test
+] with-compilation-unit
diff --git a/extra/multi-methods/tests/legacy.factor b/extra/multi-methods/tests/legacy.factor
new file mode 100644
index 0000000000..f4bd0a00b2
--- /dev/null
+++ b/extra/multi-methods/tests/legacy.factor
@@ -0,0 +1,10 @@
+IN: multi-methods.tests
+USING: math strings sequences tools.test ;
+
+GENERIC: legacy-test
+
+M: integer legacy-test sq ;
+M: string legacy-test " hey" append ;
+
+[ 25 ] [ 5 legacy-test ] unit-test
+[ "hello hey" ] [ "hello" legacy-test ] unit-test
diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor
new file mode 100644
index 0000000000..5e2e86d04b
--- /dev/null
+++ b/extra/multi-methods/tests/syntax.factor
@@ -0,0 +1,58 @@
+IN: multi-methods.tests
+USING: multi-methods tools.test math sequences namespaces system
+kernel strings definitions prettyprint debugger arrays
+hashtables continuations classes assocs ;
+
+GENERIC: first-test
+
+[ t ] [ \ first-test generic? ] unit-test
+
+MIXIN: thing
+
+SINGLETON: paper INSTANCE: paper thing
+SINGLETON: scissors INSTANCE: scissors thing
+SINGLETON: rock INSTANCE: rock thing
+
+GENERIC: beats?
+
+METHOD: beats? { paper scissors } t ;
+METHOD: beats? { scissors rock } t ;
+METHOD: beats? { rock paper } t ;
+METHOD: beats? { thing thing } f ;
+
+: play ( obj1 obj2 -- ? ) beats? 2nip ;
+
+[ { } 3 play ] must-fail
+[ t ] [ error get no-method? ] unit-test
+[ ] [ error get error. ] unit-test
+[ t ] [ paper scissors play ] unit-test
+[ f ] [ scissors paper play ] unit-test
+
+[ t ] [ { beats? paper scissors } method-spec? ] unit-test
+[ ] [ { beats? paper scissors } see ] unit-test
+
+SYMBOL: some-var
+
+GENERIC: hook-test
+
+METHOD: hook-test { array { some-var array } } reverse ;
+METHOD: hook-test { { some-var array } } class ;
+METHOD: hook-test { hashtable { some-var number } } assoc-size ;
+
+{ 1 2 3 } some-var set
+[ { f t t } ] [ { t t f } hook-test ] unit-test
+[ fixnum ] [ 3 hook-test ] unit-test
+5.0 some-var set
+[ 0 ] [ H{ } hook-test ] unit-test
+
+MIXIN: busted
+
+TUPLE: busted-1 ;
+TUPLE: busted-2 ; INSTANCE: busted-2 busted
+TUPLE: busted-3 ;
+
+GENERIC: busted-sort
+
+METHOD: busted-sort { busted-1 busted-2 } ;
+METHOD: busted-sort { busted-2 busted-3 } ;
+METHOD: busted-sort { busted busted } ;
diff --git a/extra/multi-methods/tests/topological-sort.factor b/extra/multi-methods/tests/topological-sort.factor
new file mode 100644
index 0000000000..ed8bece4ba
--- /dev/null
+++ b/extra/multi-methods/tests/topological-sort.factor
@@ -0,0 +1,18 @@
+IN: multi-methods.tests
+USING: kernel multi-methods tools.test math arrays sequences ;
+
+[ { 1 2 3 4 5 6 } ] [
+ { 6 4 5 1 3 2 } [ <=> ] topological-sort
+] unit-test
+
+[ -1 ] [
+ { fixnum array } { number sequence } classes<
+] unit-test
+
+[ 0 ] [
+ { number sequence } { number sequence } classes<
+] unit-test
+
+[ 1 ] [
+ { object object } { number sequence } classes<
+] unit-test