From 2cebf7e9e59790ba5a9531e33b4c6509f35f9c4d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Apr 2008 18:51:56 -0500 Subject: [PATCH] Improve multi-methods: multi-var hooks --- .../multi-methods/multi-methods-tests.factor | 98 ------ extra/multi-methods/multi-methods.factor | 309 ++++++++++-------- extra/multi-methods/tests/canonicalize.factor | 66 ++++ extra/multi-methods/tests/definitions.factor | 37 +++ extra/multi-methods/tests/legacy.factor | 10 + extra/multi-methods/tests/syntax.factor | 58 ++++ .../tests/topological-sort.factor | 18 + 7 files changed, 357 insertions(+), 239 deletions(-) delete mode 100755 extra/multi-methods/multi-methods-tests.factor create mode 100644 extra/multi-methods/tests/canonicalize.factor create mode 100644 extra/multi-methods/tests/definitions.factor create mode 100644 extra/multi-methods/tests/legacy.factor create mode 100644 extra/multi-methods/tests/syntax.factor create mode 100644 extra/multi-methods/tests/topological-sort.factor 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 [ 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 dup 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 >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 ; -: ( 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 +: ( specializer generic -- word ) + [ method-word-props ] 2keep method-word-name f - dup rot define - dup xref ; + [ set-word-props ] keep ; -: ( quot classes generic -- method ) - [ ] 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 [ 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 [ ] ; +: ( generic -- method ) + [ { } swap ] keep + [ drop ] [ make-default-method define ] 2bi ; -M: standard-combination generic-prologue drop [ ] ; +: define-default-method ( generic -- ) + dup "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> - [ ] 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-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