Merge branch 'master' of git://factorcode.org/git/littledan
Slava Pestov
commit
2052f70c58
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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> hello
|
||||
|
||||
|
|
@ -30,21 +25,19 @@ 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 <hello> [ foo ] [ bar ] bi ] unit-test
|
||||
[ { t 1 0 } ] [ 1 0 <hello> bing ] unit-test
|
||||
[ 1 ] [ 1 0 <hello> f <goodbye> foo ] unit-test
|
||||
[ { t 1 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
|
||||
! [ { f 1 0 } ] [ f 1 0 <hello> <goodbye> bing ] unit-test
|
||||
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
|
||||
[ 3 ] [ 1 0 <hello> f <goodbye> 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
|
||||
[ "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
|
||||
! [ f ] [ goodbye baz method ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 sets ;
|
||||
vectors definitions prettyprint combinators.lib math hashtables sets ;
|
||||
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> diff ;
|
||||
|
||||
: forget-old-definitions ( protocol new-wordlist -- )
|
||||
>r users-and-words r>
|
||||
>r [ protocol-users ] [ protocol-words ] bi r>
|
||||
swap diff 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 swap 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 ;
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1,49 @@
|
|||
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
|
||||
|
||||
: 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 ;
|
||||
|
||||
: 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 )
|
||||
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 <file-reader> make-n>e \ n>e-table set-value
|
||||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,17 +1,9 @@
|
|||
USING: assocs math kernel sequences io.files hashtables
|
||||
quotations splitting arrays math.parser hash2 math.order
|
||||
byte-arrays words namespaces words compiler.units parser
|
||||
io.encodings.ascii ;
|
||||
io.encodings.ascii unicode.syntax.backend ;
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,8 @@
|
|||
USING: kernel parser sequences words ;
|
||||
IN: unicode.syntax.backend
|
||||
|
||||
: VALUE:
|
||||
CREATE-WORD { f } clone [ first ] curry define ; parsing
|
||||
|
||||
: set-value ( value word -- )
|
||||
word-def first set-first ;
|
||||
Loading…
Reference in New Issue