diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index c88ce8d9f9..355d5647df 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/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 } } diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 54847dc8b3..200a667b6b 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/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 diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index d4a9386649..4c4a988935 100755 --- a/extra/combinators/lib/lib.factor +++ b/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 diff --git a/extra/dns/cache/cache.factor b/extra/dns/cache/cache.factor index e497192b04..75bbf9de9d 100644 --- a/extra/dns/cache/cache.factor +++ b/extra/dns/cache/cache.factor @@ -47,15 +47,9 @@ TUPLE: entry time data ; SYMBOL: NX -: cache-nx ( query ttl -- ) - ttl->time NX entry boa - table-add ; +: cache-nx ( query ttl -- ) ttl->time NX entry boa table-add ; -: nx? ( obj -- ? ) - dup entry? - [ data>> NX = ] - [ drop f ] - if ; +: nx? ( obj -- ? ) 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 = ] ! not in the cache - [ 2drop f ] - } - { - [ dup entry-expired? ] ! here but expired - [ drop table-rem f ] - } - { - [ dup nx? ] ! negative result has been cached - [ 2drop NX ] - } - { - [ t ] - [ query+entry->rrs ] - } + { [ dup f = ] [ 2drop f ] } ! not in the cache + { [ dup expired? ] [ drop table-rem f ] } ! here but expired + { [ dup nx? ] [ 2drop NX ] } ! negative result cached + { [ t ] [ query+entry->rrs ] } ! good to go } cond ; @@ -114,22 +96,10 @@ SYMBOL: NX : cache-add ( query rr -- ) over table-get ! query rr entry { - { - [ dup f = ] ! not in the cache - [ drop rr->entry table-add ] - } - { - [ 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 ] - } + { [ dup f = ] [ drop rr->entry table-add ] } + { [ dup nx? ] [ drop over table-rem rr->entry table-add ] } + { [ dup expired? ] [ drop rr->entry table-add ] } + { [ t ] [ rot drop add-rr-to-entry ] } } cond ; diff --git a/extra/dns/resolver/resolver.factor b/extra/dns/resolver/resolver.factor index 2f77840d91..c8a9f22d08 100644 --- a/extra/dns/resolver/resolver.factor +++ b/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 = [ diff --git a/extra/farkup/farkup-tests.factor b/extra/farkup/farkup-tests.factor index 7176486f8e..b6e46cfe7d 100755 --- a/extra/farkup/farkup-tests.factor +++ b/extra/farkup/farkup-tests.factor @@ -16,10 +16,18 @@ IN: farkup.tests [ "

**

" ] [ "\\**" 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 [ "

foo

bar

" ] [ "foo\n\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\n\r\nbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\rbar" convert-farkup ] unit-test +[ "

foo

bar

" ] [ "foo\r\r\nbar" convert-farkup ] unit-test [ "\n

bar\n

" ] [ "\nbar\n" convert-farkup ] unit-test +[ "\n

bar\n

" ] [ "\rbar\r" convert-farkup ] unit-test +[ "\n

bar\n

" ] [ "\r\nbar\r\n" convert-farkup ] unit-test [ "

foo

\n

bar

" ] [ "foo\n\n\nbar" convert-farkup ] unit-test diff --git a/extra/farkup/farkup.factor b/extra/farkup/farkup.factor index 15b7b4b72c..51a5a10bd9 100755 --- a/extra/farkup/farkup.factor +++ b/extra/farkup/farkup.factor @@ -9,14 +9,14 @@ IN: farkup 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: 2nl ( -- parser ) "\n\n" token hide ; +MEMO: nl ( -- parser ) + "\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 - "\n" token "\n" token ensure-not 2seq optional 3seq + nl over 2seq repeat0 + nl nl ensure-not 2seq optional 3seq [ dup [ dup string? not swap [ blank? ] all? or ] deep-all? [ "

" swap "

" 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 ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index 42355f954e..9ce45b5c47 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/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 ; +: ( vector -- link ) + [ first attributes>> ] + [ [ name>> { text "img" } member? ] filter ] bi + link boa ; + : link. ( vector -- ) - [ second text>> write bl ] - [ first tag-link write nl ] bi ; + [ attributes>> "href" swap at write nl ] + [ 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 - over [ >r first2 r> find-between* ] curry map ; + [ find-opening-tags-by-name ] keep + [ >r first2 r> find-between* ] curry map ; : form-action ( vector -- string ) [ name>> "form" = ] find nip diff --git a/extra/lisp/parser/parser.factor b/extra/lisp/parser/parser.factor index 44c79fd962..cf5ff56331 100644 --- a/extra/lisp/parser/parser.factor +++ b/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 diff --git a/extra/peg/ebnf/ebnf.factor b/extra/peg/ebnf/ebnf.factor index c3252de500..8a3a06c58d 100644 --- a/extra/peg/ebnf/ebnf.factor +++ b/extra/peg/ebnf/ebnf.factor @@ -50,7 +50,7 @@ C: 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 diff --git a/extra/project-euler/047/047.factor b/extra/project-euler/047/047.factor index 98e819a7db..e59ca56f39 100644 --- a/extra/project-euler/047/047.factor +++ b/extra/project-euler/047/047.factor @@ -35,8 +35,8 @@ IN: project-euler.047 pick pick = [ swap - nip ] [ - dup prime? [ [ drop 0 ] dipd ] [ - 2dup unique-factors length = [ [ 1+ ] dipd ] [ [ drop 0 ] dipd ] if + dup prime? [ [ drop 0 ] 2dip ] [ + 2dup unique-factors length = [ [ 1+ ] 2dip ] [ [ drop 0 ] 2dip ] if ] if 1+ (consecutive) ] if ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 3b37171da3..f94c774943 100755 --- a/extra/reports/noise/noise.factor +++ b/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 } diff --git a/extra/sequences/lib/lib-docs.factor b/extra/sequences/lib/lib-docs.factor index 6f4a173874..14fb6eaebf 100755 --- a/extra/sequences/lib/lib-docs.factor +++ b/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 diff --git a/extra/sequences/lib/lib-tests.factor b/extra/sequences/lib/lib-tests.factor index 914cb6465d..7a941b160a 100755 --- a/extra/sequences/lib/lib-tests.factor +++ b/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 diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index ac12505771..5c34b7315b 100755 --- a/extra/sequences/lib/lib.factor +++ b/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 diff --git a/extra/space-invaders/space-invaders.factor b/extra/space-invaders/space-invaders.factor index f773d331b1..d3ca3673f4 100755 --- a/extra/space-invaders/space-invaders.factor +++ b/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 - [ [ second ] dipd [ 1 + ] dip set-uchar-nth ] 3keep - [ third ] dipd [ 2 + ] dip set-uchar-nth ; + [ [ first ] 2dip set-uchar-nth ] 3keep + [ [ second ] 2dip [ 1 + ] dip set-uchar-nth ] 3keep + [ 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 diff --git a/extra/taxes/taxes.factor b/extra/taxes/taxes.factor index 8456d95673..1f4eb556dc 100644 --- a/extra/taxes/taxes.factor +++ b/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