From 48d31a2ca01989bb07ca75afafee4d4d3a2648cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 02:44:54 -0500 Subject: [PATCH] More changes to delegate --- extra/delegate/delegate-tests.factor | 11 +++-- extra/delegate/delegate.factor | 49 ++++++++++++++--------- extra/delegate/protocols/protocols.factor | 6 +-- 3 files changed, 38 insertions(+), 28 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 8563c12b75..497a6c5120 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -15,7 +15,8 @@ C: goodbye GENERIC: foo ( x -- y ) GENERIC: bar ( a -- b ) -PROTOCOL: baz foo bar ; +GENERIC# whoa 1 ( s t -- w ) +PROTOCOL: baz foo { bar 0 } { whoa 1 } ; : hello-test ( hello/goodbye -- array ) [ hello? ] [ hello-this ] [ hello-that ] tri 3array ; @@ -23,22 +24,26 @@ PROTOCOL: baz foo bar ; CONSULT: baz goodbye goodbye-these ; M: hello foo hello-this ; M: hello bar hello-test ; +M: hello whoa >r hello-this r> + ; GENERIC: bing ( c -- d ) +PROTOCOL: bee bing ; CONSULT: hello goodbye goodbye-those ; M: hello bing hello-test ; -MIMIC: bing goodbye hello +MIMIC: bee goodbye hello [ 1 { t 1 0 } ] [ 1 0 [ foo ] [ bar ] bi ] unit-test [ { t 1 0 } ] [ 1 0 bing ] unit-test [ 1 ] [ 1 0 f foo ] unit-test [ { t 1 0 } ] [ 1 0 f bar ] unit-test [ { f 1 0 } ] [ f 1 0 bing ] unit-test +[ 3 ] [ 1 0 2 whoa ] unit-test +[ 3 ] [ 1 0 f 2 whoa ] unit-test [ ] [ 10 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] unit-test [ V{ goodbye } ] [ baz protocol-users ] unit-test -[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar ;\n" ] +[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test ! [ ] [ [ baz forget ] with-compilation-unit ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index a32a44db0f..f8e238b7db 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: parser generic kernel classes words slots assocs sequences arrays -vectors definitions prettyprint ; +vectors definitions prettyprint combinators.lib math ; IN: delegate ! Protocols @@ -26,21 +26,27 @@ IN: delegate seq-diff forget-all-methods ; : define-protocol ( protocol wordlist -- ) - 2dup forget-old-definitions + ! 2dup forget-old-definitions { } like "protocol-words" set-word-prop ; +: fill-in-depth ( wordlist -- wordlist' ) + [ dup word? [ 0 2array ] when ] map ; + : PROTOCOL: CREATE-WORD dup define-symbol dup f "inline" set-word-prop - parse-definition define-protocol ; parsing + parse-definition fill-in-depth define-protocol ; parsing PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? M: protocol forget* [ users-and-words forget-all-methods ] [ call-next-method ] bi ; -M: protocol definition protocol-words ; +: show-words ( wordlist' -- wordlist ) + [ dup second zero? [ first ] when ] map ; + +M: protocol definition protocol-words show-words ; M: protocol definer drop \ PROTOCOL: \ ; ; @@ -51,18 +57,17 @@ GENERIC: group-words ( group -- words ) M: protocol group-words "protocol-words" word-prop ; -M: generic group-words - 1array ; - M: tuple-class group-words - "slots" word-prop - [ [ slot-spec-reader ] map ] - [ [ slot-spec-writer ] map ] bi append ; + "slot-names" word-prop [ + [ reader-word ] [ writer-word ] bi + 2array [ 0 2array ] map + ] map concat ; ! Consultation : define-consult-method ( word class quot -- ) - pick suffix >r swap create-method r> define ; + [ drop swap first create-method ] + [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ; : change-word-prop ( word prop quot -- ) >r swap word-props r> change-at ; inline @@ -70,24 +75,28 @@ M: tuple-class group-words : add ( item vector/f -- vector ) 2dup member? [ nip ] [ ?push ] if ; -: declare-consult ( class group -- ) +: use-protocol ( class group -- ) "protocol-users" [ add ] change-word-prop ; -: define-consult ( class group quot -- ) - >r 2dup declare-consult group-words swap r> +: define-consult ( group class quot -- ) + swapd >r 2dup use-protocol group-words swap r> [ define-consult-method ] 2curry each ; : CONSULT: - scan-word scan-word parse-definition swapd define-consult ; parsing + scan-word scan-word parse-definition define-consult ; parsing ! Mimic still needs to be updated +: mimic-method ( mimicker mimicked generic -- ) + tuck method + [ [ create-method-in ] [ word-def ] bi* define ] + [ 2drop ] if* ; + : define-mimic ( group mimicker mimicked -- ) - rot group-words -rot [ - pick "methods" word-prop at dup - [ >r swap create-method-in r> word-def define ] - [ 3drop ] if - ] 2curry each ; + [ drop swap use-protocol ] [ + rot group-words -rot + [ rot first mimic-method ] 2curry each + ] 3bi ; : MIMIC: scan-word scan-word scan-word define-mimic ; parsing diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index f9b4c8648d..b1435e0dbc 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -9,10 +9,8 @@ PROTOCOL: sequence-protocol set-nth set-nth-unsafe length set-length lengthen ; PROTOCOL: assoc-protocol - at* assoc-size >alist set-at assoc-clone-like + at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 } delete-at clear-assoc new-assoc assoc-like ; - ! assoc-find excluded because GENERIC# 1 - ! everything should work, just slower (with >alist) PROTOCOL: stream-protocol stream-read1 stream-read stream-read-until dispose @@ -28,5 +26,3 @@ PROTOCOL: prettyprint-section-protocol section-fits? indent-section? unindent-first-line? newline-after? short-section? short-section long-section
delegate>block add-section ; - -