From 90d4266867eb6af40590f1b05208b1db29aa763a Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 3 Apr 2008 19:17:58 -0500 Subject: [PATCH 1/4] Part of delegate changes --- extra/delegate/delegate-tests.factor | 8 +++++++- extra/delegate/delegate.factor | 18 ++++++++++++++---- 2 files changed, 21 insertions(+), 5 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index d66357daa5..2a0e013c1a 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,6 +1,12 @@ -USING: delegate kernel arrays tools.test ; +USING: delegate kernel arrays tools.test words math ; IN: delegate.tests +DEFER: example +[ 1 ] [ \ example 1 "prop" set-word-prop \ example "prop" word-prop ] unit-test +[ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test +[ 2 ] [ \ example "prop" word-prop ] unit-test + + TUPLE: hello this that ; C: hello diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 7f24d6258f..8ca99ec565 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,6 +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 ; +USING: parser generic kernel classes words slots assocs sequences arrays +vectors ; IN: delegate : define-protocol ( wordlist protocol -- ) @@ -18,7 +19,7 @@ M: protocol group-words "protocol-words" word-prop ; M: generic group-words - 1array ; + 1array ; M: tuple-class group-words "slots" word-prop 1 tail ! The first slot is the delegate @@ -27,10 +28,19 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add >r swap create-method r> define ; + pick add >r swap create-method-in r> define ; + +: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) ) + >r 3keep r> call ; inline + +: change-word-prop ( word prop quot -- ) + >r swap word-props r> change-at ; inline + +: declare-consult ( class group -- ) + "protocol-users" [ ?push ] change-word-prop ; : define-consult ( class group quot -- ) - >r group-words swap r> + >r 2dup declare-consult group-words swap r> [ define-consult-method ] 2curry each ; : CONSULT: From fe797265ec2b033a3af85840b84df94b93210946 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Fri, 4 Apr 2008 23:14:40 -0500 Subject: [PATCH 2/4] Working on delegate --- extra/delegate/delegate-tests.factor | 30 ++++++++---- extra/delegate/delegate.factor | 68 +++++++++++++++++++++------- 2 files changed, 73 insertions(+), 25 deletions(-) diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 2a0e013c1a..8563c12b75 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,4 +1,5 @@ -USING: delegate kernel arrays tools.test words math ; +USING: delegate kernel arrays tools.test words math definitions +compiler.units parser generic prettyprint io.streams.string ; IN: delegate.tests DEFER: example @@ -6,7 +7,6 @@ DEFER: example [ ] [ \ example "prop" [ 1+ ] change-word-prop ] unit-test [ 2 ] [ \ example "prop" word-prop ] unit-test - TUPLE: hello this that ; C: hello @@ -17,17 +17,29 @@ GENERIC: foo ( x -- y ) GENERIC: bar ( a -- b ) PROTOCOL: baz foo bar ; +: hello-test ( hello/goodbye -- array ) + [ hello? ] [ hello-this ] [ hello-that ] tri 3array ; + CONSULT: baz goodbye goodbye-these ; M: hello foo hello-this ; -M: hello bar dup hello? swap hello-that 2array ; +M: hello bar hello-test ; GENERIC: bing ( c -- d ) -CONSULT: hello goodbye goodbye-these ; -M: hello bing dup hello? swap hello-that 2array ; +CONSULT: hello goodbye goodbye-those ; +M: hello bing hello-test ; MIMIC: bing goodbye hello -[ 1 { t 0 } ] [ 1 0 [ foo ] keep bar ] unit-test -[ { t 0 } ] [ 1 0 bing ] unit-test +[ 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 0 } ] [ 1 0 f bar ] unit-test -[ { f 0 } ] [ 1 0 f bing ] unit-test +[ { t 1 0 } ] [ 1 0 f bar ] unit-test +[ { f 1 0 } ] [ f 1 0 bing ] 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" ] +[ [ baz see ] with-string-writer ] unit-test + +! [ ] [ [ baz forget ] with-compilation-unit ] unit-test +! [ f ] [ goodbye baz method ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index fc62c290df..a32a44db0f 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,17 +1,50 @@ ! 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 ; +vectors definitions prettyprint ; IN: delegate -: define-protocol ( wordlist protocol -- ) - swap { } like "protocol-words" set-word-prop ; +! Protocols + +: cross-2each ( seq1 seq2 quot -- ) + [ with each ] 2curry each ; inline + +: forget-all-methods ( classes words -- ) + [ 2array forget ] cross-2each ; + +: protocol-words ( protocol -- words ) + "protocol-words" word-prop ; + +: protocol-users ( protocol -- users ) + "protocol-users" word-prop ; + +: users-and-words ( protocol -- users words ) + [ protocol-users ] [ protocol-words ] bi ; + +: forget-old-definitions ( protocol new-wordlist -- ) + >r users-and-words r> + seq-diff forget-all-methods ; + +: define-protocol ( protocol wordlist -- ) + 2dup forget-old-definitions + { } like "protocol-words" set-word-prop ; : PROTOCOL: - CREATE-WORD dup define-symbol - parse-definition swap define-protocol ; parsing + CREATE-WORD + dup define-symbol + dup f "inline" set-word-prop + parse-definition define-protocol ; parsing -PREDICATE: protocol < word "protocol-words" word-prop ; +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 ; + +M: protocol definer drop \ PROTOCOL: \ ; ; + +M: protocol synopsis* word-synopsis ; ! Necessary? GENERIC: group-words ( group -- words ) @@ -22,22 +55,23 @@ M: generic group-words 1array ; M: tuple-class group-words - "slots" word-prop 1 tail ! The first slot is the delegate - ! 1 tail should be removed when the delegate slot is removed - dup [ slot-spec-reader ] map - swap [ slot-spec-writer ] map append ; + "slots" word-prop + [ [ slot-spec-reader ] map ] + [ [ slot-spec-writer ] map ] bi append ; + +! Consultation : define-consult-method ( word class quot -- ) pick suffix >r swap create-method r> define ; -: 3bi ( x y z p q -- p(x,y,z) q(x,y,z) ) - >r 3keep r> call ; inline - : change-word-prop ( word prop quot -- ) >r swap word-props r> change-at ; inline +: add ( item vector/f -- vector ) + 2dup member? [ nip ] [ ?push ] if ; + : declare-consult ( class group -- ) - "protocol-users" [ ?push ] change-word-prop ; + "protocol-users" [ add ] change-word-prop ; : define-consult ( class group quot -- ) >r 2dup declare-consult group-words swap r> @@ -46,10 +80,12 @@ M: tuple-class group-words : CONSULT: scan-word scan-word parse-definition swapd define-consult ; parsing +! Mimic still needs to be updated + : define-mimic ( group mimicker mimicked -- ) - >r >r group-words r> r> [ + rot group-words -rot [ pick "methods" word-prop at dup - [ >r swap create-method r> word-def define ] + [ >r swap create-method-in r> word-def define ] [ 3drop ] if ] 2curry each ; From 9f16b80f3e3a8df70efaadf62f618522d440c6e4 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 00:43:42 -0500 Subject: [PATCH 3/4] Fixing docs typo --- extra/io/encodings/utf16/utf16-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/encodings/utf16/utf16-docs.factor b/extra/io/encodings/utf16/utf16-docs.factor index bc0e943415..1666219db5 100644 --- a/extra/io/encodings/utf16/utf16-docs.factor +++ b/extra/io/encodings/utf16/utf16-docs.factor @@ -23,7 +23,7 @@ HELP: utf16 { $see-also "encodings-introduction" } ; HELP: utf16n -{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings in of wide_t*." } +{ $class-description "The encoding descriptor for UTF-16 without a byte order mark in native endian order. This is useful mostly for FFI calls which take input of strings of the type wchar_t*" } { $see-also "encodings-introduction" } ; { utf16 utf16le utf16be utf16n } related-words From 48d31a2ca01989bb07ca75afafee4d4d3a2648cd Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Sat, 5 Apr 2008 02:44:54 -0500 Subject: [PATCH 4/4] 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 ; - -