Merge branch 'master' of git://factorcode.org/git/littledan

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 ;
+CONSULT: baz goodbye these>> ;
-M: hello foo hello-this ;
+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 <hello> [ foo ] [ bar ] bi ] unit-test
@@ -33,11 +34,48 @@ M: hello bing hello-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
+[ ] [ 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
+GENERIC: one
-! [ f ] [ goodbye baz method ] unit-test
+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> hey
+CONSULT: alpha hey value>> 1+ ;
+CONSULT: beta hey value>> 1- ;
+
+[ 2 ] [ 1 <hey> one ] unit-test
+[ 2 ] [ 1 <hey> two ] unit-test
+[ 0 ] [ 1 <hey> 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 <hey> one ] unit-test
+[ 0 ] [ 1 <hey> two ] unit-test
+[ 0 ] [ 1 <hey> three ] unit-test
+[ 0 ] [ 1 <hey> four ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval ] unit-test
+[ 2 ] [ 1 <hey> one ] unit-test
+[ -1 ] [ 1 <hey> two ] unit-test
+[ -1 ] [ 1 <hey> three ] unit-test
+[ -1 ] [ 1 <hey> four ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval ] unit-test
+[ f ] [ hey \ one method ] unit-test

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
+USING: parser generic kernel classes words slots assocs
-vectors definitions prettyprint combinators.lib math hashtables sets ;
+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 ] [
+    [ register-protocol ]
-        rot group-words -rot
+    [ rot group-words -rot [ consult-method ] 2curry each ]
-        [ consult-method ] 2curry each
+    3bi ;
-    ] 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>
+    [ drop protocol-users ] [ lost-words ] 2bi
-    swap diff forget-all-methods ;
+    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>
+    [ drop protocol-consult >alist ] [ added-words ] 2bi
-     [ first2 consult-method ] cross-2each ;
+    [ 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 ;

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 
+USING: delegate sequences.private sequences assocs
-io definitions kernel continuations listener ;
+prettyprint.sections io definitions kernel continuations
+listener ;
 IN: delegate.protocols
 
 PROTOCOL: sequence-protocol
-    clone clone-like like new-sequence new-resizable nth nth-unsafe
+    clone clone-like like new-sequence new-resizable nth
-    set-nth set-nth-unsafe length set-length lengthen ;
+    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 }
+    at* assoc-size >alist set-at assoc-clone-like
-    delete-at clear-assoc new-assoc assoc-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

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

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>> ;

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 ;