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

basis/alien/c-types/c-types.factor

@@ -52,7 +52,7 @@ GENERIC: c-type ( name -- type ) foldable
 
 : parse-array-type ( name -- array )
     "[" split unclip
-    >r [ "]" ?tail drop string>number ] map r> prefix ;
+    [ [ "]" ?tail drop string>number ] map ] dip prefix ;
 
 M: string c-type ( name -- type )
     CHAR: ] over member? [
@@ -215,13 +215,13 @@ M: byte-array byte-length length ;
     ] [ ] make define-inline ;
 
 : nth-word ( name vocab -- word )
-    >r "-nth" append r> create ;
+    [ "-nth" append ] dip create ;
 
 : define-nth ( name vocab -- )
     dupd nth-word swap dup c-getter (define-nth) ;
 
 : set-nth-word ( name vocab -- word )
-    >r "set-" swap "-nth" 3append r> create ;
+    [ "set-" swap "-nth" 3append ] dip create ;
 
 : define-set-nth ( name vocab -- )
     dupd set-nth-word swap dup c-setter (define-nth) ;
@@ -229,7 +229,7 @@ M: byte-array byte-length length ;
 : typedef ( old new -- ) c-types get set-at ;
 
 : define-c-type ( type name vocab -- )
-    >r tuck typedef r> [ define-nth ] 2keep define-set-nth ;
+    [ tuck typedef ] dip [ define-nth ] 2keep define-set-nth ;
 
 TUPLE: long-long-type < c-type ;
 
@@ -249,12 +249,12 @@ M: long-long-type box-return ( type -- )
     f swap box-parameter ;
 
 : define-deref ( name vocab -- )
-    >r dup CHAR: * prefix r> create
+    [ dup CHAR: * prefix ] dip create
     swap c-getter 0 prefix define-inline ;
 
 : define-out ( name vocab -- )
     over [ <c-object> tuck 0 ] over c-setter append swap
-    >r >r constructor-word r> r> prefix define-inline ;
+    [ constructor-word ] 2dip prefix define-inline ;
 
 : c-bool> ( int -- ? )
     zero? not ;
@@ -267,7 +267,7 @@ M: long-long-type box-return ( type -- )
     dupd set-nth-word [ >c-array ] 2curry ;
 
 : to-array-word ( name vocab -- word )
-    >r ">c-" swap "-array" 3append r> create ;
+    [ ">c-" swap "-array" 3append ] dip create ;
 
 : define-to-array ( type vocab -- )
     [ to-array-word ] 2keep >c-array-quot
@@ -281,7 +281,7 @@ M: long-long-type box-return ( type -- )
     ] [ ] make ;
 
 : from-array-word ( name vocab -- word )
-    >r "c-" swap "-array>" 3append r> create ;
+    [ "c-" swap "-array>" 3append ] dip create ;
 
 : define-from-array ( type vocab -- )
     [ from-array-word ] 2keep c-array>quot
@@ -299,11 +299,13 @@ M: long-long-type box-return ( type -- )
 
 : expand-constants ( c-type -- c-type' )
     dup array? [
-        unclip >r [
+        unclip [
-            dup word? [
+            [
-                def>> { } swap with-datastack first
+                dup word? [
-            ] when
+                    def>> { } swap with-datastack first
-        ] map r> prefix
+                ] when
+            ] map
+        ] dip prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )

basis/alien/strings/strings.factor

@@ -9,7 +9,7 @@ IN: alien.strings
 GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
 
 M: c-ptr alien>string
-    >r <memory-stream> r> <decoder>
+    [ <memory-stream> ] [ <decoder> ] bi*
     "\0" swap stream-read-until drop ;
 
 M: f alien>string

basis/alien/structs/fields/fields.factor

@@ -29,10 +29,10 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
     writer>> swap "writing" set-word-prop ;
 
 : reader-word ( class name vocab -- word )
-    >r >r "-" r> 3append r> create ;
+    [ "-" swap 3append ] dip create ;
 
 : writer-word ( class name vocab -- word )
-    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+    [ [ swap "set-" % % "-" % % ] "" make ] dip create ;
 
 : <field-spec> ( struct-name vocab type field-name -- spec )
     field-spec new

basis/alien/structs/structs.factor

@@ -39,7 +39,7 @@ M: struct-type stack-size
 : c-struct? ( type -- ? ) (c-type) struct-type? ;
 
 : (define-struct) ( name vocab size align fields -- )
-    >r [ align ] keep r>
+    [ [ align ] keep ] dip
     struct-type boa
     -rot define-c-type ;
 
@@ -50,11 +50,11 @@ M: struct-type stack-size
     [ c-type-align ] map supremum ;
 
 : define-struct ( name vocab fields -- )
-    pick >r
+    pick [
-    [ struct-offsets ] keep
+        [ struct-offsets ] keep
-    [ [ type>> ] map compute-struct-align ] keep
+        [ [ type>> ] map compute-struct-align ] keep
-    [ (define-struct) ] keep
+        [ (define-struct) ] keep
-    r> [ swap define-field ] curry each ;
+    ] dip [ swap define-field ] curry each ;
 
 : define-union ( name vocab members -- )
     [ expand-constants ] map

basis/alien/syntax/syntax.factor

@@ -17,22 +17,13 @@ IN: alien.syntax
     [ alien-invoke ] 2curry 2curry ;
 
 : define-function ( return library function parameters -- )
-    >r pick r> parse-arglist
+    [ pick ] dip parse-arglist
     pick create-in dup reset-generic
-    >r >r function-quot r> r> 
+    [ function-quot ] 2dip
     -rot define-declared ;
 
 PRIVATE>
 
-: indirect-quot ( function-ptr-quot return types abi -- quot )
-    [ alien-indirect ] 3curry compose ;
-
-: define-indirect ( abi return function-ptr-quot function-name parameters -- )
-    >r pick r> parse-arglist
-    rot create-in dup reset-generic
-    >r >r swapd roll indirect-quot r> r>
-    -rot define-declared ;
-
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
 
 : ALIEN: scan string>number <alien> parsed ; parsing
@@ -55,7 +46,7 @@ PRIVATE>
 : C-STRUCT:
     scan in get
     parse-definition
-    >r 2dup r> define-struct-early
+    [ 2dup ] dip define-struct-early
     define-struct ; parsing
 
 : C-UNION:
@@ -64,7 +55,7 @@ PRIVATE>
 : C-ENUM:
     ";" parse-tokens
     dup length
-    [ >r create-in r> 1quotation define ] 2each ;
+    [ [ create-in ] dip 1quotation define ] 2each ;
     parsing
 
 M: alien pprint*

basis/bit-vectors/bit-vectors-tests.factor

@@ -4,7 +4,7 @@ USING: tools.test bit-vectors vectors sequences kernel math ;
 [ 0 ] [ 123 <bit-vector> length ] unit-test
 
 : do-it
-    1234 swap [ >r even? r> push ] curry each ;
+    1234 swap [ [ even? ] dip push ] curry each ;
 
 [ t ] [
     3 <bit-vector> dup do-it

basis/bootstrap/image/image.factor

@@ -72,7 +72,7 @@ SYMBOL: objects
 : put-object ( n obj -- ) (objects) set-at ;
 
 : cache-object ( obj quot -- value )
-    >r (objects) r> [ obj>> ] prepose cache ; inline
+    [ (objects) ] dip [ obj>> ] prepose cache ; inline
 
 ! Constants
 
@@ -97,10 +97,10 @@ SYMBOL: sub-primitives
     { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
 
 : jit-define ( quot rc rt offset name -- )
-    >r make-jit r> set ; inline
+    [ make-jit ] dip set ; inline
 
 : define-sub-primitive ( quot rc rt offset word -- )
-    >r make-jit r> sub-primitives get set-at ;
+    [ make-jit ] dip sub-primitives get set-at ;
 
 ! The image being constructed; a vector of word-size integers
 SYMBOL: image
@@ -205,7 +205,7 @@ SYMBOL: undefined-quot
 : emit-fixnum ( n -- ) tag-fixnum emit ;
 
 : emit-object ( header tag quot -- addr )
-    swap here-as >r swap tag-fixnum emit call align-here r> ;
+    swap here-as [ swap tag-fixnum emit call align-here ] dip ;
     inline
 
 ! Write an object to the image.

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/calendar/format/format.factor

@@ -138,11 +138,11 @@ M: timestamp year. ( timestamp -- )
 
 : read-rfc3339-gmt-offset ( ch -- dt )
     dup CHAR: Z = [ drop instant ] [
-        >r
+        [
-        read-00 hours
+            read-00 hours
-        read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
+            read1 { { CHAR: : [ read-00 ] } { f [ 0 ] } } case minutes
-        time+
+            time+
-        r> signed-gmt-offset
+        ] dip signed-gmt-offset
     ] if ;
 
 : read-ymd ( -- y m d )
@@ -152,8 +152,9 @@ M: timestamp year. ( timestamp -- )
     read-00 ":" expect read-00 ":" expect read-00 ;
 
 : read-rfc3339-seconds ( s -- s' ch )
-    "+-Z" read-until >r
+    "+-Z" read-until [
-    [ string>number ] [ length 10 swap ^ ] bi / + r> ;
+        [ string>number ] [ length 10 swap ^ ] bi / +
+    ] dip ;
 
 : (rfc3339>timestamp) ( -- timestamp )
     read-ymd
@@ -181,9 +182,9 @@ ERROR: invalid-timestamp-format ;
 
 : parse-rfc822-gmt-offset ( string -- dt )
     dup "GMT" = [ drop instant ] [
-        unclip >r
+        unclip [ 
-        2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
+            2 cut [ string>number ] bi@ [ hours ] [ minutes ] bi* time+
-        r> signed-gmt-offset
+        ] dip signed-gmt-offset
     ] if ;
 
 : (rfc822>timestamp) ( -- timestamp )

basis/channels/remote/remote.factor

@@ -14,7 +14,7 @@ IN: channels.remote
 PRIVATE>
 
 : publish ( channel -- id )
-    256 random-bits dup >r remote-channels set-at r> ;
+    256 random-bits dup [ remote-channels set-at ] dip ;
 
 : get-channel ( id -- channel )
     remote-channels at ;

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/cocoa/application/application.factor

@@ -40,12 +40,13 @@ FUNCTION: void NSBeep ( ) ;
     dup next-event [ -> sendEvent: t ] [ drop f ] if* ;
 
 : add-observer ( observer selector name object -- )
-    >r >r >r >r NSNotificationCenter -> defaultCenter
+    [
-    r> r> sel_registerName
+        [ NSNotificationCenter -> defaultCenter ] 2dip
-    r> r> -> addObserver:selector:name:object: ;
+        sel_registerName
+    ] 2dip -> addObserver:selector:name:object: ;
 
 : remove-observer ( observer -- )
-    >r NSNotificationCenter -> defaultCenter r>
+    [ NSNotificationCenter -> defaultCenter ] dip
     -> removeObserver: ;
 
 : finish-launching ( -- ) NSApp -> finishLaunching ;

basis/cocoa/messages/messages.factor

@@ -5,7 +5,7 @@ combinators compiler compiler.alien kernel math namespaces make
 parser prettyprint prettyprint.sections quotations sequences
 strings words cocoa.runtime io macros memoize debugger
 io.encodings.ascii effects libc libc.private parser lexer init
-core-foundation fry ;
+core-foundation fry generalizations ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -27,7 +27,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
 
 : cache-stub ( method function hash -- )
     [
-        over get [ 2drop ] [ over >r sender-stub r> set ] if
+        over get [ 2drop ] [ over [ sender-stub ] dip set ] if
     ] bind ;
 
 : cache-stubs ( method -- )
@@ -37,7 +37,7 @@ super-message-senders global [ H{ } assoc-like ] change-at
 
 : <super> ( receiver -- super )
     "objc-super" <c-object> [
-        >r dup object_getClass class_getSuperclass r>
+        [ dup object_getClass class_getSuperclass ] dip
         set-objc-super-class
     ] keep
     [ set-objc-super-receiver ] keep ;
@@ -62,23 +62,18 @@ objc-methods global [ H{ } assoc-like ] change-at
     dup objc-methods get at
     [ ] [ "No such method: " prepend throw ] ?if ;
 
-: make-dip ( quot n -- quot' )
-    dup
-    \ >r <repetition> >quotation -rot
-    \ r> <repetition> >quotation 3append ;
-
 MEMO: make-prepare-send ( selector method super? -- quot )
     [
         [ \ <super> , ] when
         swap <selector> , \ selector ,
     ] [ ] make
-    swap second length 2 - make-dip ;
+    swap second length 2 - '[ _ _ ndip ] ;
 
 MACRO: (send) ( selector super? -- quot )
-    >r dup lookup-method r>
+    [ dup lookup-method ] dip
     [ make-prepare-send ] 2keep
     super-message-senders message-senders ? get at
-    [ slip execute ] 2curry ;
+    '[ _ call _ execute ] ;
 
 : send ( receiver args... selector -- return... ) f (send) ; inline
 
@@ -172,7 +167,7 @@ assoc-union alien>objc-types set-global
     ] unless ;
 
 : (parse-objc-type) ( i string -- ctype )
-    2dup nth >r >r 1+ r> r> {
+    [ [ 1+ ] dip ] [ nth ] 2bi {
         { [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
         { [ dup CHAR: ^ = ] [ 3drop "void*" ] }
         { [ dup CHAR: { = ] [ drop objc-struct-type ] }
@@ -223,22 +218,23 @@ assoc-union alien>objc-types set-global
 : class-exists? ( string -- class ) objc_getClass >boolean ;
 
 : unless-defined ( class quot -- )
-    >r class-exists? r> unless ; inline
+    [ class-exists? ] dip unless ; inline
 
 : define-objc-class-word ( name quot -- )
     [
         over , , \ unless-defined , dup , \ objc-class ,
-    ] [ ] make >r "cocoa.classes" create r>
+    ] [ ] make [ "cocoa.classes" create ] dip
     (( -- class )) define-declared ;
 
 : import-objc-class ( name quot -- )
     2dup unless-defined
     dupd define-objc-class-word
-    [
+    '[
+        _
         dup
         objc-class register-objc-methods
         objc-meta-class register-objc-methods
-    ] curry try ;
+    ] try ;
 
 : root-class ( class -- root )
     dup class_getSuperclass [ root-class ] [ ] ?if ;

basis/core-foundation/core-foundation.factor

@@ -90,14 +90,14 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
 : <CFArray> ( seq -- alien )
     [ f swap length f CFArrayCreateMutable ] keep
     [ length ] keep
-    [ >r dupd r> CFArraySetValueAtIndex ] 2each ;
+    [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
 
 : <CFString> ( string -- alien )
     f swap dup length CFStringCreateWithCharacters ;
 
 : CF>string ( alien -- string )
     dup CFStringGetLength 1+ "ushort" <c-array> [
-        >r 0 over CFStringGetLength r> CFStringGetCharacters
+        [ 0 over CFStringGetLength ] dip CFStringGetCharacters
     ] keep utf16n alien>string ;
 
 : CF>string-array ( alien -- seq )
@@ -107,8 +107,8 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
     [ <CFString> ] map dup <CFArray> swap [ CFRelease ] each ;
 
 : <CFFileSystemURL> ( string dir? -- url )
-    >r <CFString> f over kCFURLPOSIXPathStyle
+    [ <CFString> f over kCFURLPOSIXPathStyle ] dip
-    r> CFURLCreateWithFileSystemPath swap CFRelease ;
+    CFURLCreateWithFileSystemPath swap CFRelease ;
 
 : <CFURL> ( string -- url )
     <CFString>

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 " % % ] dip "(" %
         "," join % ")" %
     ] "" make sql-command ;
 

basis/dlists/dlists.factor

@@ -57,11 +57,11 @@ M: dlist-node node-value obj>> ;
 : (dlist-find-node) ( dlist-node quot: ( node -- ? ) -- node/f ? )
     over [
         [ call ] 2keep rot
-        [ drop t ] [ >r next>> r> (dlist-find-node) ] if
+        [ drop t ] [ [ next>> ] dip (dlist-find-node) ] if
     ] [ 2drop f f ] if ; inline recursive
 
 : dlist-find-node ( dlist quot -- node/f ? )
-    >r front>> r> (dlist-find-node) ; inline
+    [ front>> ] dip (dlist-find-node) ; inline
 
 : dlist-each-node ( dlist quot -- )
     [ f ] compose dlist-find-node 2drop ; inline

basis/editors/editors.factor

@@ -26,8 +26,7 @@ SYMBOL: edit-hook
     require ;
 
 : edit-location ( file line -- )
-    >r (normalize-path) r>
+    [ (normalize-path) ] dip edit-hook get-global
-    edit-hook get-global
     [ call ] [ no-edit-hook edit-location ] if* ;
 
 : edit ( defspec -- )

basis/farkup/farkup.factor

@@ -167,7 +167,7 @@ stand-alone
     } cond ;
 
 : escape-link ( href text -- href-esc text-esc )
-    >r check-url escape-quoted-string r> escape-string ;
+    [ check-url escape-quoted-string ] dip escape-string ;
 
 : write-link ( href text -- )
     escape-link
@@ -185,7 +185,7 @@ stand-alone
     ] if ;
 
 : render-code ( string mode -- string' )
-    >r string-lines r>
+    [ string-lines ] dip
     [
         <pre>
             htmlize-lines

basis/float-arrays/float-arrays.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private alien.accessors sequences
 sequences.private math math.private byte-arrays accessors
-alien.c-types parser prettyprint.backend ;
+alien.c-types parser prettyprint.backend combinators ;
 IN: float-arrays
 
 TUPLE: float-array
@@ -67,6 +67,8 @@ M: float-array pprint* pprint-object ;
 ! Specializer hints
 USING: hints math.vectors arrays ;
 
+HINTS: <float-array> { 2 } { 3 } ;
+
 HINTS: vneg { array } { float-array } ;
 HINTS: v*n { array object } { float-array float } ;
 HINTS: n*v { array object } { float float-array } ;

basis/grouping/grouping.factor

@@ -11,7 +11,7 @@ TUPLE: chunking-seq { seq read-only } { n read-only } ;
 : check-groups dup 0 <= [ "Invalid group count" throw ] when ; inline
 
 : new-groups ( seq n class -- groups )
-    >r check-groups r> boa ; inline
+    [ check-groups ] dip boa ; inline
 
 GENERIC: group@ ( n groups -- from to seq )
 

basis/hash2/hash2.factor

@@ -14,25 +14,25 @@ IN: hash2
 : <hash2> ( size -- hash2 ) f <array> ;
 
 : 2= ( a b pair -- ? )
-    first2 swapd >r >r = r> r> = and ; inline
+    first2 swapd [ = ] 2bi@ and ; inline
 
 : (assoc2) ( a b alist -- {a,b,val} )
-    [ >r 2dup r> 2= ] find >r 3drop r> ; inline
+    [ 2= ] with with find nip ; inline
 
 : assoc2 ( a b alist -- value )
     (assoc2) dup [ third ] when ; inline
 
 : set-assoc2 ( value a b alist -- alist )
-    >r rot 3array r> ?push ; inline
+    [ rot 3array ] dip ?push ; inline
 
 : hash2@ ( a b hash2 -- a b bucket hash2 )
-    >r 2dup hashcode2 r> [ length mod ] keep ; inline
+    [ 2dup hashcode2 ] dip [ length mod ] keep ; inline
 
 : hash2 ( a b hash2 -- value/f )
-    hash2@ nth [ assoc2 ] [ 2drop f ] if* ;
+    hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
 
 : set-hash2 ( a b value hash2 -- )
-    >r -rot r> hash2@ [ set-assoc2 ] change-nth ;
+    [ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
 
 : alist>hash2 ( alist size -- hash2 )
-    <hash2> [ over >r first3 r> set-hash2 ] reduce ; inline
+    <hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

basis/heaps/heaps.factor

@@ -18,7 +18,7 @@ GENERIC: heap-size ( heap -- n )
 TUPLE: heap data ;
 
 : <heap> ( class -- heap )
-    >r V{ } clone r> boa ; inline
+    [ V{ } clone ] dip boa ; inline
 
 TUPLE: entry value key heap index ;
 
@@ -52,16 +52,16 @@ M: heap heap-size ( heap -- n )
     data>> nth-unsafe ; inline
 
 : up-value ( n heap -- entry )
-    >r up r> data-nth ; inline
+    [ up ] dip data-nth ; inline
 
 : left-value ( n heap -- entry )
-    >r left r> data-nth ; inline
+    [ left ] dip data-nth ; inline
 
 : right-value ( n heap -- entry )
-    >r right r> data-nth ; inline
+    [ right ] dip data-nth ; inline
 
 : data-set-nth ( entry n heap -- )
-    >r [ >>index drop ] 2keep r>
+    [ [ >>index drop ] 2keep ] dip
     data>> set-nth-unsafe ; inline
 
 : data-push ( entry heap -- n )
@@ -82,8 +82,8 @@ M: heap heap-size ( heap -- n )
     data>> first ; inline
 
 : data-exchange ( m n heap -- )
-    [ tuck data-nth >r data-nth r> ] 3keep
+    [ tuck data-nth [ data-nth ] dip ] 3keep
-    tuck >r >r data-set-nth r> r> data-set-nth ; inline
+    tuck [ data-set-nth ] 2dip data-set-nth ; inline
 
 GENERIC: heap-compare ( pair1 pair2 heap -- ? )
 
@@ -97,10 +97,10 @@ M: max-heap heap-compare (heap-compare) +lt+ eq? ;
     heap-size >= ; inline
 
 : left-bounds-check? ( m heap -- ? )
-    >r left r> heap-bounds-check? ; inline
+    [ left ] dip heap-bounds-check? ; inline
 
 : right-bounds-check? ( m heap -- ? )
-    >r right r> heap-bounds-check? ; inline
+    [ right ] dip heap-bounds-check? ; inline
 
 : continue? ( m up[m] heap -- ? )
     [ data-nth swap ] keep [ data-nth ] keep
@@ -109,7 +109,7 @@ M: max-heap heap-compare (heap-compare) +lt+ eq? ;
 DEFER: up-heap
 
 : (up-heap) ( n heap -- )
-    >r dup up r>
+    [ dup up ] dip
     3dup continue? [
         [ data-exchange ] 2keep up-heap
     ] [
@@ -121,7 +121,7 @@ DEFER: up-heap
 
 : (child) ( m heap -- n )
     2dup right-value
-    >r 2dup left-value r>
+    [ 2dup left-value ] dip
     rot heap-compare
     [ right ] [ left ] if ;
 

basis/help/lint/summary.txt

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

basis/hints/hints-docs.factor

@@ -1,10 +1,10 @@
 IN: hints
-USING: help.markup help.syntax words quotations sequences ;
+USING: help.markup help.syntax words quotations sequences kernel ;
 
 ARTICLE: "hints" "Compiler specialization hints"
 "Specialization hints help the compiler generate efficient code."
 $nl
-"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class, and inlining of generic methods can take place."
+"Specialization hints can help words which call a lot of generic words on the same object - perhaps in a loop - and in most cases, it is anticipated that this object is of a certain class, or even " { $link eq? } " to some literal. Using specialization hints, the compiler can be instructed to compile a branch at the beginning of the word; if the branch is taken, the input object has the assumed class or value, and inlining of generic methods can take place."
 $nl
 "Specialization hints are not declarations; if the inputs do not match what is specified, the word will still run, possibly slower if the compiled code cannot inline methods because of insufficient static type information."
 $nl
@@ -20,10 +20,10 @@ HELP: specialized-def
 { $description "Outputs the definition of a word after it has been split into specialized branches. This is the definition which will actually be compiled by the compiler." } ;
 
 HELP: HINTS:
-{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes" } }
+{ $values { "defspec" "a definition specifier" } { "hints..." "a list of sequences of classes or literals" } }
 { $description "Defines specialization hints for a word or a method."
 $nl
-"Each sequence of classes in the list will cause a specialized version of the word to be compiled." }
+"Each sequence in the list will cause a specialized version of the word to be compiled. Classes are tested for using their predicate, and literals are tested using " { $link eq? } "." }
 { $examples "The " { $link append } " word has a specializer for the very common case where two strings or two arrays are appended:"
 { $code "HINTS: append { string string } { array array } ;" }
 "Specializers can also be defined on methods:"

basis/hints/hints.factor

@@ -3,25 +3,34 @@
 USING: parser words definitions kernel sequences assocs arrays
 kernel.private fry combinators accessors vectors strings sbufs
 byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines ;
+math generic generic.standard generic.standard.engines classes ;
 IN: hints
 
-: (make-specializer) ( class picker -- quot )
+GENERIC: specializer-predicate ( spec -- quot )
-    swap "predicate" word-prop append ;
 
-: make-specializer ( classes -- quot )
+M: class specializer-predicate "predicate" word-prop ;
+
+M: object specializer-predicate '[ _ eq? ] ;
+
+GENERIC: specializer-declaration ( spec -- class )
+
+M: class specializer-declaration ;
+
+M: object specializer-declaration class ;
+
+: make-specializer ( specs -- quot )
     dup length <reversed>
     [ (picker) 2array ] 2map
     [ drop object eq? not ] assoc-filter
     [ [ t ] ] [
-        [ (make-specializer) ] { } assoc>map
+        [ swap specializer-predicate append ] { } assoc>map
         unclip [ swap [ f ] \ if 3array append [ ] like ] reduce
     ] if-empty ;
 
 : specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
-        '[ _ declare ] pick append
+        [ specializer-declaration ] map '[ _ declare ] pick append
     ] { } map>assoc ;
 
 : method-declaration ( method -- quot )

basis/math/partial-dispatch/partial-dispatch.factor

@@ -117,7 +117,9 @@ M: word integer-op-input-classes
     { fixnum bignum float }
     [ [ dup 3array ] [ swap method ] 2bi ] with { } map>assoc
     [ nip ] assoc-filter
-    [ def>> peek ] assoc-map % ;
+    [ def>> ] assoc-map
+    [ nip length 1 = ] assoc-filter
+    [ first ] assoc-map % ;
 
 SYMBOL: math-ops
 

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/opengl/gl/extensions/extensions.factor

@@ -1,6 +1,6 @@
-USING: alien alien.syntax combinators kernel parser sequences
+USING: alien alien.syntax alien.syntax.private combinators
-system words namespaces hashtables init math arrays assocs
+kernel parser sequences system words namespaces hashtables init
-continuations lexer ;
+math arrays assocs continuations lexer ;
 IN: opengl.gl.extensions
 
 ERROR: unknown-gl-platform ;
@@ -36,6 +36,15 @@ reset-gl-function-number-counter
         +gl-function-pointers+ get-global set-at
     ] if* ;
 
+: indirect-quot ( function-ptr-quot return types abi -- quot )
+    [ alien-indirect ] 3curry compose ;
+
+: define-indirect ( abi return function-ptr-quot function-name parameters -- )
+    [ pick ] dip parse-arglist
+    rot create-in
+    [ swapd roll indirect-quot ] 2dip
+    -rot define-declared ;
+
 : GL-FUNCTION:
     gl-function-calling-convention
     scan

basis/stack-checker/backend/backend.factor

@@ -4,7 +4,7 @@ USING: fry arrays generic io io.streams.string kernel math
 namespaces parser prettyprint sequences strings vectors words
 quotations effects classes continuations debugger assocs
 combinators compiler.errors accessors math.order definitions
-sets generic.standard.engines.tuple stack-checker.state
+sets generic.standard.engines.tuple hints stack-checker.state
 stack-checker.visitor stack-checker.errors
 stack-checker.values stack-checker.recursive-state ;
 IN: stack-checker.backend
@@ -125,7 +125,7 @@ M: object apply-object push-literal ;
     ] 2bi ; inline
 
 : infer-word-def ( word -- )
-    [ def>> ] [ add-recursive-state ] bi infer-quot ;
+    [ specialized-def ] [ add-recursive-state ] bi infer-quot ;
 
 : check->r ( -- )
     meta-r get empty? terminated? get or

basis/stack-checker/inlining/inlining.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: fry namespaces assocs kernel sequences words accessors
 definitions math math.order effects classes arrays combinators
-vectors arrays
+vectors arrays hints
 stack-checker.state
 stack-checker.errors
 stack-checker.values
@@ -17,7 +17,7 @@ IN: stack-checker.inlining
 ! having to handle recursive inline words.
 
 : infer-inline-word-def ( word label -- )
-    [ drop def>> ] [ add-inline-word ] 2bi infer-quot ;
+    [ drop specialized-def ] [ add-inline-word ] 2bi infer-quot ;
 
 TUPLE: inline-recursive < identity-tuple
 id

basis/tools/hexdump/summary.txt

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

core/math/floats/floats-tests.factor

@@ -60,3 +60,5 @@ unit-test
 [ 0 ] [ 1/0. >bignum ] unit-test
 
 [ t ] [ 64 [ 2^ 0.5 * ] map [ < ] monotonic? ] unit-test
+
+[ 5 ] [ 10.5 1.9 /i ] unit-test

core/math/floats/floats.factor

@@ -24,6 +24,7 @@ M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
 M: float /f float/f ;
+M: float /i float/f >integer ;
 M: float mod float-mod ;
 
 M: real abs dup 0 < [ neg ] when ;

core/parser/parser.factor

@@ -80,17 +80,17 @@ ERROR: no-word-error name ;
 : <no-word-error> ( name possibilities -- error restarts )
     [ drop \ no-word-error boa ] [ word-restarts ] 2bi ;
 
-SYMBOL: amended-use?
+SYMBOL: amended-use
 
 SYMBOL: auto-use?
 
 : no-word-restarted ( restart-value -- word )
     dup word? [
-        amended-use? on
         dup vocabulary>>
-        [ (use+) ] [
+        [ (use+) ]
-            "Added ``" swap "'' vocabulary to search path" 3append note.
+        [ amended-use get dup [ push ] [ 2drop ] if ]
-        ] bi
+        [ "Added ``" swap "'' vocabulary to search path" 3append note. ]
+        tri
     ] [ create-in ] if ;
 
 : no-word ( name -- newword )
@@ -232,22 +232,16 @@ SYMBOL: interactive-vocabs
 SYMBOL: print-use-hook
 
 print-use-hook global [ [ ] or ] change-at
-
+!
 : parse-fresh ( lines -- quot )
     [
-        amended-use? off
+        V{ } clone amended-use set
         parse-lines
-        amended-use? get [
+        amended-use get empty? [ print-use-hook get call ] unless
-            print-use-hook get call
-        ] when
     ] with-file-vocabs ;
 
 : parsing-file ( file -- )
-    "quiet" get [
+    "quiet" get [ drop ] [ "Loading " write print flush ] if ;
-        drop
-    ] [
-        "Loading " write print flush
-    ] if ;
 
 : filter-moved ( assoc1 assoc2 -- seq )
     swap assoc-diff [

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/benchmark/nbody/nbody.factor

@@ -11,39 +11,37 @@ IN: benchmark.nbody
 TUPLE: body
 { location float-array }
 { velocity float-array }
-{ mass float } ;
+{ mass float read-only } ;
 
-: <body> ( -- body ) body new ; inline
+: <body> ( location velocity mass -- body )
+    [ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline
 
 : <jupiter> ( -- body )
-    <body>
+    F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 }
-        F{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 } >>location
+    F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 }
-        F{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 } days-per-year v*n >>velocity
+    9.54791938424326609e-04
-        9.54791938424326609e-04 solar-mass * >>mass ;
+    <body> ;
 
 : <saturn> ( -- body )
-    <body>
+    F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 }
-        F{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 } >>location
+    F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 }
-        F{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 } days-per-year v*n >>velocity
+    2.85885980666130812e-04
-        2.85885980666130812e-04 solar-mass * >>mass ;
+    <body> ;
 
 : <uranus> ( -- body )
-    <body>
+    F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 }
-        F{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 } >>location
+    F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 }
-        F{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 } days-per-year v*n >>velocity
+    4.36624404335156298e-05
-        4.36624404335156298e-05 solar-mass * >>mass ;
+    <body> ;
 
 : <neptune> ( -- body )
-    <body>
+    F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 }
-        F{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 } >>location
+    F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 }
-        F{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 } days-per-year v*n >>velocity
+    5.15138902046611451e-05
-        5.15138902046611451e-05 solar-mass * >>mass ;
+    <body> ;
 
 : <sun> ( -- body )
-    <body>
+    F{ 0 0 0 } F{ 0 0 0 } 1 <body> ;
-        solar-mass >>mass
-        F{ 0 0 0 } >>location
-        F{ 0 0 0 } >>velocity ;
     
 : offset-momentum ( body offset -- body )
     vneg solar-mass v/n >>velocity ; inline

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/jamshred/tunnel/tunnel.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007, 2008 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
+USING: accessors arrays colors combinators float-arrays kernel
-USE: tools.walker
+locals math math.constants math.matrices math.order math.ranges
+math.vectors math.quadratic random sequences vectors jamshred.oint ;
 IN: jamshred.tunnel
 
 : n-segments ( -- n ) 5000 ; inline

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 / ;