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

Conflicts:

	extra/sequences/lib/lib-tests.factor
	extra/sequences/lib/lib.factor

extra/combinators/lib/lib-docs.factor

@@ -23,7 +23,7 @@ HELP: ndip
   { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
   { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
 }
-{ $see-also dip dipd } ;
+{ $see-also dip 2dip } ;
 
 HELP: nslip
 { $values { "n" number } }

extra/combinators/lib/lib-tests.factor

@@ -5,9 +5,6 @@ IN: combinators.lib.tests
 [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test
 [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test
 
-{ 6 2 } [ 1 2 [ 5 + ] dip ] unit-test
-{ 6 2 1 } [ 1 2 1 [ 5 + ] dipd ] unit-test
-
 [ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
 { 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
 [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer

extra/combinators/lib/lib.factor

@@ -38,8 +38,6 @@ MACRO: napply ( n -- )
 
 : 3apply ( obj obj obj quot -- ) 3 napply ; inline
 
-: dipd ( x y quot -- y ) 2 ndip ; inline
-
 : 2with ( param1 param2 obj quot -- obj curry )
     with with ; inline
 

extra/dns/cache/cache.factor

@@ -47,15 +47,9 @@ TUPLE: entry time data ;
 
 SYMBOL: NX
 
-: cache-nx ( query ttl -- )
+: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ;
-  ttl->time NX entry boa
-  table-add ;
 
-: nx? ( obj -- ? )
+: nx? ( obj -- ? ) dup entry? [ data>> NX = ] [ drop f ] if ;
-  dup entry?
-    [ data>> NX = ]
-    [ drop f ]
-  if ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
@@ -72,27 +66,15 @@ SYMBOL: NX
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: entry-expired? ( entry -- ? ) time>> time->ttl 0 <= ;
+: expired? ( entry -- ? ) time>> time->ttl 0 <= ;
 
 : cache-get ( query -- result )
   dup table-get               ! query result
     {
-      {
+      { [ dup f = ]      [ 2drop f ]          } ! not in the cache
-        [ dup f = ] ! not in the cache
+      { [ dup expired? ] [ drop table-rem f ] } ! here but expired
-        [ 2drop f ]
+      { [ dup nx?  ]     [ 2drop NX ]         } ! negative result cached
-      }
+      { [ t ]            [ query+entry->rrs ] } ! good to go
-      {
-        [ dup entry-expired? ] ! here but expired
-        [ drop table-rem f   ]
-      }
-      {
-        [ dup nx?  ] ! negative result has been cached
-        [ 2drop NX ]
-      }
-      {
-        [ t ]
-        [ query+entry->rrs ]
-      }
     }
   cond ;
 
@@ -114,22 +96,10 @@ SYMBOL: NX
 : cache-add ( query rr -- )
   over table-get          ! query rr entry
     {
-      {
+      { [ dup f = ]      [ drop rr->entry table-add ] }
-        [ dup f = ] ! not in the cache
+      { [ dup nx? ]      [ drop over table-rem rr->entry table-add ] }
-        [ drop rr->entry table-add ]
+      { [ dup expired? ] [ drop rr->entry table-add ] }
-      }
+      { [ t ]            [ rot drop add-rr-to-entry ] }
-      {
-        [ dup nx? ]
-        [ drop over table-rem rr->entry table-add ]
-      }
-      {
-        [ dup entry-expired? ]
-        [ drop rr->entry table-add ]
-      }
-      {
-        [ t ]
-        [ rot drop add-rr-to-entry ]
-      }
     }
   cond ;
 

extra/dns/resolver/resolver.factor

@@ -6,6 +6,8 @@ IN: dns.resolver
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
+! Need to cache records even in the case of name error
+
 : cache-message ( message -- message )
   dup dup rcode>> NAME-ERROR =
     [

extra/farkup/farkup-tests.factor

@@ -16,10 +16,18 @@ IN: farkup.tests
 [ "<p>**</p>" ] [ "\\**" convert-farkup ] unit-test
 
 [ "" ] [ "\n\n" convert-farkup ] unit-test
+[ "" ] [ "\r\n\r\n" convert-farkup ] unit-test
+[ "" ] [ "\r\r\r\r" convert-farkup ] unit-test
+[ "\n" ] [ "\r\r\r" convert-farkup ] unit-test
 [ "\n" ] [ "\n\n\n" convert-farkup ] unit-test
 [ "<p>foo</p><p>bar</p>" ] [ "foo\n\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\rbar" convert-farkup ] unit-test
+[ "<p>foo</p><p>bar</p>" ] [ "foo\r\r\nbar" convert-farkup ] unit-test
 
 [ "\n<p>bar\n</p>" ] [ "\nbar\n" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\rbar\r" convert-farkup ] unit-test
+[ "\n<p>bar\n</p>" ] [ "\r\nbar\r\n" convert-farkup ] unit-test
 
 [ "<p>foo</p>\n<p>bar</p>" ] [ "foo\n\n\nbar" convert-farkup ] unit-test
 

extra/farkup/farkup.factor

@@ -9,14 +9,14 @@ IN: farkup
 <PRIVATE
 
 : delimiters ( -- string )
-    "*_^~%[-=|\\\n" ; inline
+    "*_^~%[-=|\\\r\n" ; inline
 
 MEMO: text ( -- parser )
     [ delimiters member? not ] satisfy repeat1
     [ >string escape-string ] action ;
 
 MEMO: delimiter ( -- parser )
-    [ dup delimiters member? swap "\n=" member? not and ] satisfy
+    [ dup delimiters member? swap "\r\n=" member? not and ] satisfy
     [ 1string ] action ;
 
 : surround-with-foo ( string tag -- seq )
@@ -37,8 +37,11 @@ MEMO: emphasis ( -- parser ) "_" "em" delimited ;
 MEMO: superscript ( -- parser ) "^" "sup" delimited ;
 MEMO: subscript ( -- parser ) "~" "sub" delimited ;
 MEMO: inline-code ( -- parser ) "%" "code" delimited ;
-MEMO: nl ( -- parser ) "\n" token ;
+MEMO: nl ( -- parser )
-MEMO: 2nl ( -- parser ) "\n\n" token hide ;
+    "\r\n" token [ drop "\n" ] action
+    "\r" token [ drop "\n" ] action
+    "\n" token 3choice ;
+MEMO: 2nl ( -- parser ) nl hide nl hide 2seq ;
 MEMO: h1 ( -- parser ) "=" "h1" delimited ;
 MEMO: h2 ( -- parser ) "==" "h2" delimited ;
 MEMO: h3 ( -- parser ) "===" "h3" delimited ;
@@ -119,7 +122,7 @@ MEMO: list-item ( -- parser )
     ] seq* [ "li" surround-with-foo ] action ;
 
 MEMO: list ( -- parser )
-    list-item "\n" token hide list-of
+    list-item nl hide list-of
     [ "ul" surround-with-foo ] action ;
 
 MEMO: table-column ( -- parser )
@@ -151,8 +154,8 @@ MEMO: line ( -- parser )
 
 MEMO: paragraph ( -- parser )
     line
-    "\n" token over 2seq repeat0
+    nl over 2seq repeat0
-    "\n" token "\n" token ensure-not 2seq optional 3seq
+    nl nl ensure-not 2seq optional 3seq
     [
         dup [ dup string? not swap [ blank? ] all? or ] deep-all?
         [ "<p>" swap "</p>" 3array ] unless
@@ -163,7 +166,7 @@ PRIVATE>
 PEG: parse-farkup ( -- parser )
     [
         list , table , h1 , h2 , h3 , h4 , code , paragraph , 2nl , nl ,
-    ] choice* repeat0 "\n" token optional 2seq ;
+    ] choice* repeat0 nl optional 2seq ;
 
 : write-farkup ( parse-result  -- )
     [ dup string? [ write ] [ drop ] if ] deep-each ;

extra/html/parser/analyzer/analyzer.factor

@@ -3,25 +3,27 @@ arrays shuffle unicode.case namespaces splitting http
 sequences.lib accessors io combinators http.client ;
 IN: html.parser.analyzer
 
+TUPLE: link attributes clickable ;
+
 : scrape-html ( url -- vector )
     http-get parse-html ;
 
 : (find-relative)
-    [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ;
+    [ >r + dup r> ?nth* [ 2drop f f ] unless ] [ 2drop f ] if ; inline
 
 : find-relative ( seq quot n -- i elt )
     >r over [ find drop ] dip r> swap pick
-    (find-relative) ;
+    (find-relative) ; inline
 
 : (find-all) ( n seq quot -- )
     2dup >r >r find-from [
         dupd 2array , 1+ r> r> (find-all)
     ] [
         r> r> 3drop
-    ] if* ;
+    ] if* ; inline
 
 : find-all ( seq quot -- alist )
-    [ 0 -rot (find-all) ] { } make ;
+    [ 0 -rot (find-all) ] { } make ; inline
 
 : (find-nth) ( offset seq quot n count -- obj )
     >r >r [ find-from ] 2keep 4 npick [
@@ -33,14 +35,14 @@ IN: html.parser.analyzer
         ] if
     ] [
         2drop r> r> 2drop
-    ] if ;
+    ] if ; inline
 
 : find-nth ( seq quot n -- i elt )
-    0 -roll 0 (find-nth) ;
+    0 -roll 0 (find-nth) ; inline
 
 : find-nth-relative ( seq quot n offest -- i elt )
     >r [ find-nth ] 3keep 2drop nip r> swap pick
-    (find-relative) ;
+    (find-relative) ; inline
 
 : remove-blank-text ( vector -- vector' )
     [
@@ -120,9 +122,14 @@ IN: html.parser.analyzer
     [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
     find-between-all ;
 
+: <link> ( vector -- link )
+    [ first attributes>> ]
+    [ [ name>> { text "img" } member? ] filter ] bi
+    link boa ;
+
 : link. ( vector -- )
-    [ second text>> write bl ]
+    [ attributes>> "href" swap at write nl ]
-    [ first tag-link write nl ] bi ;
+    [ clickable>> [ bl bl text>> print ] each nl ] bi ;
 
 : find-by-text ( seq quot -- tag )
     [ dup name>> text = ] prepose find drop ;
@@ -136,12 +143,12 @@ IN: html.parser.analyzer
 
 : find-forms ( vector -- vector' )
     "form" over find-opening-tags-by-name
-    over [ >r first2 r> find-between* ] curry map
+    swap [ >r first2 r> find-between* ] curry map
     [ [ name>> { "form" "input" } member? ] filter ] map ;
 
 : find-html-objects ( string vector -- vector' )
-    find-opening-tags-by-name
+    [ find-opening-tags-by-name ] keep
-    over [ >r first2 r> find-between* ] curry map ;
+    [ >r first2 r> find-between* ] curry map ;
 
 : form-action ( vector -- string )
     [ name>> "form" = ] find nip 

extra/lisp/parser/parser.factor

@@ -19,7 +19,7 @@ dquote       = '"'
 squote       = "'"
 digit        = [0-9]
 integer      = ("-")? (digit)+                           => [[ first2 append string>number ]]
-float        = integer "." (digit)*                      => [[ first3 >string [ number>string ] dipd 3append string>number ]]
+float        = integer "." (digit)*                      => [[ first3 >string [ number>string ] 2dip 3append string>number ]]
 rational     = integer "/" (digit)+                      => [[ first3 nip string>number / ]]
 number       = float
               | rational

extra/peg/ebnf/ebnf.factor

@@ -50,7 +50,7 @@ C: <ebnf> ebnf
 : syntax-pack ( begin parser end -- parser )
   #! Parse 'parser' surrounded by syntax elements
   #! begin and end.
-  [ syntax ] dipd syntax pack ;
+  [ syntax ] 2dip syntax pack ;
 
 : 'identifier' ( -- parser )
   #! Return a parser that parses an identifer delimited by

extra/project-euler/047/047.factor

@@ -35,8 +35,8 @@ IN: project-euler.047
     pick pick = [
         swap - nip
     ] [
-        dup prime? [ [ drop 0 ] dipd ] [
+        dup prime? [ [ drop 0 ] 2dip ] [
-            2dup unique-factors length = [ [ 1+ ] dipd ] [ [ drop 0 ] dipd ] if
+            2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if
         ] if 1+ (consecutive)
     ] if ;
 

extra/reports/noise/noise.factor

@@ -35,7 +35,7 @@ IN: reports.noise
         { compose 1/2 }
         { curry 1/3 }
         { dip 1 }
-        { dipd 2 }
+        { 2dip 2 }
         { drop 1/3 }
         { dup 1/3 }
         { if 1/3 }

extra/sequences/lib/lib-docs.factor

@@ -37,3 +37,23 @@ HELP: count
     "100 [1,b] [ even? ] count ."
     "50"
 } ;
+
+HELP: if-seq
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty.  If the sequence has any elements, " { $snippet "quot1" } " is called on it.  Otherwise, the empty sequence is dropped and " { $snippet "quot2" } " is called." }
+{ $example
+    "USING: kernel prettyprint sequences sequences.lib ;"
+    "{ 1 2 3 } [ sum ] [ \"empty sequence\" throw ] if-seq ."
+    "6"
+} ;
+
+HELP: if-empty
+{ $values { "seq" sequence } { "quot1" quotation } { "quot2" quotation } }
+{ $description "Makes an implicit check if the sequence is empty. An empty sequence is dropped and " { $snippet "quot1" } " is called. Otherwise, if the sequence has any elements, " { $snippet "quot2" } " is called on it." }
+{ $example
+    "USING: kernel prettyprint sequences sequences.lib ;"
+    "{ 1 2 3 } [ \"empty sequence\" ] [ sum ] if-empty ."
+    "6"
+} ;
+
+{ if-seq if-empty } related-words

extra/sequences/lib/lib-tests.factor

@@ -80,4 +80,12 @@ IN: sequences.lib.tests
 [ ] [ { } 0 firstn ] unit-test
 [ "a" ] [ { "a" } 1 firstn ] unit-test
 
+<<<<<<< HEAD:extra/sequences/lib/lib-tests.factor
 [ { { 1 1 } { 1 2 } { 2 0 } } ] [ { { 2 0 } { 1 1 } { 1 2 } } dup [ first ] insertion-sort ] unit-test
+=======
+[ "empty" ] [ { } [ "not empty" ] [ "empty" ] if-seq ] unit-test
+[ { 1 } "not empty" ] [ { 1 } [ "not empty" ] [ "empty" ] if-seq ] unit-test
+
+[ "empty" ] [ { } [ "empty" ] [ "not empty" ] if-empty ] unit-test
+[ { 1 } "not empty" ] [ { 1 } [ "empty" ] [ "not empty" ] if-empty ] unit-test
+>>>>>>> 299bb1fb1692a4427f5b46f70dbbcefd6aa57163:extra/sequences/lib/lib-tests.factor

extra/sequences/lib/lib.factor

@@ -257,3 +257,9 @@ PRIVATE>
 : insertion-sort ( seq quot -- )
     ! quot is a transformation on elements
     over length [ insert ] 2with each ; inline
+
+: if-seq ( seq quot1 quot2 -- )
+    [ f like ] 2dip if* ; inline
+
+: if-empty ( seq quot1 quot2 -- )
+    swap if-seq ; inline

extra/space-invaders/space-invaders.factor

@@ -22,9 +22,9 @@ TUPLE: space-invaders port1 port2i port2o port3o port4lo port4hi port5o bitmap s
 : set-bitmap-pixel ( color point array -- )
   #! 'color' is a {r g b}. Point is {x y}.
   [ bitmap-index ] dip ! color index array
-  [ [ first ] dipd set-uchar-nth ] 3keep
+  [ [ first ] 2dip set-uchar-nth ] 3keep
-  [ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep
+  [ [ second ] 2dip [ 1 + ] dip set-uchar-nth ] 3keep
-  [ third ] dipd [ 2 + ] dip set-uchar-nth ;
+  [ third ] 2dip [ 2 + ] dip set-uchar-nth ;
 
 : get-bitmap-pixel ( point array -- color )
   #! Point is a {x y}. color is a {r g b} 
@@ -311,7 +311,7 @@ M: invaders-gadget draw-gadget* ( gadget -- )
 
 : plot-bitmap-bits ( bitmap point byte bit -- )
   #! point is a {x y}.
-  [ first2 ] dipd
+  [ first2 ] 2dip
   dup swapd -1 * shift 1 bitand 0 =
   [ - 2array ] dip
   [ black ] [ dup get-point-color ] if

extra/taxes/taxes.factor

@@ -33,6 +33,13 @@ TUPLE: fica-base-unknown ;
 
 ! Employer tax only, not withheld
 : futa-tax-rate ( -- x ) DECIMAL: .062 ; inline
+: futa-base-rate ( -- x ) 7000 ; inline
+: futa-tax-offset-credit ( -- x ) DECIMAL: .054 ; inline
+
+: futa-tax ( salary w4 -- x )
+    drop futa-base-rate min
+    futa-tax-rate futa-tax-offset-credit -
+    * ;
 
 ! No base rate for medicare; all wages subject
 : medicare-tax-rate ( -- x ) DECIMAL: .0145 ; inline