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

basis/boxes/boxes.factor

@@ -23,4 +23,4 @@ ERROR: box-empty box ;
     dup occupied>> [ box> t ] [ drop f f ] if ;
 
 : if-box? ( box quot -- )
-    >r ?box r> [ drop ] if ; inline
+    [ ?box ] dip [ drop ] if ; inline

basis/calendar/calendar-docs.factor

@@ -99,6 +99,48 @@ HELP: seconds-per-year
 { $values { "integer" integer } }
 { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
 
+HELP: biweekly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of two week periods in a year." } ;
+
+HELP: daily-360
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of days in a 360-day year." } ;
+
+HELP: daily-365
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of days in a 365-day year." } ;
+
+HELP: monthly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of months in a year." } ;
+
+HELP: semimonthly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of half-months in a year. Note that biweekly has two more periods than semimonthly." } ;
+
+HELP: weekly
+{ $values
+     { "x" number }
+     { "y" number }
+}
+{ $description "Divides a number by the number of weeks in a year." } ;
+
 HELP: julian-day-number
 { $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
 { $description "Calculates the Julian day number from a year, month, and day.  The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
@@ -540,6 +582,8 @@ ARTICLE: "calendar" "Calendar"
 { $subsection "years" }
 { $subsection "months" }
 { $subsection "days" }
+"Calculating amounts per period of time:"
+{ $subsection "time-period-calculations" }
 "Meta-data about the calendar:"
 { $subsection "calendar-facts" }
 ;
@@ -626,6 +670,18 @@ ARTICLE: "calendar-facts" "Calendar facts"
 { $subsection day-of-week }
 ;
 
+ARTICLE: "time-period-calculations" "Calculations over periods of time"
+{ $subsection monthly }
+{ $subsection semimonthly }
+{ $subsection biweekly }
+{ $subsection weekly }
+{ $subsection daily-360 }
+{ $subsection daily-365 }
+{ $subsection biweekly }
+{ $subsection biweekly }
+{ $subsection biweekly }
+;
+
 ARTICLE: "years" "Year operations"
 "Leap year predicate:"
 { $subsection leap-year? }

basis/calendar/calendar-tests.factor

@@ -167,3 +167,5 @@ IN: calendar.tests
 [ t ] [ now 50 milliseconds sleep now before? ] unit-test
 [ t ] [ now 50 milliseconds sleep now swap after? ] unit-test
 [ t ] [ now 50 milliseconds sleep now 50 milliseconds sleep now swapd between? ] unit-test
+
+[ 4+1/6 ] [ 100 semimonthly ] unit-test

basis/calendar/calendar.factor

@@ -89,6 +89,13 @@ PRIVATE>
 : minutes-per-year ( -- ratio ) 5259492/10 ; inline
 : seconds-per-year ( -- integer ) 31556952 ; inline
 
+: monthly ( x -- y ) 12 / ; inline
+: semimonthly ( x -- y ) 24 / ; inline
+: biweekly ( x -- y ) 26 / ; inline
+: weekly ( x -- y ) 52 / ; inline
+: daily-360 ( x -- y ) 360 / ; inline
+: daily-365 ( x -- y ) 365 / ; inline
+
 :: julian-day-number ( year month day -- n )
     #! Returns a composite date number
     #! Not valid before year -4800
@@ -173,7 +180,7 @@ M: real +year ( timestamp n -- timestamp )
     12 /rem dup zero? [ drop 1- 12 ] when swap ; inline
 
 M: integer +month ( timestamp n -- timestamp )
-    [ over month>> + months/years >r >>month r> +year ] unless-zero ;
+    [ over month>> + months/years [ >>month ] dip +year ] unless-zero ;
 
 M: real +month ( timestamp n -- timestamp )
     [ float>whole-part swapd average-month * +day swap +month ] unless-zero ;
@@ -181,7 +188,7 @@ M: real +month ( timestamp n -- timestamp )
 M: integer +day ( timestamp n -- timestamp )
     [
         over >date< julian-day-number + julian-day-number>date
-        >r >r >>year r> >>month r> >>day
+        [ >>year ] [ >>month ] [ >>day ] tri*
     ] unless-zero ;
 
 M: real +day ( timestamp n -- timestamp )
@@ -191,7 +198,7 @@ M: real +day ( timestamp n -- timestamp )
     24 /rem swap ;
 
 M: integer +hour ( timestamp n -- timestamp )
-    [ over hour>> + hours/days >r >>hour r> +day ] unless-zero ;
+    [ over hour>> + hours/days [ >>hour ] dip +day ] unless-zero ;
 
 M: real +hour ( timestamp n -- timestamp )
     float>whole-part swapd 60 * +minute swap +hour ;
@@ -200,7 +207,7 @@ M: real +hour ( timestamp n -- timestamp )
     60 /rem swap ;
 
 M: integer +minute ( timestamp n -- timestamp )
-    [ over minute>> + minutes/hours >r >>minute r> +hour ] unless-zero ;
+    [ over minute>> + minutes/hours [ >>minute ] dip +hour ] unless-zero ;
 
 M: real +minute ( timestamp n -- timestamp )
     [ float>whole-part swapd 60 * +second swap +minute ] unless-zero ;
@@ -209,7 +216,7 @@ M: real +minute ( timestamp n -- timestamp )
     60 /rem swap >integer ;
 
 M: number +second ( timestamp n -- timestamp )
-    [ over second>> + seconds/minutes >r >>second r> +minute ] unless-zero ;
+    [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
 
 : (time+)
     [ second>> +second ] keep
@@ -226,7 +233,7 @@ PRIVATE>
 GENERIC# time+ 1 ( time1 time2 -- time3 )
 
 M: timestamp time+
-    >r clone r> (time+) drop ;
+    [ clone ] dip (time+) drop ;
 
 M: duration time+
     dup timestamp? [
@@ -284,7 +291,7 @@ M: timestamp <=> ( ts1 ts2 -- n )
 : (time-) ( timestamp timestamp -- n )
     [ >gmt ] bi@
     [ [ >date< julian-day-number ] bi@ - 86400 * ] 2keep
-    [ >time< >r >r 3600 * r> 60 * r> + + ] bi@ - + ;
+    [ >time< [ [ 3600 * ] [ 60 * ] bi* ] dip + + ] bi@ - + ;
 
 M: timestamp time-
     #! Exact calendar-time difference
@@ -320,13 +327,13 @@ M: duration time-
     1970 1 1 0 0 0 instant <timestamp> ;
 
 : millis>timestamp ( x -- timestamp )
-    >r unix-1970 r> milliseconds time+ ;
+    [ unix-1970 ] dip milliseconds time+ ;
 
 : timestamp>millis ( timestamp -- n )
     unix-1970 (time-) 1000 * >integer ;
 
 : micros>timestamp ( x -- timestamp )
-    >r unix-1970 r> microseconds time+ ;
+    [ unix-1970 ] dip microseconds time+ ;
 
 : timestamp>micros ( timestamp -- n )
     unix-1970 (time-) 1000000 * >integer ;
@@ -343,10 +350,11 @@ M: duration time-
     #! Zeller Congruence
     #! http://web.textfiles.com/computers/formulas.txt
     #! good for any date since October 15, 1582
-    >r dup 2 <= [ 12 + >r 1- r> ] when
+    [
-    >r dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + r>
+        dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ 1+ 3 * 5 /i + ] keep 2 * + r>
+        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
-    1+ + 7 mod ;
+        [ 1+ 3 * 5 /i + ] keep 2 * +
+    ] dip 1+ + 7 mod ;
 
 GENERIC: days-in-year ( obj -- n )
 

basis/checksums/openssl/openssl.factor

@@ -28,7 +28,7 @@ M: evp-md-context dispose
     handle>> EVP_MD_CTX_cleanup drop ;
 
 : with-evp-md-context ( quot -- )
-    maybe-init-ssl >r <evp-md-context> r> with-disposal ; inline
+    maybe-init-ssl [ <evp-md-context> ] dip with-disposal ; inline
 
 : digest-named ( name -- md )
     dup EVP_get_digestbyname

basis/checksums/sha1/sha1.factor

@@ -41,9 +41,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
 : sha1-f ( B C D t -- f_tbcd )
     20 /i
     {   
-        { 0 [ >r over bitnot r> bitand >r bitand r> bitor ] }
+        { 0 [ [ over bitnot ] dip bitand [ bitand ] dip bitor ] }
         { 1 [ bitxor bitxor ] }
-        { 2 [ 2dup bitand >r pick bitand >r bitand r> r> bitor bitor ] }
+        { 2 [ 2dup bitand [ pick bitand [ bitand ] dip ] dip bitor bitor ] }
         { 3 [ bitxor bitxor ] }
     } case ;
 

basis/checksums/sha2/sha2.factor

@@ -59,7 +59,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ 15 - swap nth s0-256 ] 2keep
     [ 7 - swap nth ] 2keep
     [ 2 - swap nth s1-256 ] 2keep
-    >r >r + + w+ r> r> swap set-nth ; inline
+    [ + + w+ ] 2dip swap set-nth ; inline
 
 : prepare-message-schedule ( seq -- w-seq )
     word-size get group [ be> ] map block-size get 0 pad-right
@@ -71,7 +71,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ bitxor bitand ] keep bitxor ;
 
 : maj ( x y z -- x' )
-    >r [ bitand ] 2keep bitor r> bitand bitor ;
+    [ [ bitand ] 2keep bitor ] dip bitand bitor ;
 
 : S0-256 ( x -- x' )
     [ -2 bitroll-32 ] keep
@@ -83,7 +83,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ -11 bitroll-32 ] keep
     -25 bitroll-32 bitxor bitxor ; inline
 
-: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
+: slice3 ( n seq -- a b c ) [ dup 3 + ] dip <slice> first3 ; inline
 
 : T1 ( W n -- T1 )
     [ swap nth ] keep
@@ -105,7 +105,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     d c pick exchange
     c b pick exchange
     b a pick exchange
-    >r w+ a r> set-nth ;
+    [ w+ a ] dip set-nth ;
 
 : process-chunk ( M -- )
     H get clone vars set
@@ -118,7 +118,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
 
 : preprocess-plaintext ( string big-endian? -- padded-string )
     #! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
-    >r >sbuf r> over [
+    [ >sbuf ] dip over [
         HEX: 80 ,
         dup length HEX: 3f bitand
         calculate-pad-length 0 <string> %

basis/db/db.factor

@@ -48,7 +48,7 @@ GENERIC: more-rows? ( result-set -- ? )
 : new-result-set ( query handle class -- result-set )
     new
         swap >>handle
-        >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
+        [ [ sql>> ] [ in-params>> ] [ out-params>> ] tri ] dip
         swap >>out-params
         swap >>in-params
         swap >>sql ;

basis/db/postgresql/lib/lib.factor

@@ -75,7 +75,7 @@ M: postgresql-result-null summary ( obj -- str )
 : param-values ( statement -- seq seq2 )
     [ bind-params>> ] [ in-params>> ] bi
     [
-        >r value>> r> type>> {
+        [ value>> ] [ type>> ] bi* {
             { FACTOR-BLOB [
                 dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
             ] }
@@ -98,7 +98,7 @@ M: postgresql-result-null summary ( obj -- str )
 
 : do-postgresql-bound-statement ( statement -- res )
     [
-        >r db get handle>> r>
+        [ db get handle>> ] dip
         {
             [ sql>> ]
             [ bind-params>> length ]
@@ -116,7 +116,7 @@ M: postgresql-result-null summary ( obj -- str )
 
 : pq-get-string ( handle row column -- obj )
     3dup PQgetvalue utf8 alien>string
-    dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+    dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
 
 : pq-get-number ( handle row column -- obj )
     pq-get-string dup [ string>number ] when ;

basis/db/queries/queries.factor

@@ -95,7 +95,7 @@ M: random-id-generator eval-generator ( singleton -- obj )
         3drop
     ] [
         pick column-name>> 0%
-        >r first2 r> interval-comparison 0%
+        [ first2 ] dip interval-comparison 0%
         bind#
     ] if ;
 
@@ -201,7 +201,7 @@ M: db <count-statement> ( query -- statement )
 
 : create-index ( index-name table-name columns -- )
     [
-        >r >r "create index " % % r> " on " % % r> "(" %
+        [ [ "create index " % % ] dip " on " % % ] 2dip "(" %
         "," join % ")" %
     ] "" make sql-command ;
 

basis/help/lint/summary.txt

@@ -0,0 +1 @@
+Help lint tool

basis/mime/multipart/multipart.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators io kernel locals math multiline
-sequences splitting prettyprint ;
+sequences splitting prettyprint namespaces http.parsers
+ascii assocs unicode.case io.files.unique io.files io.encodings.binary
+byte-arrays io.encodings make fry ;
 IN: mime.multipart
 
 TUPLE: multipart-stream stream n leftover separator ;
@@ -27,37 +29,77 @@ TUPLE: multipart-stream stream n leftover separator ;
 : multipart-split ( bytes separator -- before after seq=? )
     2dup sequence= [ 2drop f f t ] [ split1 f ] if ;
 
-:: multipart-step-found ( bytes stream quot -- ? )
+:: multipart-step-found ( bytes stream quot: ( bytes -- ) -- ? )
-    bytes [
+    bytes [ quot unless-empty ]
-        quot unless-empty
+    [ stream (>>leftover) quot unless-empty ] if-empty f ; inline
-    ] [
-        stream (>>leftover)
-        quot unless-empty
-    ] if-empty f quot call f ;
 
-:: multipart-step-not-found ( stream end-stream? separator quot -- ? )
+:: multipart-step-not-found ( bytes stream end-stream? separator quot: ( bytes -- ) -- ? )
-    end-stream? [
+    bytes end-stream? [
         quot unless-empty f
     ] [
         separator length 1- ?cut* stream (>>leftover)
         quot unless-empty t
-    ] if ;
+    ] if ; inline
 
 :: multipart-step ( stream bytes end-stream? separator quot: ( bytes -- ) -- ? end-stream? )
     #! return t to loop again
     bytes separator multipart-split
-    [ 2drop f quot call f ]
+    [ 2drop f ]
     [
         [ stream quot multipart-step-found ]
         [ stream end-stream? separator quot multipart-step-not-found ] if*
-    ] if stream leftover>> end-stream? not or ;
+    ] if stream leftover>> end-stream? not or >boolean ;
+
+
+:: multipart-step-loop ( stream quot1: ( bytes -- ) -- ? )
+    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+    swap [ drop stream quot1 multipart-step-loop ] when ; inline recursive
+
+SYMBOL: header
+SYMBOL: parsed-header
+SYMBOL: magic-separator
+
+: trim-blanks ( str -- str' ) [ blank? ] trim ;
+
+: trim-quotes ( str -- str' )
+    [ [ CHAR: " = ] [ CHAR: ' = ] bi or ] trim ;
+
+: parse-content-disposition ( str -- content-disposition hash )
+    ";" split [ first ] [ rest-slice ] bi [ "=" split ] map
+    [ [ trim-blanks ] [ trim-quotes ] bi* ] H{ } assoc-map-as ;
+
+: parse-multipart-header ( string -- headers )
+    "\r\n" split harvest
+    [ parse-header-line first2 ] H{ } map>assoc ;
+
+ERROR: expected-file ;
+
+TUPLE: uploaded-file path filename name ;
+
+: (parse-multipart) ( stream -- ? )
+    "\r\n\r\n" >>separator
+    header off
+    dup [ header [ prepend ] change ] multipart-step-loop drop
+    header get dup magic-separator get [ length ] bi@ < [
+        2drop f
+    ] [
+        parse-multipart-header
+        parsed-header set
+        "\r\n" magic-separator get append >>separator
+        "factor-upload" "httpd" make-unique-file tuck
+        binary [ [ write ] multipart-step-loop ] with-file-writer swap
+        "content-disposition" parsed-header get at parse-content-disposition
+        nip [ "filename" swap at ] [ "name" swap at ] bi
+        uploaded-file boa ,
+    ] if ;
 
 PRIVATE>
 
-:: multipart-step-loop ( stream quot1: ( bytes -- ) quot2: ( -- ) -- ? )
+: parse-multipart ( stream -- array )
-    stream dup [ read-n ] [ separator>> ] bi quot1 multipart-step
+    [
-    swap [ drop stream quot1 quot2 multipart-step-loop ] quot2 if ;
+        "\r\n" <multipart-stream>
-
+        magic-separator off
-: multipart-loop-all ( stream quot1: ( bytes -- ) quot2: ( -- ) -- )
+        dup [ magic-separator [ prepend ] change ]
-    3dup multipart-step-loop
+            multipart-step-loop drop
-    [ multipart-loop-all ] [ 3drop ] if ;
+        '[ [ _ (parse-multipart) ] loop ] { } make
+    ] with-scope ;

basis/tools/hexdump/summary.txt

@@ -1 +1 @@
-Prints formatted hex dump of an arbitrary sequence
+Prints the formatted hex dump of a byte-array

extra/asn1/asn1.factor

@@ -189,11 +189,11 @@ M: string >ber ( str -- byte-array )
     >byte-array append ;
 
 : >ber-application-string ( n str -- byte-array )
-    >r HEX: 40 + set-tag r> >ber ;
+    [ HEX: 40 + set-tag ] dip >ber ;
 
 GENERIC: >ber-contextspecific ( n obj -- byte-array )
 M: string >ber-contextspecific ( n str -- byte-array )
-    >r HEX: 80 + set-tag r> >ber ;
+    [ HEX: 80 + set-tag ] dip >ber ;
 
 ! =========================================================
 ! Array

extra/assocs/lib/lib.factor

@@ -10,10 +10,10 @@ IN: assocs.lib
     dupd at [ nip ] when* ;
 
 : replace-at ( assoc value key -- assoc )
-    >r >r dup r> 1vector r> rot set-at ;
+    [ dupd 1vector ] dip rot set-at ;
 
 : peek-at* ( assoc key -- obj ? )
-    swap at* dup [ >r peek r> ] when ;
+    swap at* dup [ [ peek ] dip ] when ;
 
 : peek-at ( assoc key -- obj )
     peek-at* drop ;
@@ -27,7 +27,7 @@ IN: assocs.lib
 : insert ( value variable -- ) namespace push-at ;
 
 : generate-key ( assoc -- str )
-    >r 32 random-bits >hex r>
+    [ 32 random-bits >hex ] dip
     2dup key? [ nip generate-key ] [ drop ] if ;
 
 : set-at-unique ( value assoc -- key )

extra/combinators/lib/lib.factor

@@ -31,7 +31,7 @@ IN: combinators.lib
 ! Generalized versions of core combinators
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: quad ( x p q r s -- ) >r >r >r keep r> keep r> keep r> call ; inline
+: quad ( x p q r s -- ) [ keep ] 3dip [ keep ] 2dip [ keep ] dip call ; inline
 
 : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline
 
@@ -123,10 +123,10 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
     >r pick >r with r> r> swapd with ;
 
 : or? ( obj quot1 quot2 -- ? )
-    >r keep r> rot [ 2nip ] [ call ] if* ; inline
+    [ keep ] dip rot [ 2nip ] [ call ] if* ; inline
 
 : and? ( obj quot1 quot2 -- ? )
-    >r keep r> rot [ call ] [ 2drop f ] if ; inline
+    [ keep ] dip rot [ call ] [ 2drop f ] if ; inline
 
 MACRO: multikeep ( word out-indexes -- ... )
     [
@@ -139,7 +139,7 @@ MACRO: multikeep ( word out-indexes -- ... )
     [ drop ] rot compose attempt-all ; inline
 
 : do-while ( pred body tail -- )
-    >r tuck 2slip r> while ; inline
+    [ tuck 2slip ] dip while ; inline
 
 : generate ( generator predicate -- obj )
     [ dup ] swap [ dup [ nip ] unless not ] 3compose
@@ -147,7 +147,7 @@ MACRO: multikeep ( word out-indexes -- ... )
 
 MACRO: predicates ( seq -- quot/f )
     dup [ 1quotation [ drop ] prepend ] map
-    >r [ [ dup ] prepend ] map r> zip [ drop f ] suffix
+    [ [ [ dup ] prepend ] map ] dip zip [ drop f ] suffix
     [ cond ] curry ;
 
 : %chance ( quot n -- ) 100 random > swap when ; inline

extra/html/parser/parser.factor

@@ -26,7 +26,7 @@ SYMBOL: tagstack
         swap >>name ;
 
 : make-tag ( string attribs -- tag )
-    >r [ closing-tag? ] keep "/" trim1 r> rot <tag> ;
+    [ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
 
 : make-text-tag ( string -- tag )
     tag new

extra/money/money-tests.factor

@@ -12,10 +12,14 @@ IN: money.tests
 [ 1/10 ] [ DECIMAL: .1 ] unit-test
 [ 1/10 ] [ DECIMAL: 0.1 ] unit-test
 [ 1/10 ] [ DECIMAL: 00.10 ] unit-test
-
+[ 23 ] [ DECIMAL: 23 ] unit-test
-
+[ -23 ] [ DECIMAL: -23 ] unit-test
+[ -23-1/100 ] [ DECIMAL: -23.01 ] unit-test
 
 [ "DECIMAL: ." eval ] must-fail
 [ "DECIMAL: f" eval ] must-fail
 [ "DECIMAL: 0.f" eval ] must-fail
 [ "DECIMAL: f.0" eval ] must-fail
+
+[ "$100.00" ] [ DECIMAL: 100.0 money>string ] unit-test
+[ "$0.00" ] [ DECIMAL: 0.0 money>string ] unit-test

extra/money/money.factor

@@ -3,28 +3,31 @@ namespaces make sequences splitting grouping combinators
 continuations ;
 IN: money
 
+SYMBOL: currency-token
+CHAR: $ \ currency-token set-global
+
 : dollars/cents ( dollars -- dollars cents )
     100 * 100 /mod round ;
 
+: (money>string) ( dollars cents -- string )
+    [ number>string ] bi@
+    [ <reversed> 3 group "," join <reversed> ]
+    [ 2 CHAR: 0 pad-left ] bi* "." swap 3append ;
+
 : money>string ( object -- string )
-    dollars/cents [
+    dollars/cents (money>string) currency-token get prefix ;
-        "$" %
-        swap number>string
-        <reversed> 3 group "," join <reversed> %
-        "." % number>string 2 CHAR: 0 pad-left %
-    ] "" make ;
 
-: money. ( object -- )
+: money. ( object -- ) money>string print ;
-    money>string print ;
 
-ERROR: not-a-decimal x ;
+ERROR: not-an-integer x ;
 
 : parse-decimal ( str -- ratio )
     "." split1
-    >r dup "-" head? [ drop t "0" ] [ f swap ] if r>
+    [ "-" ?head swap ] dip
     [ [ "0" ] when-empty ] bi@
-    dup length
+    [
-    >r [ dup string>number [ nip ] [ not-a-decimal ] if* ] bi@ r>
+        [ dup string>number [ nip ] [ not-an-integer ] if* ] bi@
+    ] keep length
     10 swap ^ / + swap [ neg ] when ;
 
 : DECIMAL:

extra/taxes/usa/usa-tests.factor

@@ -1,6 +1,6 @@
 USING: kernel money tools.test
 taxes.usa taxes.usa.federal taxes.usa.mn
-taxes.utils taxes.usa.w4 usa-cities ;
+calendar taxes.usa.w4 usa-cities ;
 IN: taxes.usa.tests
 
 [

extra/taxes/utils/utils.factor

@@ -1,10 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: math ;
-IN: taxes.utils
-
-: monthly ( x -- y ) 12 / ;
-: semimonthly ( x -- y ) 24 / ;
-: biweekly ( x -- y ) 26 / ;
-: weekly ( x -- y ) 52 / ;
-: daily ( x -- y ) 360 / ;