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

basis/state-parser/state-parser.factor

@@ -94,7 +94,7 @@ SYMBOL: prolog-data
         [ call ] keep swap [ drop ] [
             next skip-until
         ] if
-    ] [ drop ] if ; inline
+    ] [ drop ] if ; inline recursive
 
 : take-until ( quot -- string )
     #! Take the substring of a string starting at spot

basis/xml/data/data.factor

@@ -1,25 +1,26 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private assocs arrays
-delegate.protocols delegate vectors ;
+delegate.protocols delegate vectors accessors multiline
+macros words quotations combinators ;
 IN: xml.data
 
-TUPLE: name space tag url ;
+TUPLE: name space main url ;
 C: <name> name
 
 : ?= ( object/f object/f -- ? )
     2dup and [ = ] [ 2drop t ] if ;
 
 : names-match? ( name1 name2 -- ? )
-    [ name-space swap name-space ?= ] 2keep
+    [ [ space>> ] bi@ ?= ]
-    [ name-url swap name-url ?= ] 2keep
+    [ [ url>> ] bi@ ?= ]
-    name-tag swap name-tag ?= and and ;
+    [ [ main>> ] bi@ ?= ] 2tri and and ;
 
-: <name-tag> ( string -- name )
+: <simple-name> ( string -- name )
     f swap f <name> ;
 
 : assure-name ( string/name -- name )
-    dup name? [ <name-tag> ] unless ;
+    dup name? [ <simple-name> ] unless ;
 
 TUPLE: opener name attrs ;
 C: <opener> opener
@@ -42,13 +43,11 @@ C: <instruction> instruction
 TUPLE: prolog version encoding standalone ;
 C: <prolog> prolog
 
-TUPLE: tag attrs children ;
-
 TUPLE: attrs alist ;
 C: <attrs> attrs
 
 : attr@ ( key alist -- index {key,value} )
-    >r assure-name r> attrs-alist
+    >r assure-name r> alist>>
     [ first names-match? ] with find ;
 
 M: attrs at*
@@ -58,12 +57,12 @@ M: attrs set-at
         2nip set-second
     ] [
         >r assure-name swap 2array r>
-        [ attrs-alist ?push ] keep set-attrs-alist
+        [ alist>> ?push ] keep (>>alist)
     ] if* ;
 
-M: attrs assoc-size attrs-alist length ;
+M: attrs assoc-size alist>> length ;
 M: attrs new-assoc drop V{ } new-sequence <attrs> ;
-M: attrs >alist attrs-alist ;
+M: attrs >alist alist>> ;
 
 : >attrs ( assoc -- attrs )
     dup [
@@ -74,61 +73,71 @@ M: attrs assoc-like
     drop dup attrs? [ >attrs ] unless ;
 
 M: attrs clear-assoc
-    f swap set-attrs-alist ;
+    f >>alist drop ;
 M: attrs delete-at
-    tuck attr@ drop [ swap attrs-alist delete-nth ] [ drop ] if* ;
+    tuck attr@ drop [ swap alist>> delete-nth ] [ drop ] if* ;
 
 M: attrs clone
-    attrs-alist clone <attrs> ;
+    alist>> clone <attrs> ;
 
 INSTANCE: attrs assoc
 
+TUPLE: tag name attrs children ;
+
 : <tag> ( name attrs children -- tag )
-    >r >r assure-name r> T{ attrs } assoc-like r>
+    [ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
-    { set-delegate set-tag-attrs set-tag-children }
+    tag boa ;
-    tag construct ;
 
 ! For convenience, tags follow the assoc protocol too (for attrs)
 CONSULT: assoc-protocol tag tag-attrs ;
 INSTANCE: tag assoc
 
 ! They also follow the sequence protocol (for children)
-CONSULT: sequence-protocol tag tag-children ;
+CONSULT: sequence-protocol tag children>> ;
 INSTANCE: tag sequence
 
+CONSULT: name tag name>> ;
+
 M: tag like
     over tag? [ drop ] [
-        [ delegate ] keep tag-attrs
+        [ name>> ] keep tag-attrs
         rot dup [ V{ } like ] when <tag>
     ] if ;
 
+MACRO: clone-slots ( class -- tuple )
+    [
+        "slots" word-prop
+        [ reader>> 1quotation [ clone ] compose ] map
+        [ cleave ] curry
+    ] [ [ boa ] curry ] bi compose ;
+
 M: tag clone
-    [ delegate clone ] keep [ tag-attrs clone ] keep
+    tag clone-slots ;
-    tag-children clone
-    { set-delegate set-tag-attrs set-tag-children } tag construct ;
 
-TUPLE: xml prolog before main after ;
+TUPLE: xml prolog before body after ;
-: <xml> ( prolog before main after -- xml )
+C: <xml> xml
-    { set-xml-prolog set-xml-before set-delegate set-xml-after }
-    xml construct ;
 
-CONSULT: sequence-protocol xml delegate ;
+CONSULT: sequence-protocol xml body>> ;
 INSTANCE: xml sequence
 
-CONSULT: assoc-protocol xml delegate ;
+CONSULT: assoc-protocol xml body>> ;
 INSTANCE: xml assoc
 
+CONSULT: tag xml body>> ;
+
+CONSULT: name xml body>> ;
+
 <PRIVATE
 : tag>xml ( xml tag -- newxml )
-    swap [ dup xml-prolog swap xml-before rot ] keep xml-after <xml> ;
+    >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+    swap <xml> ;
 
 : seq>xml ( xml seq -- newxml )
-    over delegate like tag>xml ;
+    over body>> like tag>xml ;
 PRIVATE>
 
 M: xml clone
-    [ xml-prolog clone ] keep [ xml-before clone ] keep
+   xml clone-slots ;
-    [ delegate clone ] keep xml-after clone <xml> ;
 
 M: xml like
     swap dup xml? [ nip ] [
@@ -139,5 +148,5 @@ M: xml like
 : <contained-tag> ( name attrs -- tag )
     f <tag> ;
 
-PREDICATE: contained-tag < tag tag-children not ;
+PREDICATE: contained-tag < tag children>> not ;
-PREDICATE: open-tag < tag tag-children ;
+PREDICATE: open-tag < tag children>> ;

basis/xml/tokenize/tokenize.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: xml.errors xml.data xml.utilities xml.char-classes sets
 xml.entities kernel state-parser kernel namespaces strings math
-math.parser sequences assocs arrays splitting combinators unicode.case ;
+math.parser sequences assocs arrays splitting combinators unicode.case
+accessors ;
 IN: xml.tokenize
 
 ! XML namespace processing: ns = namespace
@@ -14,8 +15,8 @@ SYMBOL: ns-stack
     ! this should check to make sure URIs are valid
     [
         [
-            swap dup name-space "xmlns" =
+            swap dup space>> "xmlns" =
-            [ name-tag set ]
+            [ main>> set ]
             [
                 T{ name f "" "xmlns" f } names-match?
                 [ "" set ] [ drop ] if
@@ -24,8 +25,8 @@ SYMBOL: ns-stack
     ] { } make-assoc f like ;
 
 : add-ns ( name -- )
-    dup name-space dup ns-stack get assoc-stack
+    dup space>> dup ns-stack get assoc-stack
-    [ nip ] [ <nonexist-ns> throw ] if* swap set-name-url ;
+    [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
 
 : push-ns ( hash -- )
     ns-stack get push ;

basis/xml/utilities/utilities.factor

@@ -10,13 +10,13 @@ IN: xml.utilities
 TUPLE: process-missing process tag ;
 M: process-missing error.
     "Tag <" write
-    dup process-missing-tag print-name
+    dup tag>> print-name
     "> not implemented on process process " write
-    process-missing-process name>> print ;
+    name>> print ;
 
 : run-process ( tag word -- )
     2dup "xtable" word-prop
-    >r dup name-tag r> at* [ 2nip call ] [
+    >r dup main>> r> at* [ 2nip call ] [
         drop \ process-missing boa throw
     ] if ;
 
@@ -48,17 +48,18 @@ M: process-missing error.
     standard-prolog { } rot { } <xml> ;
 
 : children>string ( tag -- string )
-    tag-children {
+    children>> {
         { [ dup empty? ] [ drop "" ] }
-        { [ dup [ string? not ] contains? ] [ "XML tag unexpectedly contains non-text children" throw ] }
+        { [ dup [ string? not ] contains? ]
+          [ "XML tag unexpectedly contains non-text children" throw ] }
         [ concat ]
     } cond ;
 
 : children-tags ( tag -- sequence )
-    tag-children [ tag? ] filter ;
+    children>> [ tag? ] filter ;
 
 : first-child-tag ( tag -- tag )
-    tag-children [ tag? ] find nip ;
+    children>> [ tag? ] find nip ;
 
 ! * Accessing part of an XML document
 ! for tag- words, a start means that it searches all children
@@ -91,7 +92,7 @@ M: process-missing error.
     assure-name [ tag-with-attr? ] 2curry find nip ;
 
 : tags-with-attr ( tag attr-value attr-name -- tags-seq )
-    tags@ [ tag-with-attr? ] 2curry filter tag-children ;
+    tags@ [ tag-with-attr? ] 2curry filter children>> ;
 
 : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
     assure-name [ tag-with-attr? ] 2curry deep-find ;
@@ -109,8 +110,8 @@ M: process-missing error.
     names-match? [ "Unexpected XML tag found" throw ] unless ;
 
 : insert-children ( children tag -- )
-    dup tag-children [ push-all ]
+    dup children>> [ push-all ]
-    [ >r V{ } like r> set-tag-children ] if ;
+    [ swap V{ } like >>children drop ] if ;
 
 : insert-child ( child tag -- )
     >r 1vector r> insert-children ;

basis/xml/writer/writer.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: hashtables kernel math namespaces sequences strings
-assocs combinators io io.streams.string
+assocs combinators io io.streams.string accessors
 xml.data wrap xml.entities unicode.categories ;
 IN: xml.writer
 
@@ -38,9 +38,9 @@ SYMBOL: indenter
     ] when ;
 
 : print-name ( name -- )
-    dup name-space f like
+    dup space>> f like
     [ write CHAR: : write1 ] when*
-    name-tag write ;
+    main>> write ;
 
 : print-attrs ( assoc -- )
     [
@@ -59,7 +59,7 @@ M: string write-item
 
 : write-tag ( tag -- )
     ?indent CHAR: < write1
-    dup print-name tag-attrs print-attrs ;
+    dup print-name attrs>> print-attrs ;
 
 : write-start-tag ( tag -- )
     write-tag ">" write ;
@@ -68,7 +68,7 @@ M: contained-tag write-item
     write-tag "/>" write ;
 
 : write-children ( tag -- )
-    indent tag-children ?filter-children
+    indent children>> ?filter-children
     [ write-item ] each unindent ;
 
 : write-end-tag ( tag -- )
@@ -85,18 +85,18 @@ M: open-tag write-item
     r> xml-pprint? set ;
 
 M: comment write-item
-    "<!--" write comment-text write "-->" write ;
+    "<!--" write text>> write "-->" write ;
 
 M: directive write-item
-    "<!" write directive-text write CHAR: > write1 ;
+    "<!" write text>> write CHAR: > write1 ;
 
 M: instruction write-item
-    "<?" write instruction-text write "?>" write ;
+    "<?" write text>> write "?>" write ;
 
 : write-prolog ( xml -- )
-    "<?xml version=\"" write dup prolog-version write
+    "<?xml version=\"" write dup version>> write
-    "\" encoding=\"" write dup prolog-encoding write
+    "\" encoding=\"" write dup encoding>> write
-    prolog-standalone [ "\" standalone=\"yes" write ] when
+    standalone>> [ "\" standalone=\"yes" write ] when
     "\"?>" write ;
 
 : write-chunk ( seq -- )
@@ -104,10 +104,10 @@ M: instruction write-item
 
 : write-xml ( xml -- )
     {
-        [ xml-prolog write-prolog ]
+        [ prolog>> write-prolog ]
-        [ xml-before write-chunk ]
+        [ before>> write-chunk ]
-        [ write-item ]
+        [ body>> write-item ]
-        [ xml-after write-chunk ]
+        [ after>> write-chunk ]
     } cleave ;
 
 : print-xml ( xml -- )

basis/xml/xml.factor

@@ -38,19 +38,19 @@ M: directive process
     add-child ;
 
 M: contained process
-    [ contained-name ] keep contained-attrs 
+    [ name>> ] [ attrs>> ] bi
     <contained-tag> add-child ;
 
 M: opener process push-xml ;
 
 : check-closer ( name opener -- name opener )
     dup [ <unopened> throw ] unless
-    2dup opener-name =
+    2dup name>> =
-    [ opener-name swap <mismatched> throw ] unless ;
+    [ name>> swap <mismatched> throw ] unless ;
 
 M: closer process
-    closer-name pop-xml first2
+    name>> pop-xml first2
-    >r check-closer opener-attrs r>
+    >r check-closer attrs>> r>
     <tag> add-child ;
 
 : init-xml-stack ( -- )
@@ -102,10 +102,10 @@ TUPLE: pull-xml scope ;
         init-parser reset-prolog init-ns-stack
         text-now? on
     ] H{ } make-assoc
-    { set-pull-xml-scope } pull-xml construct ;
+    pull-xml boa ;
 
 : pull-event ( pull -- xml-event/f )
-    pull-xml-scope [
+    scope>> [
         text-now? get [ parse-text f ] [
             get-char [ make-tag t ] [ f f ] if
         ] if text-now? set

extra/sequences/lib/lib.factor

@@ -193,7 +193,7 @@ USE: continuations
     [
         iterate-step roll
         [ 3nip ] [ iterate-next (attempt-each-integer) ] if*
-    ] [ 3drop f ] if-iterate? ; inline
+    ] [ 3drop f ] if-iterate? ; inline recursive
 PRIVATE>
 
 : attempt-each ( seq quot -- result )