From be5f77a319c79b0de92f59126f31f9d9d330a9be Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 28 Jan 2018 11:42:58 -0600 Subject: [PATCH] multi-methods: Rename stuff. About to refactor. --- extra/boolean-expr/boolean-expr.factor | 15 +++--- extra/flatland/flatland.factor | 49 ++++++++++---------- extra/multi-methods/multi-methods.factor | 23 +++++---- extra/multi-methods/tests/definitions.factor | 4 +- extra/multi-methods/tests/syntax.factor | 9 ++-- 5 files changed, 50 insertions(+), 50 deletions(-) diff --git a/extra/boolean-expr/boolean-expr.factor b/extra/boolean-expr/boolean-expr.factor index 46449d7486..a57624b73b 100644 --- a/extra/boolean-expr/boolean-expr.factor +++ b/extra/boolean-expr/boolean-expr.factor @@ -2,7 +2,6 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes kernel sequences sets io prettyprint ; -FROM: multi-methods => GENERIC: METHOD: ; IN: boolean-expr TUPLE: ⋀ x y ; @@ -15,7 +14,7 @@ SINGLETONS: P Q R S T U V W X Y Z ; UNION: □ ⋀ ⋁ ¬ ⊤ ⊥ P Q R S T U V W X Y Z ; -GENERIC: ⋀ ( x y -- expr ) +MULTI-GENERIC: ⋀ ( x y -- expr ) METHOD: ⋀ { ⊤ □ } nip ; METHOD: ⋀ { □ ⊤ } drop ; @@ -27,7 +26,7 @@ METHOD: ⋀ { □ ⋁ } [ x>> ⋀ ] [ y>> ⋀ ] 2bi ⋁ ; METHOD: ⋀ { □ □ } \ ⋀ boa ; -GENERIC: ⋁ ( x y -- expr ) +MULTI-GENERIC: ⋁ ( x y -- expr ) METHOD: ⋁ { ⊤ □ } drop ; METHOD: ⋁ { □ ⊤ } nip ; @@ -36,7 +35,7 @@ METHOD: ⋁ { □ ⊥ } drop ; METHOD: ⋁ { □ □ } \ ⋁ boa ; -GENERIC: ¬ ( x -- expr ) +MULTI-GENERIC: ¬ ( x -- expr ) METHOD: ¬ { ⊤ } drop ⊥ ; METHOD: ¬ { ⊥ } drop ⊤ ; @@ -50,17 +49,17 @@ METHOD: ¬ { □ } \ ¬ boa ; : ⊕ ( x y -- expr ) [ ⋁ ] [ ⋀ ¬ ] 2bi ⋀ ; : ≣ ( x y -- expr ) [ ⋀ ] [ [ ¬ ] bi@ ⋀ ] 2bi ⋁ ; -GENERIC: (dnf) ( expr -- dnf ) +MULTI-GENERIC: (dnf) ( expr -- dnf ) METHOD: (dnf) { ⋀ } [ x>> (dnf) ] [ y>> (dnf) ] bi append ; METHOD: (dnf) { □ } 1array ; -GENERIC: dnf ( expr -- dnf ) +MULTI-GENERIC: dnf ( expr -- dnf ) METHOD: dnf { ⋁ } [ x>> dnf ] [ y>> dnf ] bi append ; METHOD: dnf { □ } (dnf) 1array ; -GENERIC: satisfiable? ( expr -- ? ) +MULTI-GENERIC: satisfiable? ( expr -- ? ) METHOD: satisfiable? { ⊤ } drop t ; METHOD: satisfiable? { ⊥ } drop f ; @@ -72,7 +71,7 @@ METHOD: satisfiable? { ⊥ } drop f ; METHOD: satisfiable? { □ } dnf [ (satisfiable?) ] any? ; -GENERIC: (expr.) ( expr -- ) +MULTI-GENERIC: (expr.) ( expr -- ) METHOD: (expr.) { □ } pprint ; diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor index 7e83e9dd53..12b58513f9 100644 --- a/extra/flatland/flatland.factor +++ b/extra/flatland/flatland.factor @@ -2,56 +2,55 @@ USING: accessors arrays combinators combinators.short-circuit fry kernel locals math math.intervals math.vectors multi-methods sequences ; -FROM: multi-methods => \GENERIC: ; IN: flatland ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Two dimensional world protocol -GENERIC: x ( obj -- x ) -GENERIC: y ( obj -- y ) +MULTI-GENERIC: x ( obj -- x ) +MULTI-GENERIC: y ( obj -- y ) -GENERIC: (x!) ( x obj -- ) -GENERIC: (y!) ( y obj -- ) +MULTI-GENERIC: (x!) ( x obj -- ) +MULTI-GENERIC: (y!) ( y obj -- ) : x! ( obj x -- obj ) over (x!) ; : y! ( obj y -- obj ) over (y!) ; -GENERIC: width ( obj -- width ) -GENERIC: height ( obj -- height ) +MULTI-GENERIC: width ( obj -- width ) +MULTI-GENERIC: height ( obj -- height ) -GENERIC: (width!) ( width obj -- ) -GENERIC: (height!) ( height obj -- ) +MULTI-GENERIC: (width!) ( width obj -- ) +MULTI-GENERIC: (height!) ( height obj -- ) : width! ( obj width -- obj ) over (width!) ; : height! ( obj height -- obj ) over (width!) ; ! Predicates on relative placement -GENERIC: to-the-left-of? ( obj obj -- ? ) -GENERIC: to-the-right-of? ( obj obj -- ? ) +MULTI-GENERIC: to-the-left-of? ( obj obj -- ? ) +MULTI-GENERIC: to-the-right-of? ( obj obj -- ? ) -GENERIC: below? ( obj obj -- ? ) -GENERIC: above? ( obj obj -- ? ) +MULTI-GENERIC: below? ( obj obj -- ? ) +MULTI-GENERIC: above? ( obj obj -- ? ) -GENERIC: in-between-horizontally? ( obj obj -- ? ) +MULTI-GENERIC: in-between-horizontally? ( obj obj -- ? ) -GENERIC: horizontal-interval ( obj -- interval ) +MULTI-GENERIC: horizontal-interval ( obj -- interval ) -GENERIC: move-to ( obj obj -- ) +MULTI-GENERIC: move-to ( obj obj -- ) -GENERIC: move-by ( obj delta -- ) +MULTI-GENERIC: move-by ( obj delta -- ) -GENERIC: move-left-by ( obj obj -- ) -GENERIC: move-right-by ( obj obj -- ) +MULTI-GENERIC: move-left-by ( obj obj -- ) +MULTI-GENERIC: move-right-by ( obj obj -- ) -GENERIC: left ( obj -- left ) -GENERIC: right ( obj -- right ) -GENERIC: bottom ( obj -- bottom ) -GENERIC: top ( obj -- top ) +MULTI-GENERIC: left ( obj -- left ) +MULTI-GENERIC: right ( obj -- right ) +MULTI-GENERIC: bottom ( obj -- bottom ) +MULTI-GENERIC: top ( obj -- top ) -GENERIC: distance ( a b -- c ) +MULTI-GENERIC: distance ( a b -- c ) ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -216,7 +215,7 @@ METHOD: above? { sequence rectangle } [ y ] [ top ] bi* > ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -GENERIC: within? ( a b -- ? ) +MULTI-GENERIC: within? ( a b -- ? ) METHOD: within? { pos rectangle } { diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index e580e2ede8..db335276af 100644 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -140,14 +140,14 @@ PREDICATE: generic < word : methods ( word -- alist ) "multi-methods" word-prop >alist ; -: make-generic ( generic -- quot ) +: make-multi-generic ( generic -- quot ) [ [ methods prepare-methods % sort-methods ] keep multi-dispatch-quot % ] [ ] make ; : update-generic ( word -- ) - dup make-generic define ; + dup make-multi-generic define ; ! Methods PREDICATE: method-body < word @@ -215,7 +215,7 @@ M: no-method error. [ "multi-method-specializer" word-prop ] [ "multi-method-generic" word-prop ] bi prefix ; -: define-generic ( word effect -- ) +: define-multi-generic ( word effect -- ) over set-stack-effect dup "multi-methods" word-prop [ drop ] [ [ H{ } clone "multi-methods" set-word-prop ] @@ -224,31 +224,34 @@ M: no-method error. ] if ; ! Syntax -SYNTAX: \GENERIC: scan-new-word scan-effect define-generic ; +SYNTAX: \MULTI-GENERIC: scan-new-word scan-effect define-multi-generic ; + +SYNTAX: \MULTI-HOOK: + scan-new-word scan-object 2array scan-effect define-multi-generic ; : parse-method ( -- quot classes generic ) parse-definition [ 2 tail ] [ second ] [ first ] tri ; -: create-method-in ( specializer generic -- method ) +: create-multi-method-in ( specializer generic -- method ) create-method dup save-location f set-last-word ; -: scan-new-method ( -- method ) - scan-word scan-object swap create-method-in ; +: scan-new-multi-method ( -- method ) + scan-word scan-object swap create-multi-method-in ; -: (METHOD:) ( -- method def ) scan-new-method parse-definition ; +: (METHOD:) ( -- method def ) scan-new-multi-method parse-definition ; SYNTAX: \METHOD: (METHOD:) define ; ! For compatibility SYNTAX: \M: - scan-word 1array scan-word create-method-in + scan-word 1array scan-word create-multi-method-in parse-definition define ; ! Definition protocol. We qualify core generics here QUALIFIED: syntax -syntax::M: generic definer drop \ GENERIC: f ; +syntax::M: generic definer drop \ MULTI-GENERIC: f ; syntax::M: generic definition drop f ; diff --git a/extra/multi-methods/tests/definitions.factor b/extra/multi-methods/tests/definitions.factor index 20d82bff2c..ae683ddd84 100644 --- a/extra/multi-methods/tests/definitions.factor +++ b/extra/multi-methods/tests/definitions.factor @@ -19,11 +19,11 @@ DEFER: testing [ t ] [ { } \ fake multi-dispatch-quot callable? ] unit-test - [ t ] [ \ fake make-generic quotation? ] unit-test + [ t ] [ \ fake make-multi-generic quotation? ] unit-test [ ] [ \ fake update-generic ] unit-test - [ ] [ \ testing ( -- ) define-generic ] unit-test + [ ] [ \ testing ( -- ) define-multi-generic ] unit-test [ t ] [ \ testing generic? ] unit-test ] with-compilation-unit diff --git a/extra/multi-methods/tests/syntax.factor b/extra/multi-methods/tests/syntax.factor index 1ca0be472f..31596e6092 100644 --- a/extra/multi-methods/tests/syntax.factor +++ b/extra/multi-methods/tests/syntax.factor @@ -1,10 +1,9 @@ USING: multi-methods tools.test math sequences namespaces system kernel strings definitions prettyprint debugger arrays hashtables continuations classes assocs accessors see ; -RENAME: \GENERIC: multi-methods => \multi-methods:GENERIC: IN: multi-methods.tests -multi-methods:GENERIC: first-test ( -- ) +MULTI-GENERIC: first-test ( -- ) [ t ] [ \ first-test generic? ] unit-test @@ -14,7 +13,7 @@ SINGLETON: paper INSTANCE: paper thing SINGLETON: scissors INSTANCE: scissors thing SINGLETON: rock INSTANCE: rock thing -multi-methods:GENERIC: beats? ( obj1 obj2 -- ? ) +MULTI-GENERIC: beats? ( obj1 obj2 -- ? ) METHOD: beats? { paper scissors } 2drop t ; METHOD: beats? { scissors rock } 2drop t ; @@ -35,7 +34,7 @@ METHOD: beats? { thing thing } 2drop f ; SYMBOL: some-var -multi-methods:GENERIC: hook-test ( obj -- obj ) +MULTI-GENERIC: hook-test ( obj -- obj ) METHOD: hook-test { array { some-var array } } reverse ; METHOD: hook-test { { some-var array } } class-of ; @@ -58,7 +57,7 @@ TUPLE: busted-1 ; TUPLE: busted-2 ; INSTANCE: busted-2 busted TUPLE: busted-3 ; -multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) +MULTI-GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 ) METHOD: busted-sort { busted-1 busted-2 } ; METHOD: busted-sort { busted-2 busted-3 } ;