Merge git://factorcode.org/git/factor

extra/inverse/inverse.factor

@@ -1,18 +1,9 @@
 USING: kernel words inspector slots quotations sequences assocs
 math arrays inference effects shuffle continuations debugger
 tuples namespaces vectors bit-arrays byte-arrays strings sbufs
-math.functions macros ;
+math.functions macros combinators.private combinators ;
 IN: inverse
 
-: (repeat) ( from to quot -- )
-    pick pick >= [
-        3drop
-    ] [
-        [ swap >r call 1+ r> ] keep (repeat)
-    ] if ; inline
-
-: repeat ( n quot -- ) 0 -rot (repeat) ; inline
-
 TUPLE: fail ;
 : fail ( -- * ) \ fail construct-empty throw ;
 M: fail summary drop "Unification failed" ;
@@ -27,17 +18,12 @@ 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 ;
+    pick 1quotation 3array "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 )
-    word-def [undo] ;
-
 TUPLE: no-inverse word ;
 : no-inverse ( word -- * ) \ no-inverse construct-empty throw ;
 M: no-inverse summary
@@ -54,10 +40,7 @@ M: no-inverse summary
     effect-in length 0 = and ;
 
 : assure-constant ( constant -- quot )
-    dup word? [
+    dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
-        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 ;
@@ -68,25 +51,52 @@ M: no-inverse summary
 : ?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 [ ]
-    [ dup primitive? [ no-inverse ] [ make-inverse ] if ] ?if ;
-
 : undo-literal ( object -- quot )
     [ =/fail ] curry ;
 
+PREDICATE: word normal-inverse "inverse" word-prop ;
+PREDICATE: word math-inverse "math-inverse" word-prop ;
+PREDICATE: word pop-inverse "pop-length" word-prop ;
+UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
+
+: inline-word ( word -- )
+    {
+        { [ dup word? not over symbol? or ] [ , ] }
+        { [ dup explicit-inverse? ] [ , ] }
+        { [ dup compound? over { if dispatch } member? not and ]
+          [ word-def [ inline-word ] each ] }
+        { [ drop t ] [ "Quotation is not invertible" throw ] }
+    } cond ;
+
+: math-exp? ( n n word -- ? )
+    { + - * / ^ } member? -rot [ number? ] 2apply and and ;
+
+: (fold-constants) ( quot -- )
+    dup length 3 < [ % ] [
+        dup first3 3dup math-exp?
+        [ execute , 3 ] [ 2drop , 1 ] if
+        tail-slice (fold-constants) 
+    ] if ;
+
+: fold-constants ( quot -- folded )
+    [ (fold-constants) ] [ ] make ;
+
+: do-inlining ( quot -- inlined-quot )
+    [ [ inline-word ] each ] [ ] make fold-constants ;
+
+GENERIC: inverse ( revquot word -- revquot* quot )
+
 M: object inverse undo-literal ;
 M: symbol inverse undo-literal ;
 
-PREDICATE: word math-inverse "math-inverse" word-prop ;
+M: normal-inverse inverse
+    "inverse" word-prop ;
+
 M: math-inverse inverse
     "math-inverse" word-prop
     swap next dup \ swap =
     [ drop swap-inverse ] [ pull-inverse ] if ;
 
-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 ;
@@ -96,11 +106,11 @@ M: pop-inverse inverse
     [ unclip-slice inverse % (undo) ] if ;
 
 : [undo] ( quot -- undo )
-    reverse [ (undo) ] [ ] make ;
+    do-inlining reverse [ (undo) ] [ ] make ;
 
 MACRO: undo ( quot -- ) [undo] ;
 
-! Inversions of selected words
+! Inverse of selected words
 
 \ swap [ swap ] define-inverse
 \ dup [ [ =/fail ] keep ] define-inverse

extra/rss/rss-tests.factor

@@ -1,5 +1,9 @@
-USING: rss io.files tools.test ;
+USING: rss io kernel io.files tools.test ;
-IN: temporary
+
+: load-news-file ( filename -- feed )
+    #! Load an news syndication file and process it, returning
+    #! it as an feed tuple.
+    <file-reader> read-feed ;
 
 [ T{
     feed
@@ -34,4 +38,3 @@ IN: temporary
         }
     }
 } ] [ "extra/rss/atom.xml" resource-path load-news-file ] unit-test
-[ " &amp; &amp; hi" ] [ " & &amp; hi" &>&amp; ] unit-test

extra/rss/rss.factor

@@ -62,23 +62,17 @@ C: <entry> entry
         children>string <entry>
     ] map <feed> ;
 
-: feed ( xml -- feed )
+: xml>feed ( xml -- feed )
     dup name-tag {
         { "RDF" [ rss1.0 ] }
         { "rss" [ rss2.0 ] }
         { "feed" [ atom1.0 ] }
     } case ;
 
-: read-feed ( string -- feed )
+: read-feed ( stream -- feed )
-    ! &>&amp; ! this will be uncommented when parser-combinators are fixed
+    [ read-xml ] with-html-entities xml>feed ;
-    [ string>xml ] with-html-entities feed ;
 
-: load-news-file ( filename -- feed )
+: download-feed ( url -- feed )
-    #! Load an news syndication file and process it, returning
-    #! it as an feed tuple.
-    <file-reader> [ contents read-feed ] keep stream-close ;
-
-: news-get ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
     http-get rot 200 = [
         nip read-feed
@@ -90,7 +84,7 @@ C: <entry> entry
 : simple-tag, ( content name -- )
     [ , ] tag, ;
 
-: (generate-atom) ( entry -- )
+: entry, ( entry -- )
     "entry" [
         dup entry-title "title" simple-tag,
         "link" over entry-link "href" associate contained*,
@@ -98,9 +92,12 @@ C: <entry> entry
         entry-description "content" simple-tag,
     ] tag, ;
 
-: generate-atom ( feed -- xml )
+: feed>xml ( feed -- xml )
-    "feed" [
+    "feed" { { "xmlns" "http://www.w3.org/2005/Atom" } } [
         dup feed-title "title" simple-tag,
         "link" over feed-link "href" associate contained*,
-        feed-entries [ (generate-atom) ] each
+        feed-entries [ entry, ] each
-    ] make-xml ;
+    ] make-xml* ;
+
+: write-feed ( feed -- xml )
+    feed>xml write-xml ;

extra/units/si/si.factor

@@ -38,8 +38,11 @@ IN: units.si
 : cd/m^2 { cd } { m m } <dimensioned> ;
 : kg/kg { kg } { kg } <dimensioned> ;
 
-: radians ( n -- radian ) { m } { m } <dimensioned> ;
+! Radians are really m/m, and steradians are m^2/m^2
-: sr ( n -- steradian ) { m m } { m m } <dimensioned> ;
+! but they need to be in reduced form here.
+: radians ( n -- radian ) scalar ;
+: sr ( n -- steradian ) scalar ;
+
 : Hz ( n -- hertz ) { } { s } <dimensioned> ;
 : N ( n -- newton ) { kg m } { s s } <dimensioned> ;
 : Pa ( n -- pascal ) { kg } { m s s } <dimensioned> ;