Merge commit 'littledan/master'

extra/delegate/author.txt

@@ -0,0 +1 @@
+Daniel Ehrenberg

extra/delegate/delegate-docs.factor

@@ -0,0 +1,52 @@
+USING: delegate help.syntax help.markup ;
+
+HELP: define-protocol
+{ $values { "wordlist" "a sequence of words" } { "protocol" "a word for the new protocol" } }
+{ $description "Defines a symbol as a protocol." }
+{ $notes "Usually, " { $link POSTPONE: PROTOCOL: } " should be used instead. This is only for runtime use." } ;
+
+HELP: PROTOCOL:
+{ $syntax "PROTOCOL: protocol-name words... ;" }
+{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
+
+{ define-protocol POSTPONE: PROTOCOL: } related-words
+
+HELP: define-consult
+{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
+{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
+{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
+
+HELP: CONSULT:
+{ $syntax "CONSULT: group class getter... ;" } 
+{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
+{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
+
+{ 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." } ;
+
+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"
+{ $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 } ;
+
+IN: delegate
+ABOUT: { "delegate" "intro" }

extra/delegate/delegate-tests.factor

@@ -0,0 +1,26 @@
+USING: delegate kernel arrays tools.test ;
+
+TUPLE: hello this that ;
+C: <hello> hello
+
+TUPLE: goodbye these those ;
+C: <goodbye> goodbye
+
+GENERIC: foo ( x -- y )
+GENERIC: bar ( a -- b )
+PROTOCOL: baz foo bar ;
+
+CONSULT: baz goodbye goodbye-these ;
+M: hello foo hello-this ;
+M: hello bar dup hello? swap hello-that 2array ;
+
+GENERIC: bing ( c -- d )
+CONSULT: hello goodbye goodbye-these ;
+M: hello bing dup hello? swap hello-that 2array ;
+MIMIC: bing goodbye hello
+
+[ 1 { t 0 } ] [ 1 0 <hello> [ foo ] keep bar ] unit-test
+[ { t 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

extra/delegate/delegate.factor

@@ -0,0 +1,73 @@
+! Copyright (C) 2007 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: parser generic kernel classes words slots io definitions
+sequences sequences.private assocs prettyprint.sections arrays ;
+IN: delegate
+
+: define-protocol ( wordlist protocol -- )
+    swap { } like "protocol-words" set-word-prop ;
+
+: PROTOCOL:
+    CREATE dup reset-generic dup define-symbol
+    parse-definition swap define-protocol ; parsing
+
+PREDICATE: word protocol "protocol-words" word-prop ;
+
+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 ;
+
+: spin ( x y z -- z y x )
+    swap rot ;
+
+: define-consult-method ( word class quot -- )
+    pick add <method> spin define-method ;
+
+: define-consult ( class group quot -- )
+    >r group-words r>
+    swapd [ define-consult-method ] 2curry each ;
+
+: CONSULT:
+    scan-word scan-word parse-definition swapd define-consult ; parsing
+
+PROTOCOL: sequence-protocol
+    clone clone-like like new new-resizable nth nth-unsafe
+    set-nth set-nth-unsafe length immutable set-length lengthen ;
+
+PROTOCOL: assoc-protocol
+    at* assoc-size >alist assoc-find set-at
+    delete-at clear-assoc new-assoc assoc-like ;
+
+PROTOCOL: stream-protocol
+    stream-close stream-read1 stream-read stream-read-until
+    stream-flush stream-write1 stream-write stream-format
+    stream-nl make-span-stream make-block-stream stream-readln
+    make-cell-stream stream-write-table set-timeout ;
+
+PROTOCOL: definition-protocol
+    where set-where forget uses redefined*
+    synopsis* definer definition ;
+
+PROTOCOL: prettyprint-section-protocol
+    section-fits? indent-section? unindent-first-line?
+    newline-after?  short-section? short-section long-section
+    <section> delegate>block add-section ;
+
+: define-mimic ( group mimicker mimicked -- )
+    >r >r group-words r> r> [
+        pick "methods" word-prop at method-def
+        <method> spin define-method
+    ] 2curry each ; 
+
+: MIMIC:
+    scan-word scan-word scan-word define-mimic ; parsing

extra/delegate/summary.txt

@@ -0,0 +1 @@
+Delegation and mimicking on top of the Factor object system

extra/inverse/inverse-docs.factor

@@ -24,7 +24,7 @@ HELP: matches?
 { $values { "quot" "a quotation" } { "?" "a boolean" } }
 { $description "Tests if the stack can match the given quotation. The quotation is inverted, and if the inverse can run without a unification failure, then t is returned. Else f is returned. If a different error is encountered (such as stack underflow), this will be propagated." } ;
 
-HELP: which
+HELP: switch
 { $values { "quot-alist" "an alist from inverse quots to quots" } }
 { $description "The equivalent of a case expression in a programming language with buitlin pattern matchining. It attempts to match the stack with each of the patterns, in order, by treating them as inverse quotations. Failure causes the next pattern to be tested." }
 { $code
@@ -34,7 +34,7 @@ HELP: which
 "    {"
 "        { [ <cons> ] [ sum + ] }"
 "        { [ f ] [ 0 ] }"
-"    } which ;" }
+"    } switch ;" }
 { $see-also undo } ;
 
 ARTICLE: { "inverse" "intro" } "Invertible quotations"
@@ -46,7 +46,7 @@ ARTICLE: { "inverse" "intro" } "Invertible quotations"
 "To use the inverse quotation for pattern matching"
 { $subsection undo }
 { $subsection matches? }
-{ $subsection which } ;
+{ $subsection switch } ;
 
 IN: inverse
 ABOUT: { "inverse" "intro" }

extra/inverse/inverse-tests.factor

@@ -1,5 +1,6 @@
 USING: inverse tools.test arrays math kernel sequences
-math.functions ;
+math.functions math.constants ;
+IN: inverse-tests
 
 [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
 [ { 3 4 } [ dup 2array ] undo ] unit-test-fails
@@ -20,7 +21,7 @@ C: <foo> foo
     {
         { [ dup 1+ 2array ] [ 3 * ] }
         { [ 3array ] [ + + ] }
-    } which ;
+    } switch ;
 
 [ 5 ] [ { 1 2 2 } something ] unit-test
 [ 6 ] [ { 2 3 } something ] unit-test
@@ -35,6 +36,8 @@ C: <foo> foo
 [ { t t f } ] [ { t f 1 } [ [ >boolean ] matches? ] map ] unit-test
 [ { t f } ] [ { { 1 2 3 } 4 } [ [ >array ] matches? ] map ] unit-test
 [ 9 9 ] [ 3 [ 1/2 ^ ] undo 3 [ sqrt ] undo ] unit-test
+[ 5 ] [ 6 5 - [ 6 swap - ] undo ] unit-test
+[ 6 ] [ 6 5 - [ 5 - ] undo ] unit-test
 
 TUPLE: cons car cdr ;
 
@@ -49,12 +52,19 @@ C: <nil> nil
         { [ <cons> ] [ list-sum + ] }
         { [ <nil> ] [ 0 ] }
         { [ ] [ "Malformed list" throw ] }
-    } which ;
+    } switch ;
 
 [ 10 ] [ 1 2 3 4 <nil> <cons> <cons> <cons> <cons> list-sum ] unit-test
+[ ] [ <nil> [ <nil> ] undo ] unit-test
+[ 1 2 ] [ 1 2 <cons> [ <cons> ] undo ] unit-test
+[ t ] [ 1 2 <cons> [ <cons> ] matches? ] unit-test
+[ f ] [ 1 2 <cons> [ <foo> ] matches? ] unit-test
 
 : empty-cons ( -- cons ) cons construct-empty ;
 : cons* ( cdr car -- cons ) { set-cons-cdr set-cons-car } cons construct ;
 
 [ ] [ T{ cons f f f } [ empty-cons ] undo ] unit-test
 [ 1 2 ] [ 2 1 <cons> [ cons* ] undo ] unit-test
+
+[ t ] [ pi [ pi ] matches? ] unit-test
+[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test

extra/inverse/inverse.factor

@@ -26,6 +26,13 @@ M: fail summary drop "Unification failed" ;
 
 : define-inverse ( word quot -- ) "inverse" set-word-prop ;
 
+: define-math-inverse ( word quot1 quot2 -- )
+    2array "math-inverse" set-word-prop ;
+
+: define-pop-inverse ( word n quot -- )
+    >r dupd "pop-length" set-word-prop r>
+    "pop-inverse" set-word-prop ;
+
 DEFER: [undo]
 
 : make-inverse ( word -- quot )
@@ -36,7 +43,32 @@ TUPLE: no-inverse word ;
 M: no-inverse summary
     drop "The word cannot be used in pattern matching" ;
 
-GENERIC: inverse ( word -- quot )
+: next ( revquot -- revquot* first )
+    dup empty?
+    [ "Badly formed math inverse" throw ]
+    [ unclip-slice ] if ;
+
+: constant-word? ( word -- ? )
+    stack-effect
+    [ effect-out length 1 = ] keep
+    effect-in length 0 = and ;
+
+: assure-constant ( constant -- quot )
+    dup word? [
+        dup constant-word?
+        [ "Badly formed math inverse" throw ] unless
+    ] when 1quotation ;
+
+: swap-inverse ( math-inverse revquot -- revquot* quot )
+    next assure-constant rot second [ swap ] swap 3compose ;
+
+: pull-inverse ( math-inverse revquot const -- revquot* quot )
+    assure-constant rot first compose ;
+
+: ?word-prop ( word/object name -- value/f )
+    over word? [ word-prop ] [ 2drop f ] if ;
+
+GENERIC: inverse ( revquot word -- revquot* quot )
 
 M: word inverse
     dup "inverse" word-prop [ ]
@@ -48,32 +80,23 @@ M: word inverse
 M: object inverse undo-literal ;
 M: symbol inverse undo-literal ;
 
-: ?word-prop ( word/object name -- value/f )
-    over word? [ word-prop ] [ 2drop f ] if ;
+PREDICATE: word math-inverse "math-inverse" word-prop ;
+M: math-inverse inverse
+    "math-inverse" word-prop
+    swap next dup \ swap =
+    [ drop swap-inverse ] [ pull-inverse ] if ;
 
-: group-pops ( seq -- matrix )
-    [
-        dup length [
-            2dup swap nth dup "pop-length" ?word-prop
-            [ 1+ dupd + tuck >r pick r> swap subseq , 1- ]
-            [ 1quotation , ] ?if
-        ] repeat drop
-    ] [ ] make ;
+PREDICATE: word pop-inverse "pop-length" word-prop ;
+M: pop-inverse inverse
+    [ "pop-length" word-prop cut-slice swap ] keep
+    "pop-inverse" word-prop compose call ;
 
-: inverse-pop ( quot -- inverse )
-    unclip >r reverse r> "pop-inverse" word-prop call ;
-
-: firstn ( n -- quot )
-    { [ drop ] [ first ] [ first2 ] [ first3 ] [ first4 ] } nth ;
-
-: define-pop-inverse ( word n quot -- )
-    -rot 2dup "pop-length" set-word-prop
-    firstn rot append "pop-inverse" set-word-prop ;
+: (undo) ( revquot -- )
+    dup empty? [ drop ]
+    [ unclip-slice inverse % (undo) ] if ;
 
 : [undo] ( quot -- undo )
-    reverse group-pops [
-        dup length 1 = [ first inverse ] [ inverse-pop ] if
-    ] map concat [ ] like ;
+    reverse [ (undo) ] [ ] make ;
 
 MACRO: undo ( quot -- ) [undo] ;
 
@@ -96,8 +119,6 @@ MACRO: undo ( quot -- ) [undo] ;
 \ undo 1 [ [ call ] curry ] define-pop-inverse
 \ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
 
-\ neg [ neg ] define-inverse
-\ recip [ recip ] define-inverse
 \ exp [ log ] define-inverse
 \ log [ exp ] define-inverse
 \ not [ not ] define-inverse
@@ -107,11 +128,11 @@ MACRO: undo ( quot -- ) [undo] ;
 : assert-literal ( n -- n )
     dup [ word? ] keep symbol? not and
     [ "Literal missing in pattern matching" throw ] when ;
-\ + 1 [ assert-literal [ - ] curry ] define-pop-inverse
-\ - 1 [ assert-literal [ + ] curry ] define-pop-inverse
-\ * 1 [ assert-literal [ / ] curry ] define-pop-inverse
-\ / 1 [ assert-literal [ * ] curry ] define-pop-inverse
-\ ^ 1 [ assert-literal recip [ ^ ] curry ] define-pop-inverse
+\ + [ - ] [ - ] define-math-inverse
+\ - [ + ] [ - ] define-math-inverse
+\ * [ / ] [ / ] define-math-inverse
+\ / [ * ] [ / ] define-math-inverse
+\ ^ [ recip ^ ] [ [ log ] 2apply / ] define-math-inverse
 
 \ ? 2 [
     [ assert-literal ] 2apply
@@ -160,13 +181,13 @@ MACRO: undo ( quot -- ) [undo] ;
 : slot-readers ( class -- quot )
     "slots" word-prop 1 tail ! tail gets rid of delegate
     [ slot-spec-reader 1quotation [ keep ] curry ] map concat
-    [ drop ] append ;
+    [ ] like [ drop ] compose ;
 
 : ?wrapped ( object -- wrapped )
     dup wrapper? [ wrapped ] when ;
 
 : boa-inverse ( class -- quot )
-    [ deconstruct-pred ] keep slot-readers append ;
+    [ deconstruct-pred ] keep slot-readers compose ;
 
 \ construct-boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 
@@ -186,7 +207,7 @@ MACRO: undo ( quot -- ) [undo] ;
     [ writer>reader ] map [ get-slots ] curry
     compose ;
 
-\ construct 2 [ ?wrapped swap construct-inverse ] define-pop-inverse
+\ construct 2 [ >r ?wrapped r> construct-inverse ] define-pop-inverse
 
 ! More useful inverse-based combinators
 
@@ -196,21 +217,27 @@ MACRO: undo ( quot -- ) [undo] ;
         [ drop call ] [ nip throw ] if
     ] recover ; inline
 
-: infer-out ( quot -- #out )
-    infer effect-out ;
+: true-out ( quot effect -- quot' )
+    effect-out [ ndrop ] curry
+    [ t ] 3compose ;
 
-MACRO: matches? ( quot -- ? )
-    [undo] [ t ] append
-    [ [ [ f ] recover-fail ] curry ] keep
-    infer-out 1- [ nnip ] curry append ;
+: false-recover ( effect -- quot )
+    effect-in [ ndrop f ] curry [ recover-fail ] curry ;
+
+: [matches?] ( quot -- undoes?-quot )
+    [undo] dup infer [ true-out ] keep false-recover curry ;
+
+MACRO: matches? ( quot -- ? ) [matches?] ;
 
 TUPLE: no-match ;
 : no-match ( -- * ) \ no-match construct-empty throw ;
-M: no-match summary drop "Fall through in which" ;
+M: no-match summary drop "Fall through in switch" ;
 
 : recover-chain ( seq -- quot )
     [ no-match ] [ swap \ recover-fail 3array >quotation ] reduce ;
 
-MACRO: which ( quot-alist -- )
-    reverse [ >r [undo] r> append ] { } assoc>map
+: [switch]  ( quot-alist -- quot )
+    reverse [ >r [undo] r> compose ] { } assoc>map
     recover-chain ;
+
+MACRO: switch ( quot-alist -- ) [switch] ;

extra/rss/rss.factor

@@ -3,22 +3,14 @@
 IN: rss
 ! USING: kernel http-client xml xml-utils xml-data errors io strings
 !    sequences xml-writer parser-combinators lazy-lists entities ;
-USING: xml.utilities kernel promises parser-combinators assocs
-    parser-combinators.replace strings sequences xml.data xml.writer
+USING: xml.utilities kernel assocs
+    strings sequences xml.data xml.writer
     io.streams.string combinators xml xml.entities io.files io
     http.client ;
 
 : ?children>string ( tag/f -- string/f )
     [ children>string ] [ f ] if* ;
 
-LAZY: '&' ( -- parser )
-    "&" token
-    [ blank? ] satisfy &>
-    [ "&amp;" swap add ] <@ ;
-
-: &>&amp; ( string -- string )
-    '&amp;' replace ;
-
 TUPLE: feed title link entries ;
 
 C: <feed> feed