diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor index d66357daa5..497a6c5120 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 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 @@ -9,19 +15,36 @@ 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 ; 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 [ 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 +[ 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 { whoa 1 } ;\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 eadd1a03e8..f8e238b7db 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -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 diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index 64e133dd2a..736645890e 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 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