diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index 0276e1422c..8f9e34b1fb 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -117,9 +117,18 @@ SYMBOL: total unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; +: argument-count ( methods -- n ) + keys 0 [ length max ] reduce ; + +ERROR: no-method arguments generic ; + +: make-default-method ( methods generic -- quot ) + >r argument-count r> [ >r narray r> no-method ] 2curry ; + : multi-dispatch-quot ( methods generic -- quot ) - "default-multi-method" word-prop 1quotation swap - [ >r multi-predicate r> ] assoc-map reverse alist>quot ; + [ make-default-method ] + [ drop [ >r multi-predicate r> ] assoc-map reverse ] + 2bi alist>quot ; ! Generic words PREDICATE: generic < word @@ -178,11 +187,6 @@ M: method-body crossref? drop [ dup ] 2keep reveal-method ] if ; -TUPLE: no-method arguments generic ; - -: no-method ( argument-count generic -- * ) - >r narray r> \ no-method construct-boa throw ; inline - : niceify-method [ dup \ f eq? [ drop f ] when ] map ; M: no-method error. @@ -196,18 +200,8 @@ M: no-method error. dup arguments>> [ class ] map niceify-method . nl "Available methods: " print - generic>> methods keys - [ niceify-method ] map stack. ; - -: make-default-method ( generic -- quot ) - [ 0 swap no-method ] curry ; - -: ( generic -- method ) - [ { } swap ] keep - [ drop ] [ make-default-method define ] 2bi ; - -: define-default-method ( generic -- ) - dup "default-multi-method" set-word-prop ; + generic>> methods canonicalize-specializers drop sort-methods + keys [ niceify-method ] map stack. ; : forget-method ( specializer generic -- ) [ delete-at ] with-methods ; @@ -221,9 +215,8 @@ M: no-method error. drop ] [ [ H{ } clone "multi-methods" set-word-prop ] - [ define-default-method ] [ update-generic ] - tri + bi ] if ; ! Syntax diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 60ddd32875..fea8f0c402 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -4,7 +4,6 @@ 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 @@ -17,11 +16,9 @@ DEFER: fake [ t ] [ { } \ fake 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 multi-dispatch-quot callable? ] unit-test [ t ] [ \ fake make-generic quotation? ] unit-test diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 5e2e86d04b..597a1cebeb 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,7 +1,7 @@ IN: multi-methods.tests USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays -hashtables continuations classes assocs ; +hashtables continuations classes assocs accessors ; GENERIC: first-test @@ -25,6 +25,7 @@ METHOD: beats? { thing thing } f ; [ { } 3 play ] must-fail [ t ] [ error get no-method? ] unit-test [ ] [ error get error. ] unit-test +[ { { } 3 } ] [ error get arguments>> ] unit-test [ t ] [ paper scissors play ] unit-test [ f ] [ scissors paper play ] unit-test @@ -45,6 +46,11 @@ METHOD: hook-test { hashtable { some-var number } } assoc-size ; 5.0 some-var set [ 0 ] [ H{ } hook-test ] unit-test +"error" some-var set +[ H{ } hook-test ] must-fail +[ t ] [ error get no-method? ] unit-test +[ { H{ } "error" } ] [ error get arguments>> ] unit-test + MIXIN: busted TUPLE: busted-1 ;