Fix conflict
Slava Pestov
commit
507da24d39
|
|
@ -1,6 +1,12 @@
|
|||
USING: delegate kernel arrays tools.test ;
|
||||
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
|
||||
|
||||
|
|
@ -9,19 +15,36 @@ C: <goodbye> 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 ;
|
||||
|
||||
CONSULT: baz goodbye goodbye-these ;
|
||||
M: hello foo hello-this ;
|
||||
M: hello bar dup hello? swap hello-that 2array ;
|
||||
M: hello bar hello-test ;
|
||||
M: hello whoa >r hello-this r> + ;
|
||||
|
||||
GENERIC: bing ( c -- d )
|
||||
CONSULT: hello goodbye goodbye-these ;
|
||||
M: hello bing dup hello? swap hello-that 2array ;
|
||||
MIMIC: bing goodbye hello
|
||||
PROTOCOL: bee bing ;
|
||||
CONSULT: hello goodbye goodbye-those ;
|
||||
M: hello bing hello-test ;
|
||||
MIMIC: bee goodbye hello
|
||||
|
||||
[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
|
||||
[ { t 0 } ] [ 1 0 <hello> bing ] unit-test
|
||||
[ 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 0 } ] [ 1 0 <hello> f <goodbye> bar ] unit-test
|
||||
[ { f 0 } ] [ 1 0 <hello> f <goodbye> bing ] 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
|
||||
|
||||
[ "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,47 +1,102 @@
|
|||
! 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 definitions prettyprint combinators.lib math ;
|
||||
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 ;
|
||||
|
||||
: fill-in-depth ( wordlist -- wordlist' )
|
||||
[ dup word? [ 0 2array ] when ] map ;
|
||||
|
||||
: 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 fill-in-depth 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 ;
|
||||
|
||||
: show-words ( wordlist' -- wordlist )
|
||||
[ dup second zero? [ first ] when ] map ;
|
||||
|
||||
M: protocol definition protocol-words show-words ;
|
||||
|
||||
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: 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 ;
|
||||
"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 ;
|
||||
|
||||
: define-consult ( class group quot -- )
|
||||
>r group-words swap r>
|
||||
: 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 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 -- )
|
||||
>r >r group-words r> r> [
|
||||
pick "methods" word-prop at dup
|
||||
[ >r swap create-method 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue