diff --git a/extra/delegate/delegate-tests.factor b/extra/delegate/delegate-tests.factor old mode 100644 new mode 100755 index 6aa015a74d..ab0ea988ea --- a/extra/delegate/delegate-tests.factor +++ b/extra/delegate/delegate-tests.factor @@ -1,5 +1,6 @@ USING: delegate kernel arrays tools.test words math definitions -compiler.units parser generic prettyprint io.streams.string ; +compiler.units parser generic prettyprint io.streams.string +accessors ; IN: delegate.tests TUPLE: hello this that ; @@ -16,14 +17,14 @@ 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 ; +CONSULT: baz goodbye these>> ; +M: hello foo this>> ; M: hello bar hello-test ; -M: hello whoa >r hello-this r> + ; +M: hello whoa >r this>> r> + ; GENERIC: bing ( c -- d ) PROTOCOL: bee bing ; -CONSULT: hello goodbye goodbye-those ; +CONSULT: hello goodbye those>> ; M: hello bing hello-test ; [ 1 { t 1 0 } ] [ 1 0 [ foo ] [ bar ] bi ] unit-test @@ -33,11 +34,48 @@ M: hello bing hello-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 +[ ] [ 3 [ "USE: delegate IN: delegate.tests CONSULT: baz goodbye goodbye-these ;" eval ] times ] 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 -! [ ] [ [ baz forget ] with-compilation-unit ] unit-test -! [ f ] [ goodbye baz method ] unit-test +GENERIC: one +M: integer one ; +GENERIC: two +M: integer two ; +GENERIC: three +M: integer three ; +GENERIC: four +M: integer four ; + +PROTOCOL: alpha one two ; +PROTOCOL: beta three ; + +TUPLE: hey value ; +C: hey +CONSULT: alpha hey value>> 1+ ; +CONSULT: beta hey value>> 1- ; + +[ 2 ] [ 1 one ] unit-test +[ 2 ] [ 1 two ] unit-test +[ 0 ] [ 1 three ] unit-test +[ { hey } ] [ alpha protocol-users ] unit-test +[ { hey } ] [ beta protocol-users ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval ] unit-test +[ f ] [ hey \ two method ] unit-test +[ f ] [ hey \ four method ] unit-test +[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval ] unit-test +[ { hey } ] [ alpha protocol-users ] unit-test +[ { hey } ] [ beta protocol-users ] unit-test +[ 2 ] [ 1 one ] unit-test +[ 0 ] [ 1 two ] unit-test +[ 0 ] [ 1 three ] unit-test +[ 0 ] [ 1 four ] unit-test +[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test +[ 2 ] [ 1 one ] unit-test +[ -1 ] [ 1 two ] unit-test +[ -1 ] [ 1 three ] unit-test +[ -1 ] [ 1 four ] unit-test +[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test +[ f ] [ hey \ one method ] unit-test diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 39eccfd194..c375dcf874 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,7 +1,8 @@ ! 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 hashtables sets ; +USING: parser generic kernel classes words slots assocs +sequences arrays vectors definitions prettyprint combinators.lib +math hashtables sets ; IN: delegate : protocol-words ( protocol -- words ) @@ -22,7 +23,8 @@ M: tuple-class group-words : consult-method ( word class quot -- ) [ drop swap first create-method ] - [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi define ; + [ nip swap first2 swapd [ ndip ] 2curry swap suffix ] 3bi + define ; : change-word-prop ( word prop quot -- ) rot word-props swap change-at ; inline @@ -31,10 +33,9 @@ M: tuple-class group-words 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 ; + [ register-protocol ] + [ rot group-words -rot [ consult-method ] 2curry each ] + 3bi ; : CONSULT: scan-word scan-word parse-definition define-consult ; parsing @@ -45,7 +46,7 @@ M: tuple-class group-words [ with each ] 2curry each ; inline : forget-all-methods ( classes words -- ) - [ 2array forget ] cross-2each ; + [ first method forget ] cross-2each ; : protocol-users ( protocol -- users ) protocol-consult keys ; @@ -54,19 +55,21 @@ M: tuple-class group-words >r protocol-words r> diff ; : forget-old-definitions ( protocol new-wordlist -- ) - >r [ protocol-users ] [ protocol-words ] bi r> - swap diff forget-all-methods ; + [ drop protocol-users ] [ lost-words ] 2bi + forget-all-methods ; : added-words ( protocol wordlist -- added-words ) - swap protocol-words swap diff ; + swap protocol-words diff ; : add-new-definitions ( protocol wordlist -- ) - dupd added-words >r protocol-consult >alist r> - [ first2 consult-method ] cross-2each ; + [ drop protocol-consult >alist ] [ added-words ] 2bi + [ swap 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 ; + [ + drop \ protocol-consult + [ H{ } assoc-like ] change-word-prop + ] [ { } like \ protocol-words set-word-prop ] 2bi ; : fill-in-depth ( wordlist -- wordlist' ) [ dup word? [ 0 2array ] when ] map ; diff --git a/extra/delegate/protocols/protocols.factor b/extra/delegate/protocols/protocols.factor index d4d34f0bd0..1e83c15694 100755 --- a/extra/delegate/protocols/protocols.factor +++ b/extra/delegate/protocols/protocols.factor @@ -1,16 +1,19 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: delegate sequences.private sequences assocs prettyprint.sections -io definitions kernel continuations listener ; +USING: delegate sequences.private sequences assocs +prettyprint.sections io definitions kernel continuations +listener ; IN: delegate.protocols PROTOCOL: sequence-protocol - clone clone-like like new-sequence new-resizable nth nth-unsafe - set-nth set-nth-unsafe length set-length lengthen ; + clone clone-like like new-sequence new-resizable nth + nth-unsafe set-nth set-nth-unsafe length set-length + lengthen ; PROTOCOL: assoc-protocol - at* assoc-size >alist set-at assoc-clone-like { assoc-find 1 } - delete-at clear-assoc new-assoc assoc-like ; + at* assoc-size >alist set-at assoc-clone-like + { assoc-find 1 } delete-at clear-assoc new-assoc + assoc-like ; PROTOCOL: input-stream-protocol stream-read1 stream-read stream-read-partial stream-readln diff --git a/extra/descriptive/descriptive-tests.factor b/extra/descriptive/descriptive-tests.factor new file mode 100755 index 0000000000..4aabbb9be0 --- /dev/null +++ b/extra/descriptive/descriptive-tests.factor @@ -0,0 +1,16 @@ +USING: descriptive kernel math tools.test continuations prettyprint io.streams.string ; +IN: descriptive.tests + +DESCRIPTIVE: divide ( num denom -- fraction ) / ; + +[ 3 ] [ 9 3 divide ] unit-test +[ T{ known f H{ { "num" 3 } { "denom" 0 } } "Division by zero" divide } ] [ [ 3 0 divide ] [ ] recover ] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE: divide ( num denom -- fraction ) / ;\n" ] [ \ divide [ see ] with-string-writer ] unit-test + +DESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ; + +[ 3 ] [ 9 3 divide* ] unit-test +[ T{ known f H{ { "num" 3 } { "denom" 0 } } "Division by zero" divide* } ] [ [ 3 0 divide* ] [ ] recover ] unit-test + +[ "USING: descriptive math ;\nIN: descriptive.tests\nDESCRIPTIVE:: divide* ( num denom -- fraction ) num denom / ;\n" ] [ \ divide* [ see ] with-string-writer ] unit-test diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor new file mode 100755 index 0000000000..f5a71ab6e3 --- /dev/null +++ b/extra/descriptive/descriptive.factor @@ -0,0 +1,45 @@ +USING: words kernel sequences combinators.lib locals +locals.private accessors parser namespaces continuations +inspector definitions ; +IN: descriptive + +ERROR: known args underlying word ; + +M: known summary + word>> "The " swap word-name " word encountered an error." + 3append ; + +: rethrower ( word inputs -- quot ) + reverse [ [ set ] curry ] map concat [ ] like + [ H{ } make-assoc ] curry + [ 2 ndip known ] 2curry ; + +: [descriptive] ( word def -- newdef ) + swap dup "declared-effect" word-prop in>> rethrower + [ recover ] 2curry ; + +: define-descriptive ( word def -- ) + [ "descriptive-definition" set-word-prop ] + [ dupd [descriptive] define ] 2bi ; + +: DESCRIPTIVE: + (:) define-descriptive ; parsing + +PREDICATE: descriptive-word < word + "descriptive-definition" word-prop ; + +M: descriptive-word definer drop \ DESCRIPTIVE: \ ; ; + +M: descriptive-word definition + "descriptive-definition" word-prop ; + +: DESCRIPTIVE:: + (::) define-descriptive ; parsing + +PREDICATE: descriptive-lambda < lambda-word + "descriptive-definition" word-prop ; + +M: descriptive-lambda definer drop \ DESCRIPTIVE:: \ ; ; + +M: descriptive-lambda definition + "lambda" word-prop body>> ; diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 4b7ab8cdad..d4fc920b25 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -363,14 +363,6 @@ M: lambda-word definer drop \ :: \ ; ; M: lambda-word definition "lambda" word-prop body>> ; -: lambda-word-synopsis ( word -- ) - dup definer. - dup seeing-word - dup pprint-word - stack-effect. ; - -M: lambda-word synopsis* lambda-word-synopsis ; - PREDICATE: lambda-macro < macro "lambda" word-prop >boolean ; @@ -379,8 +371,6 @@ M: lambda-macro definer drop \ MACRO:: \ ; ; M: lambda-macro definition "lambda" word-prop body>> ; -M: lambda-macro synopsis* lambda-word-synopsis ; - PREDICATE: lambda-method < method-body "lambda" word-prop >boolean ;