From 4823509dfd2c0b0ce153e6d8a497977e0fd7a86e Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Thu, 17 Apr 2008 22:39:25 -0500 Subject: [PATCH 1/5] Delegate changes for crossreferencing; removing mimic (not enough unit tests) --- extra/delegate/delegate-docs.factor | 19 +--- extra/delegate/delegate-tests.factor | 10 +-- extra/delegate/delegate.factor | 126 +++++++++++++-------------- 3 files changed, 67 insertions(+), 88 deletions(-) diff --git a/extra/delegate/delegate-docs.factor b/extra/delegate/delegate-docs.factor index f123c3a802..e6a2ad7bf4 100644 --- a/extra/delegate/delegate-docs.factor +++ b/extra/delegate/delegate-docs.factor @@ -24,30 +24,17 @@ HELP: CONSULT: { define-consult POSTPONE: CONSULT: } related-words -HELP: define-mimic -{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } } -{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the word is called." } -{ $notes "Usually, " { $link POSTPONE: MIMIC: } " should be used instead. This is only for runtime use." } ; - -HELP: MIMIC: -{ $syntax "MIMIC: group mimicker mimicked" } -{ $values { "group" "a protocol, generic word or tuple class" } { "mimicker" "a class" } { "mimicked" "a class" } } -{ $description "For the generic words in the group, the given mimicker copies the methods of the mimicked. This only works for the methods that have already been defined when the syntax is used. Mimicking overwrites existing methods." } ; - HELP: group-words { $values { "group" "a group" } { "words" "an array of words" } } -{ $description "Given a protocol, generic word or tuple class, this returns the corresponding generic words that this group contains." } ; +{ $description "Given a protocol or tuple class, this returns the corresponding generic words that this group contains." } ; ARTICLE: { "delegate" "intro" } "Delegation module" -"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". To define a group as a set of words, use" +"This vocabulary defines methods for consultation and mimicry, independent of the current Factor object system; it is a replacement for Factor's builtin delegation system. Fundamental to the concept of generic word groups, which can be specific protocols, generic words or tuple slot accessors. Fundamentally, a group is a word which has a method for " { $link group-words } ". One type of group is a tuple, which consists of the slot words. To define a group as a set of words, use" { $subsection POSTPONE: PROTOCOL: } { $subsection define-protocol } "One method of object extension which this vocabulary defines is consultation. This is slightly different from the current Factor concept of delegation, in that instead of delegating for all generic words not implemented, only generic words included in a specific group are consulted. Additionally, instead of using a single hard-coded delegate slot, you can specify any quotation to execute in order to retrieve who to consult. The literal syntax and defining word are" { $subsection POSTPONE: CONSULT: } -{ $subsection define-consult } -"Another object extension mechanism is mimicry. This is the copying of methods in a group from one class to another. For certain applications, this is more appropriate than delegation, as it avoids the slicing problem. It is inappropriate for tuple slots, however. The literal syntax and defining word are" -{ $subsection POSTPONE: MIMIC: } -{ $subsection define-mimic } ; +{ $subsection define-consult } ; IN: delegate ABOUT: { "delegate" "intro" } diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index 497a6c5120..7f633ed4a4 100644 --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -2,11 +2,6 @@ USING: delegate kernel arrays tools.test words math definitions compiler.units parser generic prettyprint io.streams.string ; 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 @@ -30,18 +25,17 @@ GENERIC: bing ( c -- d ) PROTOCOL: bee bing ; CONSULT: hello goodbye goodbye-those ; M: hello bing hello-test ; -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 +[ H{ { goodbye [ goodbye-these ] } } ] [ baz protocol-consult ] unit-test +[ H{ } ] [ bee protocol-consult ] unit-test [ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index f8e238b7db..59b298c242 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,9 +1,44 @@ ! 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 combinators.lib math ; +vectors definitions prettyprint combinators.lib math hashtables ; IN: delegate +: protocol-words ( protocol -- words ) + \ protocol-words word-prop ; + +: protocol-consult ( protocol -- consulters ) + \ protocol-consult word-prop ; + +GENERIC: group-words ( group -- words ) + +M: tuple-class group-words + "slot-names" word-prop [ + [ reader-word ] [ writer-word ] bi + 2array [ 0 2array ] map + ] map concat ; + +! Consultation + +: consult-method ( word class quot -- ) + [ drop swap first create-method ] + [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ; + +: change-word-prop ( word prop quot -- ) + rot word-props swap change-at ; inline + +: register-protocol ( group class quot -- ) + rot \ protocol-consult [ swapd ?set-at ] change-word-prop ; + +: define-consult ( group class quot -- ) + [ register-protocol ] [ + rot group-words -rot + [ consult-method ] 2curry each + ] 3bi ; + +: CONSULT: + scan-word scan-word parse-definition define-consult ; parsing + ! Protocols : cross-2each ( seq1 seq2 quot -- ) @@ -12,36 +47,46 @@ IN: delegate : 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 ; + protocol-consult keys ; -: users-and-words ( protocol -- users words ) - [ protocol-users ] [ protocol-words ] bi ; +: lost-words ( protocol wordlist -- lost-words ) + >r protocol-words r> seq-diff ; : forget-old-definitions ( protocol new-wordlist -- ) - >r users-and-words r> - seq-diff forget-all-methods ; + values [ drop protocol-users ] [ lost-words ] 2bi + forget-all-methods ; -: define-protocol ( protocol wordlist -- ) - ! 2dup forget-old-definitions - { } like "protocol-words" set-word-prop ; +: added-words ( protocol wordlist -- added-words ) + swap protocol-words seq-diff ; + +: add-new-definitions ( protocol wordlist -- ) + dupd added-words >r protocol-consult >alist r> + [ first2 consult-method ] cross-2each ; + +: initialize-protocol-props ( protocol wordlist -- ) + [ drop H{ } clone \ protocol-consult set-word-prop ] + [ { } like \ protocol-words set-word-prop ] 2bi ; : fill-in-depth ( wordlist -- wordlist' ) [ dup word? [ 0 2array ] when ] map ; +: define-protocol ( protocol wordlist -- ) + fill-in-depth + [ forget-old-definitions ] + [ add-new-definitions ] + [ initialize-protocol-props ] 2tri ; + : PROTOCOL: CREATE-WORD - dup define-symbol - dup f "inline" set-word-prop - parse-definition fill-in-depth define-protocol ; parsing + [ define-symbol ] + [ f "inline" set-word-prop ] + [ parse-definition define-protocol ] tri ; parsing PREDICATE: protocol < word protocol-words ; ! Subclass of symbol? M: protocol forget* - [ users-and-words forget-all-methods ] [ call-next-method ] bi ; + [ f forget-old-definitions ] [ call-next-method ] bi ; : show-words ( wordlist' -- wordlist ) [ dup second zero? [ first ] when ] map ; @@ -52,51 +97,4 @@ M: protocol definer drop \ PROTOCOL: \ ; ; M: protocol synopsis* word-synopsis ; ! Necessary? -GENERIC: group-words ( group -- words ) - -M: protocol group-words - "protocol-words" word-prop ; - -M: tuple-class group-words - "slot-names" word-prop [ - [ reader-word ] [ writer-word ] bi - 2array [ 0 2array ] map - ] map concat ; - -! Consultation - -: define-consult-method ( word class quot -- ) - [ 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 - -: add ( item vector/f -- vector ) - 2dup member? [ nip ] [ ?push ] if ; - -: use-protocol ( class group -- ) - "protocol-users" [ add ] change-word-prop ; - -: 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 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 -- ) - [ 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 +M: protocol group-words protocol-words ; From eac64bccab46a11de5f3459fd208b4899bb6a52c Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Apr 2008 19:39:54 -0500 Subject: [PATCH 2/5] Moving VALUE: into unicode.syntax.backend --- extra/unicode/breaks/breaks.factor | 2 +- extra/unicode/data/data.factor | 10 +--------- extra/unicode/syntax/backend/backend.factor | 8 ++++++++ 3 files changed, 10 insertions(+), 10 deletions(-) create mode 100644 extra/unicode/syntax/backend/backend.factor diff --git a/extra/unicode/breaks/breaks.factor b/extra/unicode/breaks/breaks.factor index ee3c8729c4..2117567e9f 100644 --- a/extra/unicode/breaks/breaks.factor +++ b/extra/unicode/breaks/breaks.factor @@ -1,6 +1,6 @@ USING: unicode.categories kernel math combinators splitting sequences math.parser io.files io assocs arrays namespaces -math.ranges unicode.normalize +math.ranges unicode.normalize unicode.syntax.backend unicode.syntax unicode.data compiler.units alien.syntax io.encodings.ascii ; IN: unicode.breaks diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 58d836464c..b1e6fc5f8b 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -1,16 +1,8 @@ USING: assocs math kernel sequences io.files hashtables -quotations splitting arrays math.parser hash2 +quotations splitting arrays math.parser hash2 unicode.syntax.backend byte-arrays words namespaces words compiler.units parser io.encodings.ascii ; IN: unicode.data -<< -: VALUE: - CREATE-WORD { f } clone [ first ] curry define ; parsing - -: set-value ( value word -- ) - word-def first set-first ; ->> - ! Convenience functions : ?between? ( n/f from to -- ? ) pick [ between? ] [ 3drop f ] if ; diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/unicode/syntax/backend/backend.factor new file mode 100644 index 0000000000..d1065da5c8 --- /dev/null +++ b/extra/unicode/syntax/backend/backend.factor @@ -0,0 +1,8 @@ +USING: kernel parser sequences definitions ; +IN: unicode.syntax.backend + +: VALUE: + CREATE-WORD { f } clone [ first ] curry define ; parsing + +: set-value ( value word -- ) + word-def first set-first ; From 594f335dfebd4cf483d12a652f666d75d9fc1a44 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Apr 2008 21:04:57 -0500 Subject: [PATCH 3/5] Adding IANA encodings table --- extra/io/encodings/iana/iana.factor | 41 ++++++++++++++++++++- extra/unicode/syntax/backend/backend.factor | 2 +- 2 files changed, 40 insertions(+), 3 deletions(-) diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor index 08b40f802c..1bbb80482d 100644 --- a/extra/io/encodings/iana/iana.factor +++ b/extra/io/encodings/iana/iana.factor @@ -1,7 +1,27 @@ -USING: kernel strings unicode.syntax.backend ; +USING: kernel strings unicode.syntax.backend io.files assocs +splitting sequences io namespaces sets +io.encodings.ascii io.encodings.utf8 io.encodings.utf16 io.encodings.8-bit ; +IN: io.encodings.iana VALUE: n>e-table -VALUE: e>n-table + +: e>n-table H{ + { ascii "US-ASCII" } + { utf8 "UTF-8" } + { utf16 "UTF-16" } + { utf16be "UTF-16BE" } + { utf16le "UTF-16LE" } + { latin1 "ISO-8859-1" } + { latin2 "ISO-8859-2" } + { latin3 "ISO-8859-3" } + { latin4 "ISO-8859-4" } + { latin/cyrillic "ISO-8859-5" } + { latin/arabic "ISO-8859-6" } + { latin/greek "ISO-8859-7" } + { latin/hebrew "ISO-8859-8" } + { latin5 "ISO-8859-9" } + { latin6 "ISO-8859-10" } +} ; : name>encoding ( string -- encoding ) n>e-table at ; @@ -9,4 +29,21 @@ VALUE: e>n-table : encoding>name ( encoding -- string ) e>n-table at ; +: parse-iana ( stream -- synonym-set ) + lines { "" } split [ + [ " " split ] map + [ first { "Name:" "Alias:" } member? ] filter + [ second ] map { "None" } diff + ] map ; +: make-n>e ( stream -- n>e ) ! encodings is string => symbol + parse-iana [ [ + dup [ + e>n-table value-at + [ swap [ set ] with each ] + [ drop ] if* + ] with each + ] each ] H{ } make-assoc ; + +"resource:extra/io/encodings/iana/character-sets" +ascii make-n>e \ n>e-table set-value diff --git a/extra/unicode/syntax/backend/backend.factor b/extra/unicode/syntax/backend/backend.factor index d1065da5c8..5c463e8fc4 100644 --- a/extra/unicode/syntax/backend/backend.factor +++ b/extra/unicode/syntax/backend/backend.factor @@ -1,4 +1,4 @@ -USING: kernel parser sequences definitions ; +USING: kernel parser sequences words ; IN: unicode.syntax.backend : VALUE: From ada6e4ed0b5fd51659b348c27e1f3f9ef90e0c6f Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Apr 2008 21:08:18 -0500 Subject: [PATCH 4/5] Fixing delegate regression --- extra/delegate/delegate.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 59e2210ae0..39eccfd194 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -54,7 +54,7 @@ M: tuple-class group-words >r protocol-words r> diff ; : forget-old-definitions ( protocol new-wordlist -- ) - >r users-and-words r> + >r [ protocol-users ] [ protocol-words ] bi r> swap diff forget-all-methods ; : added-words ( protocol wordlist -- added-words ) From 82679024ce4e19dc95c29947e7c3b6414b52da66 Mon Sep 17 00:00:00 2001 From: Daniel Ehrenberg Date: Wed, 30 Apr 2008 21:09:27 -0500 Subject: [PATCH 5/5] Deleting inaccurate comment --- extra/io/encodings/iana/iana.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/encodings/iana/iana.factor b/extra/io/encodings/iana/iana.factor index 1bbb80482d..9d5fabd439 100644 --- a/extra/io/encodings/iana/iana.factor +++ b/extra/io/encodings/iana/iana.factor @@ -36,7 +36,7 @@ VALUE: n>e-table [ second ] map { "None" } diff ] map ; -: make-n>e ( stream -- n>e ) ! encodings is string => symbol +: make-n>e ( stream -- n>e ) parse-iana [ [ dup [ e>n-table value-at