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

basis/bootstrap/image/image.factor

@@ -23,7 +23,7 @@ IN: bootstrap.image
     os name>> cpu name>> arch ;
 
 : boot-image-name ( arch -- string )
-    "boot." swap ".image" 3append ;
+    "boot." ".image" surround ;
 
 : my-boot-image-name ( -- string )
     my-arch boot-image-name ;

basis/calendar/calendar-docs.factor

@@ -99,48 +99,6 @@ 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." }
@@ -582,8 +540,6 @@ 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" }
 ;
@@ -670,18 +626,6 @@ 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,5 +167,3 @@ 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,13 +89,6 @@ 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

basis/compiler/cfg/hats/hats.factor

@@ -39,6 +39,7 @@ IN: compiler.cfg.hats
 : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline
 : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline
 : ^^not ( src -- dst ) ^^i1 ##not ; inline
+: ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline
 : ^^bignum>integer ( src -- dst ) ^^i1 i ##bignum>integer ; inline
 : ^^integer>bignum ( src -- dst ) ^^i1 i ##integer>bignum ; inline
 : ^^add-float ( src1 src2 -- dst ) ^^d2 ##add-float ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -92,6 +92,7 @@ INSN: ##shl-imm < ##binary-imm ;
 INSN: ##shr-imm < ##binary-imm ;
 INSN: ##sar-imm < ##binary-imm ;
 INSN: ##not < ##unary ;
+INSN: ##log2 < ##unary ;
 
 ! Overflowing arithmetic
 TUPLE: ##fixnum-overflow < insn src1 src2 ;

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -53,6 +53,9 @@ IN: compiler.cfg.intrinsics.fixnum
 : emit-fixnum-bitnot ( -- )
     ds-pop ^^not tag-mask get ^^xor-imm ds-push ;
 
+: emit-fixnum-log2 ( -- )
+    ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ;
+
 : (emit-fixnum*fast) ( -- dst )
     2inputs ^^untag-fixnum ^^mul ;
 

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -19,6 +19,7 @@ QUALIFIED: slots.private
 QUALIFIED: strings.private
 QUALIFIED: classes.tuple.private
 QUALIFIED: math.private
+QUALIFIED: math.integers.private
 QUALIFIED: alien.accessors
 IN: compiler.cfg.intrinsics
 
@@ -93,6 +94,9 @@ IN: compiler.cfg.intrinsics
         alien.accessors:set-alien-double
     } [ t "intrinsic" set-word-prop ] each ;
 
+: enable-fixnum-log2 ( -- )
+    \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;
+
 : emit-intrinsic ( node word -- node/f )
     {
         { \ kernel.private:tag [ drop emit-tag iterate-next ] }
@@ -108,6 +112,7 @@ IN: compiler.cfg.intrinsics
         { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-fixnum-op iterate-next ] }
         { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast iterate-next ] }
         { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot iterate-next ] }
+        { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 iterate-next ] }
         { \ math.private:fixnum*fast [ emit-fixnum*fast iterate-next ] }
         { \ math.private:fixnum< [ cc< emit-fixnum-comparison iterate-next ] }
         { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison iterate-next ] }

basis/compiler/codegen/codegen.factor

@@ -163,6 +163,7 @@ M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ;
 M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ;
 M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ;
 M: ##not     generate-insn dst/src       %not     ;
+M: ##log2    generate-insn dst/src       %log2    ;
 
 : src1/src2 ( insn -- src1 src2 )
     [ src1>> register ] [ src2>> register ] bi ; inline

basis/compiler/tests/optimizer.factor

@@ -375,3 +375,9 @@ DEFER: loop-bbb
 : loop-ccc ( -- ) loop-bbb ;
 
 [ 0 ] [ 0 counter set loop-ccc counter get ] unit-test
+
+! Type inference issue
+[ 4 3 ] [
+    1 >bignum 2 >bignum
+    [ { bignum integer } declare [ shift ] keep 1+ ] compile-call
+] unit-test

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -1,11 +1,12 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel effects accessors math math.private math.libm
+USING: kernel effects accessors math math.private
-math.partial-dispatch math.intervals math.parser math.order
+math.integers.private math.partial-dispatch math.intervals
-layouts words sequences sequences.private arrays assocs classes
+math.parser math.order layouts words sequences sequences.private
-classes.algebra combinators generic.math splitting fry locals
+arrays assocs classes classes.algebra combinators generic.math
-classes.tuple alien.accessors classes.tuple.private slots.private
+splitting fry locals classes.tuple alien.accessors
-definitions strings.private vectors hashtables
+classes.tuple.private slots.private definitions strings.private
+vectors hashtables
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -76,14 +77,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ rational math-class-max ] dip
     ] unless ;
 
+: ensure-math-class ( class must-be -- class' )
+    [ class<= ] 2keep ? ;
+
 : number-valued ( class interval -- class' interval' )
-    [ number math-class-min ] dip ;
+    [ number ensure-math-class ] dip ;
 
 : integer-valued ( class interval -- class' interval' )
-    [ integer math-class-min ] dip ;
+    [ integer ensure-math-class ] dip ;
 
 : real-valued ( class interval -- class' interval' )
-    [ real math-class-min ] dip ;
+    [ real ensure-math-class ] dip ;
 
 : float-valued ( class interval -- class' interval' )
     over null-class? [
@@ -230,7 +234,7 @@ generic-comparison-ops [
 } [
     [
         in-d>> second value-info >literal<
-        [ power-of-2? [ 1- bitand ] f ? ] when
+        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
     ] "custom-inlining" set-word-prop
 ] each
 
@@ -247,6 +251,15 @@ generic-comparison-ops [
     ] "custom-inlining" set-word-prop
 ] each
 
+{ numerator denominator }
+[ [ drop integer <class-info> ] "outputs" set-word-prop ] each
+
+{ (log2) fixnum-log2 bignum-log2 } [
+    [
+        [ class>> ] [ interval>> interval-log2 ] bi <class/interval-info>
+    ] "outputs" set-word-prop
+] each
+
 \ string-nth [
     2drop fixnum 0 23 2^ [a,b] <class/interval-info>
 ] "outputs" set-word-prop

basis/compiler/tree/propagation/propagation-tests.factor

@@ -34,17 +34,57 @@ IN: compiler.tree.propagation.tests
 
 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
 
-[ V{ number } ] [ [ + ] final-classes ] unit-test
+! Test type propagation for math ops
+: cleanup-math-class ( obj -- class )
+    { null fixnum bignum integer ratio rational float real complex number }
+    [ class= ] with find nip ;
 
-[ V{ float } ] [ [ { float integer } declare + ] final-classes ] unit-test
+: final-math-class ( quot -- class )
+    final-classes first cleanup-math-class ;
 
-[ V{ float } ] [ [ /f ] final-classes ] unit-test
+[ number ] [ [ + ] final-math-class ] unit-test
 
-[ V{ integer } ] [ [ /i ] final-classes ] unit-test
+[ bignum ] [ [ { fixnum bignum } declare + ] final-math-class ] unit-test
 
-[ V{ integer } ] [
+[ integer ] [ [ { fixnum integer } declare + ] final-math-class ] unit-test
-    [ { integer } declare bitnot ] final-classes
+
-] unit-test
+[ bignum ] [ [ { integer bignum } declare + ] final-math-class ] unit-test
+
+[ integer ] [ [ { fixnum fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float integer } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { real float } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float real } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { ratio ratio } declare + ] final-math-class ] unit-test
+
+[ rational ] [ [ { rational ratio } declare + ] final-math-class ] unit-test
+
+[ number ] [ [ { complex complex } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ /f ] final-math-class ] unit-test
+
+[ float ] [ [ { real real } declare /f ] final-math-class ] unit-test
+
+[ integer ] [ [ /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { float float } declare /i ] final-math-class ] unit-test
+
+[ integer ] [ [ { integer } declare bitnot ] final-math-class ] unit-test
+
+[ null ] [ [ { null null } declare + ] final-math-class ] unit-test
+
+[ null ] [ [ { null fixnum } declare + ] final-math-class ] unit-test
+
+[ float ] [ [ { float fixnum } declare + ] final-math-class ] unit-test
+
+[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
+
+[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
 
 [ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test
 
@@ -66,18 +106,6 @@ IN: compiler.tree.propagation.tests
     [ { fixnum } declare 615949 * ] final-classes
 ] unit-test
 
-[ V{ null } ] [
-    [ { null null } declare + ] final-classes
-] unit-test
-
-[ V{ null } ] [
-    [ { null fixnum } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
-    [ { float fixnum } declare + ] final-classes
-] unit-test
-
 [ V{ fixnum } ] [
     [ 255 bitand >fixnum 3 bitor ] final-classes
 ] unit-test
@@ -279,14 +307,6 @@ IN: compiler.tree.propagation.tests
     ] final-classes
 ] unit-test
 
-[ V{ float } ] [
-    [ { real float } declare + ] final-classes
-] unit-test
-
-[ V{ float } ] [
-    [ { float real } declare + ] final-classes
-] unit-test
-
 [ V{ fixnum } ] [
     [ { fixnum fixnum } declare 7 bitand neg shift ] final-classes
 ] unit-test
@@ -604,6 +624,22 @@ MIXIN: empty-mixin
     [ { integer } declare 127 bitand ] final-info first interval>>
 ] unit-test
 
+[ V{ bignum } ] [
+    [ { bignum } declare dup 1- bitxor ] final-classes
+] unit-test
+
+[ V{ bignum integer } ] [
+    [ { bignum integer } declare [ shift ] keep ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare log2 ] final-classes
+] unit-test
+
+[ V{ word } ] [
+    [ { fixnum } declare log2 0 >= ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/core-foundation/core-foundation.factor

@@ -16,13 +16,17 @@ TYPEDEF: void* CFStringRef
 TYPEDEF: void* CFURLRef
 TYPEDEF: void* CFUUIDRef
 TYPEDEF: void* CFTypeRef
+TYPEDEF: void* CFFileDescriptorRef
 TYPEDEF: bool Boolean
 TYPEDEF: long CFIndex
 TYPEDEF: int SInt32
 TYPEDEF: uint UInt32
 TYPEDEF: ulong CFTypeID
+TYPEDEF: UInt32 CFOptionFlags
 TYPEDEF: double CFTimeInterval
 TYPEDEF: double CFAbsoluteTime
+TYPEDEF: int CFFileDescriptorNativeDescriptor
+TYPEDEF: void* CFFileDescriptorCallBack
 
 TYPEDEF: int CFNumberType
 : kCFNumberSInt8Type 1 ; inline
@@ -121,18 +125,35 @@ FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
     ] keep CFRelease ;
 
 GENERIC: <CFNumber> ( number -- alien )
+
 M: integer <CFNumber>
     [ f kCFNumberLongLongType ] dip <longlong> CFNumberCreate ;
+
 M: float <CFNumber>
     [ f kCFNumberDoubleType ] dip <double> CFNumberCreate ;
+
 M: t <CFNumber>
     drop f kCFNumberIntType 1 <int> CFNumberCreate ;
+
 M: f <CFNumber>
     drop f kCFNumberIntType 0 <int> CFNumberCreate ;
 
 : <CFData> ( byte-array -- alien )
     [ f ] dip dup length CFDataCreate ;
 
+FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate (
+    CFAllocatorRef allocator,
+    CFFileDescriptorNativeDescriptor fd,
+    Boolean closeOnInvalidate,
+    CFFileDescriptorCallBack callout, 
+    CFFileDescriptorContext* context
+) ;
+
+FUNCTION: void CFFileDescriptorEnableCallBacks (
+    CFFileDescriptorRef f,
+    CFOptionFlags callBackTypes
+) ;
+
 : load-framework ( name -- )
     dup <CFBundle> [
         CFBundleLoadExecutable drop
@@ -141,8 +162,11 @@ M: f <CFNumber>
     ] ?if ;
 
 TUPLE: CFRelease-destructor alien disposed ;
+
 M: CFRelease-destructor dispose* alien>> CFRelease ;
+
 : &CFRelease ( alien -- alien )
     dup f CFRelease-destructor boa &dispose drop ; inline
+
 : |CFRelease ( alien -- alien )
     dup f CFRelease-destructor boa |dispose drop ; inline

basis/core-foundation/run-loop/run-loop.factor

@@ -10,6 +10,7 @@ IN: core-foundation.run-loop
 : kCFRunLoopRunHandledSource 4 ; inline
 
 TYPEDEF: void* CFRunLoopRef
+TYPEDEF: void* CFRunLoopSourceRef
 
 FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
 FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
@@ -20,6 +21,18 @@ FUNCTION: SInt32 CFRunLoopRunInMode (
    Boolean returnAfterSourceHandled
 ) ;
 
+FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
+    CFAllocatorRef allocator,
+    CFFileDescriptorRef f,
+    CFIndex order
+) ;
+
+FUNCTION: void CFRunLoopAddSource (
+   CFRunLoopRef rl,
+   CFRunLoopSourceRef source,
+   CFStringRef mode
+) ;
+
 : CFRunLoopDefaultMode ( -- alien )
     #! Ugly, but we don't have static NSStrings
     \ CFRunLoopDefaultMode get-global dup expired? [

basis/cpu/architecture/architecture.factor

@@ -77,6 +77,7 @@ HOOK: %shl-imm cpu ( dst src1 src2 -- )
 HOOK: %shr-imm cpu ( dst src1 src2 -- )
 HOOK: %sar-imm cpu ( dst src1 src2 -- )
 HOOK: %not     cpu ( dst src -- )
+HOOK: %log2    cpu ( dst src -- )
 
 HOOK: %fixnum-add cpu ( src1 src2 -- )
 HOOK: %fixnum-add-tail cpu ( src1 src2 -- )

basis/cpu/ppc/bootstrap.factor

@@ -329,14 +329,15 @@ big-endian on
 ! Math
 [
     3 ds-reg 0 LWZ
-    4 ds-reg -4 LWZ
+    ds-reg ds-reg 4 SUBI
+    4 ds-reg 0 LWZ
     3 3 4 OR
     3 3 tag-mask get ANDI
     \ f tag-number 4 LI
     0 3 0 CMPI
     2 BNE
     1 tag-fixnum 4 LI
-    4 ds-reg 4 STWU
+    4 ds-reg 0 STW
 ] f f f \ both-fixnums? define-sub-primitive
 
 : jit-math ( insn -- )

basis/cpu/ppc/ppc.factor

@@ -37,8 +37,8 @@ M: ppc %load-immediate ( reg n -- ) swap LOAD ;
 M: ppc %load-indirect ( reg obj -- )
     [ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
 
-: %load-dlsym ( symbol dll register -- )
+M: ppc %alien-global ( register symbol dll -- )
-    0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
+    [ 0 swap LOAD32 ] 2dip rc-absolute-ppc-2/2 rel-dlsym ;
 
 : ds-reg 29 ; inline
 : rs-reg 30 ; inline
@@ -145,8 +145,8 @@ M:: ppc %string-nth ( dst src index temp -- )
         temp temp index ADD
         temp temp index ADD
         temp temp byte-array-offset LHZ
-        temp temp 8 SLWI
+        temp temp 7 SLWI
-        dst dst temp OR
+        dst dst temp XOR
         "end" resolve-label
     ] with-scope ;
 
@@ -172,7 +172,7 @@ M: ppc %sar-imm SRAWI ;
 M: ppc %not     NOT ;
 
 : %alien-invoke-tail ( func dll -- )
-    scratch-reg %load-dlsym scratch-reg MTCTR BCTR ;
+    [ scratch-reg ] 2dip %alien-global scratch-reg MTCTR BCTR ;
 
 :: exchange-regs ( r1 r2 -- )
     scratch-reg r1 MR
@@ -411,7 +411,7 @@ M: ppc %set-alien-float swap 0 STFS ;
 M: ppc %set-alien-double swap 0 STFD ;
 
 : load-zone-ptr ( reg -- )
-    [ "nursery" f ] dip %load-dlsym ;
+    "nursery" f %alien-global ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 4 LWZ ] 2bi ;
@@ -433,14 +433,11 @@ M:: ppc %allot ( dst size class nursery-ptr -- )
     dst class store-header
     dst class store-tagged ;
 
-: %alien-global ( dst name -- )
-    [ f rot %load-dlsym ] [ drop dup 0 LWZ ] 2bi ;
-
 : load-cards-offset ( dst -- )
-    "cards_offset" %alien-global ;
+    [ "cards_offset" f %alien-global ] [ dup 0 LWZ ] bi ;
 
 : load-decks-offset ( dst -- )
-    "decks_offset" %alien-global ;
+    [ "decks_offset" f %alien-global ] [ dup 0 LWZ ] bi  ;
 
 M:: ppc %write-barrier ( src card# table -- )
     card-mark scratch-reg LI
@@ -627,14 +624,14 @@ M: ppc %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    "stack_chain" f scratch-reg %load-dlsym
+    scratch-reg "stack_chain" f %alien-global
     scratch-reg scratch-reg 0 LWZ
     1 scratch-reg 0 STW
     ds-reg scratch-reg 8 STW
     rs-reg scratch-reg 12 STW ;
 
 M: ppc %alien-invoke ( symbol dll -- )
-    11 %load-dlsym 11 MTLR BLRL ;
+    [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
 M: ppc %alien-callback ( quot -- )
     3 swap %load-indirect "c_to_factor" f %alien-invoke ;

basis/cpu/x86/assembler/assembler.factor

@@ -384,6 +384,8 @@ M: operand CMP OCT: 070 2-operand ;
 
 : XCHG ( dst src -- ) OCT: 207 2-operand ;
 
+: BSR ( dst src -- ) swap { HEX: 0f HEX: bd } (2-operand) ;
+
 : NOT  ( dst -- ) { BIN: 010 t HEX: f7 } 1-operand ;
 : NEG  ( dst -- ) { BIN: 011 t HEX: f7 } 1-operand ;
 : MUL  ( dst -- ) { BIN: 100 t HEX: f7 } 1-operand ;

basis/cpu/x86/x86.factor

@@ -5,10 +5,12 @@ cpu.x86.assembler cpu.x86.assembler.private cpu.architecture
 kernel kernel.private math memory namespaces make sequences
 words system layouts combinators math.order fry locals
 compiler.constants compiler.cfg.registers
-compiler.cfg.instructions compiler.codegen
+compiler.cfg.instructions compiler.cfg.intrinsics
-compiler.codegen.fixup ;
+compiler.codegen compiler.codegen.fixup ;
 IN: cpu.x86
 
+<< enable-fixnum-log2 >>
+
 M: x86 two-operand? t ;
 
 HOOK: temp-reg-1 cpu ( -- reg )
@@ -92,6 +94,7 @@ M: x86 %shl-imm nip SHL ;
 M: x86 %shr-imm nip SHR ;
 M: x86 %sar-imm nip SAR ;
 M: x86 %not     drop NOT ;
+M: x86 %log2    BSR ;
 
 : ?MOV ( dst src -- )
     2dup = [ 2drop ] [ MOV ] if ; inline

basis/db/sqlite/sqlite.factor

@@ -164,7 +164,7 @@ M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
 
 M: sqlite-db bind# ( spec obj -- )
     [
-        [ column-name>> ":" swap next-sql-counter 3append dup 0% ]
+        [ column-name>> ":" next-sql-counter surround dup 0% ]
         [ type>> ] bi
     ] dip <literal-bind> 1, ;
 

basis/editors/editpadlite/authors.txt

@@ -0,0 +1,2 @@
+Ryan Murphy
+Doug Coleman

basis/editors/editpadlite/editpadlite-docs.factor

@@ -0,0 +1,7 @@
+USING: help.syntax help.markup ;
+IN: editors.editpadpro
+
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
+"EditPadPro text editor integration on Windows.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
+
+ABOUT: "editors.editpadpro"

basis/editors/editpadlite/editpadlite.factor

@@ -0,0 +1,16 @@
+USING: definitions kernel parser words sequences math.parser
+namespaces editors io.launcher windows.shell32 io.files
+io.paths.windows strings unicode.case make ;
+IN: editors.editpadlite
+
+: editpadlite-path ( -- path )
+    \ editpadlite-path get-global [
+        "JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
+    ] unless* ;
+
+: editpadlite ( file line -- )
+    [
+        editpadlite-path , drop ,
+    ] { } make run-detached drop ;
+
+[ editpadlite ] edit-hook set-global

basis/editors/editpadlite/summary.txt

@@ -0,0 +1 @@
+EditPadLite editor integration

basis/editors/editpadpro/editpadpro-docs.factor

@@ -1,6 +1,7 @@
 USING: help.syntax help.markup ;
+IN: editors.editpadpro
 
-ARTICLE: "editpadpro" "EditPad Pro support"
+ARTICLE: "editors.editpadpro" "EditPad Pro support"
-"Just load this module and you will be able to edit documentation with EditPadPro.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
+"EditPadPro text editor integration on Windows.  Be sure to put EditPadPro in your system path so that it will be found.  Windows only." ;
 
-ABOUT: "editpadpro"
+ABOUT: "editors.editpadpro"

basis/editors/editpadpro/editpadpro.factor

@@ -1,17 +1,16 @@
 USING: definitions kernel parser words sequences math.parser
 namespaces editors io.launcher windows.shell32 io.files
-io.paths strings unicode.case make ;
+io.paths.windows strings unicode.case make ;
 IN: editors.editpadpro
 
-: editpadpro-path
+: editpadpro-path ( -- path )
     \ editpadpro-path get-global [
-        program-files "JGsoft" append-path
+        "JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
-        t [ >lower "editpadpro.exe" tail? ] find-file
     ] unless* ;
 
 : editpadpro ( file line -- )
     [
-        editpadpro-path , "/l" swap number>string append , ,
+        editpadpro-path , number>string "/l" prepend , ,
     ] { } make run-detached drop ;
 
 [ editpadpro ] edit-hook set-global

basis/editors/editplus/editplus.factor

@@ -1,10 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 make io.paths.windows ;
 IN: editors.editplus
 
 : editplus-path ( -- path )
     \ editplus-path get-global [
-        program-files "\\EditPlus 2\\editplus.exe" append-path
+        "EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : editplus ( file line -- )

basis/editors/emeditor/emeditor.factor

@@ -1,11 +1,10 @@
-USING: editors hardware-info.windows io.files io.launcher
+USING: editors io.files io.launcher kernel math.parser
-kernel math.parser namespaces sequences windows.shell32
+namespaces sequences windows.shell32 make io.paths.windows ;
-make ;
 IN: editors.emeditor
 
 : emeditor-path ( -- path )
     \ emeditor-path get-global [
-        program-files "\\EmEditor\\EmEditor.exe" append-path
+        "EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : emeditor ( file line -- )

basis/editors/etexteditor/etexteditor.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2008 Kibleur Christophe.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 io.paths.windows make ;
 IN: editors.etexteditor
 
 : etexteditor-path ( -- str )
     \ etexteditor-path get-global [
-        program-files "e\\e.exe" append-path
+        "e" t [ "e.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : etexteditor ( file line -- )

basis/editors/gvim/windows/windows.factor

@@ -1,9 +1,8 @@
 USING: editors.gvim io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths system ;
+sequences windows.shell32 io.paths.windows system ;
 IN: editors.gvim.windows
 
 M: windows gvim-path
     \ gvim-path get-global [
-        program-files "vim" append-path
+        "vim" t [ "gvim.exe" tail? ] find-in-program-files
-        t [ "gvim.exe" tail? ] find-file
     ] unless* ;

basis/editors/notepad2/notepad2.factor

@@ -2,9 +2,9 @@ USING: editors io.files io.launcher kernel math.parser
 namespaces sequences windows.shell32 make ;
 IN: editors.notepad2
 
-: notepad2-path ( -- str )
+: notepad2-path ( -- path )
     \ notepad2-path get-global [
-        program-files "C:\\Windows\\system32\\notepad.exe" append-path
+        "C:\\Windows\\system32\\notepad.exe"
     ] unless* ;
 
 : notepad2 ( file line -- )

basis/editors/notepadpp/notepadpp.factor

@@ -1,10 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
 IN: editors.notepadpp
 
-: notepadpp-path
+: notepadpp-path ( -- path )
     \ notepadpp-path get-global [
-        program-files "notepad++\\notepad++.exe" append-path
+        "notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : notepadpp ( file line -- )

basis/editors/scite/scite.factor

@@ -1,23 +1,14 @@
-! Basic SciTE integration for Factor.
+! Copyright (C) 2007 Clemens F. Hofreither.
-!
+! See http://factorcode.org/license.txt for BSD license.
-! By Clemens F. Hofreither, 2007.
 ! clemens.hofreither@gmx.net
-!
+USING: io.files io.launcher kernel namespaces io.paths.windows
-! In your .factor-rc or .factor-boot-rc,
+math math.parser editors sequences make unicode.case ;
-! require this module and set the scite-path
-! variable to point to your executable,
-! if not on the path.
-!
-USING: io.files io.launcher kernel namespaces math
-math.parser editors sequences windows.shell32 make ;
 IN: editors.scite
 
 : scite-path ( -- path )
     \ scite-path get-global [
-        program-files "ScITE Source Code Editor\\SciTE.exe" append-path
+        "Scintilla Text Editor" t
-        dup exists? [
+        [ >lower "scite.exe" tail? ] find-in-program-files
-            drop program-files "wscite\\SciTE.exe" append-path
-        ] unless
     ] unless* ;
 
 : scite-command ( file line -- cmd )
@@ -25,7 +16,7 @@ IN: editors.scite
     [
         scite-path ,
         ,
-    "-goto:" swap number>string append ,
+        number>string "-goto:" prepend ,
     ] { } make ;
 
 : scite-location ( file line -- )

basis/editors/scite/summary.txt

@@ -1 +1 @@
-SciTE editor integration
+Scintilla text editor (SciTE) integration

basis/editors/ted-notepad/ted-notepad.factor

@@ -1,15 +1,16 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences io.paths.windows make ;
 IN: editors.ted-notepad
 
-: ted-notepad-path
+: ted-notepad-path ( -- path )
     \ ted-notepad-path get-global [
-        program-files "\\TED Notepad\\TedNPad.exe" append-path
+        "TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : ted-notepad ( file line -- )
     [
-        ted-notepad-path , "/l" swap number>string append , ,
+        ted-notepad-path ,
+        number>string "/l" prepend , ,
     ] { } make run-detached drop ;
 
 [ ted-notepad ] edit-hook set-global

basis/editors/textedit/textedit.factor

@@ -1,6 +1,5 @@
 USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
-
 IN: editors.textedit
 
 : textedit-location ( file line -- )
@@ -9,5 +8,3 @@ IN: editors.textedit
     try-process ;
 
 [ textedit-location ] edit-hook set-global
-
-

basis/editors/ultraedit/ultraedit.factor

@@ -1,11 +1,10 @@
 USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 wne ;
+namespaces sequences io.paths.windows make ;
 IN: editors.ultraedit
 
 : ultraedit-path ( -- path )
     \ ultraedit-path get-global [
-        program-files
+        "IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
-        "IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" append-path
     ] unless* ;
 
 : ultraedit ( file line -- )

basis/editors/wordpad/wordpad.factor

@@ -1,14 +1,14 @@
-USING: editors hardware-info.windows io.launcher kernel
+USING: editors io.launcher kernel io.paths.windows
-math.parser namespaces sequences windows.shell32 io.files
+math.parser namespaces sequences io.files arrays ;
-arrays ;
 IN: editors.wordpad
 
 : wordpad-path ( -- path )
     \ wordpad-path get [
-        program-files "Windows NT\\Accessories\\wordpad.exe" append-path
+        "Windows NT\\Accessories" t
+        [ "wordpad.exe" tail? ] find-in-program-files
     ] unless* ;
 
 : wordpad ( file line -- )
-    drop wordpad-path swap 2array dup . run-detached drop ;
+    drop wordpad-path swap 2array run-detached drop ;
 
 [ wordpad ] edit-hook set-global

basis/grouping/grouping-tests.factor

@@ -5,7 +5,7 @@ IN: grouping.tests
 
 [ { "hell" "o wo" "rld" } ] [ "hello world" 4 group ] unit-test
 
-[ { V{ "a" "b" } V{ f f } } ] [
+[ { V{ "a" "b" } V{ 0 0 } } ] [
     V{ "a" "b" } clone 2 <groups>
     2 over set-length
     >array

basis/html/elements/elements.factor

@@ -26,7 +26,7 @@ SYMBOL: html
     #! dynamically creating words.
     [ elements-vocab create ] 2dip define-declared ;
 
-: <foo> ( str -- <str> ) "<" swap ">" 3append ;
+: <foo> ( str -- <str> ) "<" ">" surround ;
 
 : def-for-html-word-<foo> ( name -- )
     #! Return the name and code for the <foo> patterned
@@ -49,14 +49,14 @@ SYMBOL: html
     #! word.
     foo> [ ">" write-html ] (( -- )) html-word ;
 
-: </foo> ( str -- </str> ) "</" swap ">" 3append ;
+: </foo> ( str -- </str> ) "</" ">" surround ;
 
 : def-for-html-word-</foo> ( name -- )
     #! Return the name and code for the </foo> patterned
     #! word.
     </foo> dup '[ _ write-html ] (( -- )) html-word ;
 
-: <foo/> ( str -- <str/> ) "<" swap "/>" 3append ;
+: <foo/> ( str -- <str/> ) "<" "/>" surround ;
 
 : def-for-html-word-<foo/> ( name -- )
     #! Return the name and code for the <foo/> patterned

basis/io/unix/files/macosx/macosx.factor

@@ -13,7 +13,8 @@ M: macosx file-systems ( -- array )
     f <void*> dup 0 getmntinfo64 dup io-error
     [ *void* ] dip
     "statfs64" heap-size [ * memory>byte-array ] keep group
-    [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
+    [ statfs64-f_mntonname utf8 alien>string file-system-info ] map ;
+    ! [ [ new-file-system-info ] dip statfs>file-system-info ] map ;
 
 M: macosx new-file-system-info macosx-file-system-info new ;
 

basis/io/unix/kqueue/kqueue.factor

@@ -1,11 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types kernel math math.bitwise namespaces
+USING: accessors alien.c-types combinators io.unix.backend
-locals accessors combinators threads vectors hashtables
+kernel math.bitwise sequences struct-arrays unix unix.kqueue
-sequences assocs continuations sets
+unix.time ;
-unix unix.time unix.kqueue unix.process
-io.ports io.unix.backend io.launcher io.unix.launcher
-io.monitors ;
 IN: io.unix.kqueue
 
 TUPLE: kqueue-mx < mx events monitors ;
@@ -19,131 +16,66 @@ TUPLE: kqueue-mx < mx events monitors ;
     kqueue-mx new-mx
         H{ } clone >>monitors
         kqueue dup io-error >>fd
-        max-events "kevent" <c-array> >>events ;
+        max-events "kevent" <struct-array> >>events ;
 
-GENERIC: io-task-filter ( task -- n )
+: make-kevent ( fd filter flags -- event )
-
-M: input-task io-task-filter drop EVFILT_READ ;
-
-M: output-task io-task-filter drop EVFILT_WRITE ;
-
-GENERIC: io-task-fflags ( task -- n )
-
-M: io-task io-task-fflags drop 0 ;
-
-: make-kevent ( task flags -- event )
     "kevent" <c-object>
-    tuck set-kevent-flags
+    [ set-kevent-flags ] keep
-    over io-task-fd over set-kevent-ident
+    [ set-kevent-filter ] keep
-    over io-task-fflags over set-kevent-fflags
+    [ set-kevent-ident ] keep ;
-    swap io-task-filter over set-kevent-filter ;
 
 : register-kevent ( kevent mx -- )
-    fd>> swap 1 f 0 f kevent
+    fd>> swap 1 f 0 f kevent io-error ;
-    0 < [ err_no ESRCH = [ (io-error) ] unless ] when ;
 
-M: kqueue-mx register-io-task ( task mx -- )
+M: kqueue-mx add-input-callback ( thread fd mx -- )
-    [ >r EV_ADD make-kevent r> register-kevent ]
+    [ call-next-method ] [
-    [ call-next-method ]
+        [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
 
-M: kqueue-mx unregister-io-task ( task mx -- )
+M: kqueue-mx add-output-callback ( thread fd mx -- )
-    [ call-next-method ]
+    [ call-next-method ] [
-    [ >r EV_DELETE make-kevent r> register-kevent ]
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
-    2bi ;
+        register-kevent
+    ] 2bi ;
+
+: cancel-input-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_READ EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-input-callbacks ] 2bi ;
+
+: cancel-output-callbacks ( fd mx -- seq )
+    [
+        [ EVFILT_WRITE EV_DELETE make-kevent ] dip
+        register-kevent
+    ] [ remove-output-callbacks ] 2bi ;
+
+M: fd cancel-operation ( fd -- )
+    dup disposed>> [ drop ] [
+        fd>>
+        mx get-global
+        [ cancel-input-callbacks [ t swap resume-with ] each ]
+        [ cancel-output-callbacks [ t swap resume-with ] each ]
+        2bi
+    ] if ;
 
 : wait-kevent ( mx timespec -- n )
-    >r [ fd>> f 0 ] keep events>> max-events r> kevent
+    [
+        [ fd>> f 0 ]
+        [ events>> [ underlying>> ] [ length ] bi ] bi
+    ] dip kevent
     dup multiplexer-error ;
 
-:: kevent-read-task ( mx fd kevent -- )
-    mx fd mx reads>> at perform-io-task ;
-
-:: kevent-write-task ( mx fd kevent -- )
-    mx fd mx writes>> at perform-io-task ;
-
-:: kevent-proc-task ( mx pid kevent -- )
-    pid wait-for-pid
-    pid find-process
-    dup [ swap notify-exit ] [ 2drop ] if ;
-
-: parse-action ( mask -- changed )
-    [
-        NOTE_DELETE +remove-file+ ?flag
-        NOTE_WRITE +modify-file+ ?flag
-        NOTE_EXTEND +modify-file+ ?flag
-        NOTE_ATTRIB +modify-file+ ?flag
-        NOTE_RENAME +rename-file+ ?flag
-        NOTE_REVOKE +remove-file+ ?flag
-        drop
-    ] { } make prune ;
-
-:: kevent-vnode-task ( mx kevent fd -- )
-    ""
-    kevent kevent-fflags parse-action
-    fd mx monitors>> at queue-change ;
-
 : handle-kevent ( mx kevent -- )
-    [ ] [ kevent-ident ] [ kevent-filter ] tri {
+    [ kevent-ident swap ] [ kevent-filter ] bi {
-        { [ dup EVFILT_READ = ] [ drop kevent-read-task ] }
+        { EVFILT_READ [ input-available ] }
-        { [ dup EVFILT_WRITE = ] [ drop kevent-write-task ] }
+        { EVFILT_WRITE [ output-available ] }
-        { [ dup EVFILT_PROC = ] [ drop kevent-proc-task ] }
+    } case ;
-        { [ dup EVFILT_VNODE = ] [ drop kevent-vnode-task ] }
-    } cond ;
 
 : handle-kevents ( mx n -- )
-    [ over events>> kevent-nth handle-kevent ] with each ;
+    [ dup events>> ] dip head-slice [ handle-kevent ] with each ;
 
 M: kqueue-mx wait-for-events ( us mx -- )
     swap dup [ make-timespec ] when
     dupd wait-kevent handle-kevents ;
-
-! Procs
-: make-proc-kevent ( pid -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-ident
-    EV_ADD over set-kevent-flags
-    EVFILT_PROC over set-kevent-filter
-    NOTE_EXIT over set-kevent-fflags ;
-
-: register-pid-task ( pid mx -- )
-    swap make-proc-kevent swap register-kevent ;
-
-! VNodes
-TUPLE: vnode-monitor < monitor fd ;
-
-: vnode-fflags ( -- n )
-    {
-        NOTE_DELETE
-        NOTE_WRITE
-        NOTE_EXTEND
-        NOTE_ATTRIB
-        NOTE_LINK
-        NOTE_RENAME
-        NOTE_REVOKE
-    } flags ;
-
-: make-vnode-kevent ( fd flags -- kevent )
-    "kevent" <c-object>
-    tuck set-kevent-flags
-    tuck set-kevent-ident
-    EVFILT_VNODE over set-kevent-filter
-    vnode-fflags over set-kevent-fflags ;
-
-: register-monitor ( monitor mx -- )
-    >r dup fd>> r>
-    [ >r EV_ADD EV_CLEAR bitor make-vnode-kevent r> register-kevent drop ]
-    [ monitors>> set-at ] 3bi ;
-
-: unregister-monitor ( monitor mx -- )
-    >r fd>> r>
-    [ monitors>> delete-at ]
-    [ >r EV_DELETE make-vnode-kevent r> register-kevent ] 2bi ;
-
-: <vnode-monitor> ( path mailbox -- monitor )
-    >r [ O_RDONLY 0 open dup io-error ] keep r>
-    vnode-monitor new-monitor swap >>fd
-    [ dup kqueue-mx get register-monitor ] [ ] [ fd>> close ] cleanup ;
-
-M: vnode-monitor dispose
-    [ kqueue-mx get unregister-monitor ] [ fd>> close ] bi ;

basis/io/windows/launcher/launcher.factor

@@ -56,7 +56,7 @@ TUPLE: CreateProcess-args
 
 : escape-argument ( str -- newstr )
     CHAR: \s over member? [
-        "\"" swap fix-trailing-backslashes "\"" 3append
+        fix-trailing-backslashes "\"" dup surround
     ] when ;
 
 : join-arguments ( args -- cmd-line )

basis/math/intervals/intervals-docs.factor

@@ -44,7 +44,8 @@ ARTICLE: "math-intervals-arithmetic" "Interval arithmetic"
 { $subsection interval-bitnot }
 { $subsection interval-recip }
 { $subsection interval-2/ }
-{ $subsection interval-abs } ;
+{ $subsection interval-abs }
+{ $subsection interval-log2 } ;
 
 ARTICLE: "math-intervals-sets" "Set-theoretic operations on intervals"
 { $subsection interval-contains? }
@@ -203,6 +204,10 @@ HELP: interval-abs
 { $values { "i1" interval } { "i2" interval } }
 { $description "Absolute value of an interval." } ;
 
+HELP: interval-log2
+{ $values { "i1" interval } { "i2" interval } }
+{ $description "Integer-valued Base-2 logarithm of an interval." } ;
+
 HELP: interval-intersect
 { $values { "i1" interval } { "i2" interval } { "i3" "an " { $link interval  } " or " { $link f } } }
 { $description "Outputs the set-theoretic intersection of " { $snippet "i1" } " and " { $snippet "i2" } ". If " { $snippet "i1" } " and " { $snippet "i2" } " do not intersect, outputs " { $link f } "." } ;

basis/math/intervals/intervals.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 ! Based on Slate's src/unfinished/interval.slate by Brian Rice.
 USING: accessors kernel sequences arrays math math.order
-combinators generic ;
+combinators generic layouts ;
 IN: math.intervals
 
 SYMBOL: empty-interval
@@ -365,7 +365,7 @@ SYMBOL: incomparable
         2dup [ interval-nonnegative? ] both?
         [
             [ interval>points [ first ] bi@ ] bi@
-            4array supremum 0 swap next-power-of-2 [a,b]
+            4array supremum 0 swap >integer next-power-of-2 [a,b]
         ] [ 2drop [-inf,inf] ] if
     ] do-empty-interval ;
 
@@ -373,6 +373,18 @@ SYMBOL: incomparable
     #! Inaccurate.
     interval-bitor ;
 
+: interval-log2 ( i1 -- i2 )
+    {
+        { empty-interval [ empty-interval ] }
+        { full-interval [ 0 [a,inf] ] }
+        [
+            to>> first 1 max dup most-positive-fixnum >
+            [ drop full-interval interval-log2 ]
+            [ 1+ >integer log2 0 swap [a,b] ]
+            if
+        ]
+    } case ;
+
 : assume< ( i1 i2 -- i3 )
     dup special-interval? [ drop ] [
         to>> first [-inf,a) interval-intersect

basis/memoize/memoize-tests.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel memoize tools.test parser
+USING: math kernel memoize tools.test parser generalizations
 prettyprint io.streams.string sequences eval ;
 IN: memoize.tests
 
@@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
 
 [ 89 ] [ 10 fib ] unit-test
 
-[ "USING: kernel math memoize ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) >r >r >r >r 1+ r> r> r> r> ;" eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval ] must-fail
 
 MEMO: see-test ( a -- b ) reverse ;
 

basis/nmake/nmake.factor

@@ -10,7 +10,7 @@ SYMBOL: building-seq
 
 : n, ( obj n -- ) get-building-seq push ;
 : n% ( seq n -- ) get-building-seq push-all ;
-: n# ( num n -- ) >r number>string r> n% ;
+: n# ( num n -- ) [ number>string ] dip n% ;
 
 : 0, ( obj -- ) 0 n, ;
 : 0% ( seq -- ) 0 n% ;

basis/prettyprint/backend/backend.factor

@@ -10,7 +10,7 @@ IN: prettyprint.backend
 
 GENERIC: pprint* ( obj -- )
 
-M: effect pprint* effect>string "(" swap ")" 3append text ;
+M: effect pprint* effect>string "(" ")" surround text ;
 
 : ?effect-height ( word -- n )
     stack-effect [ effect-height ] [ 0 ] if* ;

basis/random/mersenne-twister/mersenne-twister-tests.factor

@@ -11,7 +11,7 @@ IN: random.mersenne-twister.tests
     100 [ 100 random ] replicate ;
 
 : test-rng ( seed quot -- )
-    >r <mersenne-twister> r> with-random ;
+    [  <mersenne-twister> ] dip with-random ;
 
 [ f ] [ 1234 [ randoms randoms = ] test-rng ] unit-test
 

basis/smtp/smtp.factor

@@ -72,10 +72,12 @@ ERROR: bad-email-address email ;
     [ bad-email-address ] unless ;
 
 : mail-from ( fromaddr -- )
-    "MAIL FROM:<" swap validate-address ">" 3append command ;
+    validate-address
+    "MAIL FROM:<" ">" surround command ;
 
 : rcpt-to ( to -- )
-    "RCPT TO:<" swap validate-address ">" 3append command ;
+    validate-address
+    "RCPT TO:<" ">" surround command ;
 
 : data ( -- )
     "DATA" command ;

basis/state-parser/state-parser.factor

@@ -139,7 +139,7 @@ M: not-enough-characters summary ( obj -- str )
 
 : expect ( ch -- )
     get-char 2dup = [ 2drop ] [
-        >r 1string r> 1string expected
+        [ 1string ] bi@ expected
     ] if next ;
 
 : expect-string ( string -- )
@@ -155,4 +155,4 @@ M: not-enough-characters summary ( obj -- str )
     swap [ init-parser call ] with-input-stream ; inline
 
 : string-parse ( input quot -- )
-    >r <string-reader> r> state-parse ; inline
+    [ <string-reader> ] dip state-parse ; inline

basis/tools/deploy/deploy-tests.factor

@@ -14,34 +14,22 @@ urls math.parser ;
 : small-enough? ( n -- ? )
     [ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
 
-[ ] [ "hello-world" shake-and-bake ] unit-test
+[ t ] [ "hello-world" shake-and-bake 500000 small-enough? ] unit-test
 
-[ t ] [ 500000 small-enough? ] unit-test
+[ t ] [ "sudoku" shake-and-bake 800000 small-enough? ] unit-test
 
-[ ] [ "sudoku" shake-and-bake ] unit-test
+[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
-
-[ t ] [ 800000 small-enough? ] unit-test
-
-[ ] [ "hello-ui" shake-and-bake ] unit-test
-
-[ t ] [ 1300000 small-enough? ] unit-test
 
 [ "staging.math-compiler-threads-ui-strip.image" ] [
     "hello-ui" deploy-config
     [ bootstrap-profile staging-image-name file-name ] bind
 ] unit-test
 
-[ ] [ "maze" shake-and-bake ] unit-test
+[ t ] [ "maze" shake-and-bake 1200000 small-enough? ] unit-test
 
-[ t ] [ 1200000 small-enough? ] unit-test
+[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
 
-[ ] [ "tetris" shake-and-bake ] unit-test
+[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
-
-[ t ] [ 1500000 small-enough? ] unit-test
-
-! [ ] [ "bunny" shake-and-bake ] unit-test
-
-! [ t ] [ 2500000 small-enough? ] unit-test
 
 : run-temp-image ( -- )
     vm
@@ -110,3 +98,8 @@ M: quit-responder call-responder*
     "tools.deploy.test.7" shake-and-bake
     run-temp-image
 ] unit-test
+
+[ ] [
+    "tools.deploy.test.8" shake-and-bake
+    run-temp-image
+] unit-test

basis/tools/deploy/test/8/8.factor

@@ -0,0 +1,11 @@
+USING: kernel ;
+IN: tools.deploy.test.8
+
+: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
+: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
+
+: literal-merge-test ( -- )
+    literal-merge-test-1
+    literal-merge-test-2 eq? t assert= ;
+
+MAIN: literal-merge-test

basis/tools/deploy/test/8/deploy.factor

@@ -0,0 +1,15 @@
+USING: tools.deploy.config ;
+H{
+    { deploy-name "tools.deploy.test.8" }
+    { deploy-c-types? f }
+    { deploy-word-props? f }
+    { deploy-ui? f }
+    { deploy-reflection 1 }
+    { deploy-compiler? f }
+    { deploy-unicode? f }
+    { deploy-io 1 }
+    { deploy-word-defs? f }
+    { deploy-threads? f }
+    { "stop-after-last-window?" t }
+    { deploy-math? f }
+}

basis/tools/files/files.factor

@@ -1,14 +1,15 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators io io.files kernel
-math.parser sequences system vocabs.loader calendar ;
+math.parser sequences system vocabs.loader calendar math
+symbols fry prettyprint ;
 IN: tools.files
 
 <PRIVATE
 
 : ls-time ( timestamp -- string )
     [ hour>> ] [ minute>> ] bi
-    [ number>string 2 CHAR: 0 pad-left ] bi@ ":" swap 3append ;
+    [ number>string 2 CHAR: 0 pad-left ] bi@ ":" glue ;
 
 : ls-timestamp ( timestamp -- string )
     [ month>> month-abbreviation ]
@@ -32,7 +33,37 @@ PRIVATE>
 : directory. ( path -- )
     [ (directory.) ] with-directory-files [ print ] each ;
 
+SYMBOLS: device-name mount-point type
+available-space free-space used-space total-space
+percent-used percent-free ;
+
+: percent ( real -- integer ) 100 * >integer ; inline
+
+: file-system-spec ( file-system-info obj -- str )
+    {
+        { device-name [ device-name>> ] }
+        { mount-point [ mount-point>> ] }
+        { type [ type>> ] }
+        { available-space [ available-space>> ] }
+        { free-space [ free-space>> ] }
+        { used-space [ used-space>> ] }
+        { total-space [ total-space>> ] }
+        { percent-used [
+            [ used-space>> ] [ total-space>> ] bi dup 0 =
+            [ 2drop 0 ] [ / percent ] if
+        ] }
+    } case ;
+
+: file-systems-info ( spec -- seq )
+    file-systems swap '[ _ [ file-system-spec ] with map ] map ;
+
+: file-systems. ( spec -- )
+    [ file-systems-info ]
+    [ [ unparse ] map ] bi prefix simple-table. ;
+
 {
     { [ os unix? ] [ "tools.files.unix" ] }
     { [ os windows? ] [ "tools.files.windows" ] }
 } cond require
+
+! { device-name free-space used-space total-space percent-used } file-systems.

basis/tools/vocabs/browser/browser.factor

@@ -289,7 +289,7 @@ M: vocab-spec article-parent drop "vocab-index" ;
 M: vocab-tag >link ;
 
 M: vocab-tag article-title
-    name>> "Vocabularies tagged ``" swap "''" 3append ;
+    name>> "Vocabularies tagged ``" "''" surround ;
 
 M: vocab-tag article-name name>> ;
 

basis/ui/freetype/freetype.factor

@@ -61,7 +61,7 @@ M: freetype-renderer free-fonts ( world -- )
     } at ;
 
 : ttf-path ( name -- string )
-    "resource:fonts/" swap ".ttf" 3append ;
+    "resource:fonts/" ".ttf" surround ;
 
 : (open-face) ( path length -- face )
     #! We use FT_New_Memory_Face, not FT_New_Face, since

basis/ui/tools/deploy/deploy.factor

@@ -119,5 +119,5 @@ deploy-gadget "toolbar" f {
 : deploy-tool ( vocab -- )
     vocab-name
     [ <deploy-gadget> 10 <border> ]
-    [ "Deploying \"" swap "\"" 3append ] bi
+    [ "Deploying \"" "\"" surround ] bi
     open-window ;

basis/unicode/case/case-tests.factor

@@ -16,3 +16,9 @@ USING: unicode.case tools.test namespaces ;
     "lt" locale set
     ! Lithuanian casing tests
 ] with-scope
+
+[ t ] [ "asdf" lower? ] unit-test
+[ f ] [ "asdF" lower? ] unit-test
+
+[ t ] [ "ASDF" upper? ] unit-test
+[ f ] [ "ASDf" upper? ] unit-test

basis/unicode/case/case.factor

@@ -100,11 +100,10 @@ SYMBOL: locale ! Just casing locale, or overall?
 : >case-fold ( string -- fold )
     >upper >lower ;
 
-: lower? ( string -- ? )
+: lower? ( string -- ? ) dup >lower = ;
-    dup >lower = ;
+
-: upper? ( string -- ? )
+: upper? ( string -- ? ) dup >upper = ;
-    dup >lower = ;
+
-: title? ( string -- ? )
+: title? ( string -- ? ) dup >title = ;
-    dup >title = ;
+
-: case-fold? ( string -- ? )
+: case-fold? ( string -- ? ) dup >case-fold = ;
-    dup >case-fold = ;

core/arrays/arrays.factor

@@ -12,9 +12,9 @@ M: array resize resize-array ;
 
 : >array ( seq -- array ) { } clone-like ;
 
-M: object new-sequence drop f <array> ;
+M: object new-sequence drop 0 <array> ;
 
-M: f new-sequence drop dup zero? [ drop f ] [ f <array> ] if ;
+M: f new-sequence drop dup zero? [ drop f ] [ 0 <array> ] if ;
 
 M: array equal?
     over array? [ sequence= ] [ 2drop f ] if ;

core/assocs/assocs.factor

@@ -90,7 +90,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     ] if ; inline recursive
 
 : assoc-stack ( key seq -- value )
-    dup length 1- swap (assoc-stack) ;
+    dup length 1- swap (assoc-stack) ; flushable
 
 : assoc-subset? ( assoc1 assoc2 -- ? )
     [ swapd at* [ = ] [ 2drop f ] if ] curry assoc-all? ;

core/classes/intersection/intersection.factor

@@ -12,7 +12,7 @@ PREDICATE: intersection-class < class
         [ drop t ]
     ] [
         unclip "predicate" word-prop swap [
-            "predicate" word-prop [ dup ] swap [ not ] 3append
+            "predicate" word-prop [ dup ] [ not ] surround
             [ drop f ]
         ] { } map>assoc alist>quot
     ] if-empty ;

core/generic/math/math.factor

@@ -28,9 +28,6 @@ PREDICATE: math-class < class
 : math-class-max ( class1 class2 -- class )
     [ math-class<=> ] most ;
 
-: math-class-min ( class1 class2 -- class )
-    [ swap math-class<=> ] most ;
-
 : (math-upgrade) ( max class -- quot )
     dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ;
 

core/hashtables/hashtables.factor

@@ -40,7 +40,7 @@ TUPLE: hashtable
     0 >>count 0 >>deleted drop ; inline
 
 : reset-hash ( n hash -- )
-    swap <hash-array> >>array init-hash ;
+    swap <hash-array> >>array init-hash ; inline
 
 : (new-key@) ( key keys i -- keys n empty? )
     3dup swap array-nth dup ((empty)) eq? [

core/math/integers/integers.factor

@@ -40,11 +40,10 @@ M: fixnum bitnot fixnum-bitnot ;
 
 M: fixnum bit? neg shift 1 bitand 0 > ;
 
-: (fixnum-log2) ( accum n -- accum )
+: fixnum-log2 ( x -- n )
-    dup 1 number= [ drop ] [ [ 1+ ] [ 2/ ] bi* (fixnum-log2) ] if ;
+    0 swap [ dup 1 number= not ] [ [ 1+ ] [ 2/ ] bi* ] [ ] while drop ;
-    inline recursive
 
-M: fixnum (log2) 0 swap (fixnum-log2) ;
+M: fixnum (log2) fixnum-log2 ;
 
 M: bignum >fixnum bignum>fixnum ;
 M: bignum >bignum ;
@@ -74,7 +73,7 @@ M: bignum /mod bignum/mod ;
 M: bignum bitand bignum-bitand ;
 M: bignum bitor bignum-bitor ;
 M: bignum bitxor bignum-bitxor ;
-M: bignum shift bignum-shift ;
+M: bignum shift >fixnum bignum-shift ;
 
 M: bignum bitnot bignum-bitnot ;
 M: bignum bit? bignum-bit? ;

core/math/math.factor

@@ -53,7 +53,7 @@ PRIVATE>
         "log2 expects positive inputs" throw
     ] [
         (log2)
-    ] if ; foldable
+    ] if ; inline
 
 : zero? ( x -- ? ) 0 number= ; inline
 : 1+ ( x -- y ) 1 + ; inline
@@ -103,14 +103,8 @@ M: float fp-infinity? ( float -- ? )
         drop f
     ] if ;
 
-: (next-power-of-2) ( i n -- n )
+: next-power-of-2 ( m -- n )
-    2dup >= [
+    dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
-        drop
-    ] [
-        [ 1 shift ] dip (next-power-of-2)
-    ] if ;
-
-: next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
 
 : power-of-2? ( n -- ? )
     dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable

core/namespaces/namespaces.factor

@@ -12,12 +12,12 @@ IN: namespaces
 
 PRIVATE>
 
-: namespace ( -- namespace ) namestack* peek ;
+: namespace ( -- namespace ) namestack* peek ; inline
 : namestack ( -- namestack ) namestack* clone ;
 : set-namestack ( namestack -- ) >vector 0 setenv ;
 : global ( -- g ) 21 getenv { hashtable } declare ; inline
 : init-namespaces ( -- ) global 1array set-namestack ;
-: get ( variable -- value ) namestack* assoc-stack ; flushable
+: get ( variable -- value ) namestack* assoc-stack ; inline
 : set ( value variable -- ) namespace set-at ;
 : on ( variable -- ) t swap set ; inline
 : off ( variable -- ) f swap set ; inline
@@ -28,7 +28,7 @@ PRIVATE>
 : inc ( variable -- ) 1 swap +@ ; inline
 : dec ( variable -- ) -1 swap +@ ; inline
 : bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) global [ dup inc get ] bind ;
+: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
 
 : make-assoc ( quot exemplar -- hash )
     20 swap new-assoc [ >n call ndrop ] keep ; inline

core/parser/parser.factor

@@ -71,7 +71,7 @@ TUPLE: no-current-vocab ;
 
 : word-restarts ( name possibilities -- restarts )
     natural-sort
-    [ [ "Use the " swap vocabulary>> " vocabulary" 3append ] keep ] { } map>assoc
+    [ [ vocabulary>> "Use the " " vocabulary" surround ] keep ] { } map>assoc
     swap "Defer word in current vocabulary" swap 2array
     suffix ;
 
@@ -89,7 +89,7 @@ SYMBOL: auto-use?
         dup vocabulary>>
         [ (use+) ]
         [ amended-use get dup [ push ] [ 2drop ] if ]
-        [ "Added ``" swap "'' vocabulary to search path" 3append note. ]
+        [ "Added ``" "'' vocabulary to search path" surround note. ]
         tri
     ] [ create-in ] if ;
 
@@ -292,7 +292,7 @@ print-use-hook global [ [ ] or ] change-at
     ] with-compilation-unit ;
 
 : parse-file-restarts ( file -- restarts )
-    "Load " swap " again" 3append t 2array 1array ;
+    "Load " " again" surround t 2array 1array ;
 
 : parse-file ( file -- quot )
     [

core/sequences/sequences-docs.factor

@@ -416,11 +416,6 @@ HELP: interleave
 { $description "Applies " { $snippet "quot" } " to each element in turn, also invoking " { $snippet "between" } " in-between each pair of elements." }
 { $example "USING: io sequences ;" "{ \"a\" \"b\" \"c\" } [ \"X\" write ] [ write ] interleave" "aXbXc" } ;
 
-HELP: cache-nth
-{ $values { "i" "a non-negative integer" } { "seq" "a mutable sequence" } { "quot" { $quotation "( i -- elt )" } } { "elt" object } }
-{ $description "If the sequence does not contain at least " { $snippet "i" } " elements or if the " { $snippet "i" } "th element of the sequence is " { $link f } ", calls the quotation to produce a new value, and stores it back into the sequence. Otherwise, this word outputs the " { $snippet "i" } "th element of the sequence." }
-{ $side-effects "seq" } ;
-
 HELP: index
 { $values { "obj" object } { "seq" sequence } { "n" "an index" } }
 { $description "Outputs the index of the first element in the sequence equal to " { $snippet "obj" } ". If no element is found, outputs " { $link f } "." } ;
@@ -1497,7 +1492,6 @@ ARTICLE: "sequences-destructive" "Destructive operations"
 "Changing elements:"
 { $subsection change-each }
 { $subsection change-nth }
-{ $subsection cache-nth }
 "Deleting elements:"
 { $subsection delete }
 { $subsection delq }

core/sequences/sequences-tests.factor

@@ -190,16 +190,6 @@ unit-test
 
 [ V{ "a" "b" } V{ } ] [ { "X" "a" "b" } { "X" } drop-prefix [ >vector ] bi@ ] unit-test
 
-[ 1 4 9 16 16 V{ f 1 4 9 16 } ] [
-    V{ } clone "cache-test" set
-    1 "cache-test" get [ sq ] cache-nth
-    2 "cache-test" get [ sq ] cache-nth
-    3 "cache-test" get [ sq ] cache-nth
-    4 "cache-test" get [ sq ] cache-nth
-    4 "cache-test" get [ "wrong" ] cache-nth
-    "cache-test" get
-] unit-test
-
 [ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
 
 ! Pathological case

core/sequences/sequences.factor

@@ -523,13 +523,6 @@ PRIVATE>
 : harvest ( seq -- newseq )
     [ empty? not ] filter ;
 
-: cache-nth ( i seq quot -- elt )
-    2over ?nth dup [
-        [ 3drop ] dip
-    ] [
-        drop swap [ over [ call dup ] dip ] dip set-nth
-    ] if ; inline
-
 : mismatch ( seq1 seq2 -- i )
     [ min-length ] 2keep
     [ 2nth-unsafe = not ] 2curry

core/slots/slots.factor

@@ -50,7 +50,7 @@ PREDICATE: writer < word "writer" word-prop ;
     define-typecheck ;
 
 : writer-word ( name -- word )
-    "(>>" swap ")" 3append (( value object -- )) create-accessor
+    "(>>" ")" surround (( value object -- )) create-accessor
     dup t "writer" set-word-prop ;
 
 ERROR: bad-slot-value value class ;

core/vectors/vectors.factor

@@ -8,7 +8,7 @@ TUPLE: vector
 { underlying array }
 { length array-capacity } ;
 
-: <vector> ( n -- vector ) f <array> 0 vector boa ; inline
+: <vector> ( n -- vector ) 0 <array> 0 vector boa ; inline
 
 : >vector ( seq -- vector ) V{ } clone-like ;
 

core/words/words.factor

@@ -239,7 +239,7 @@ ERROR: bad-create name vocab ;
     dup [ 2nip ] [ drop <word> dup reveal ] if ;
 
 : constructor-word ( name vocab -- word )
-    [ "<" swap ">" 3append ] dip create ;
+    [ "<" ">" surround ] dip create ;
 
 PREDICATE: parsing-word < word "parsing" word-prop ;
 

extra/bunny/outlined/outlined.factor

@@ -1,7 +1,8 @@
 USING: arrays bunny.model bunny.cel-shaded continuations
 destructors kernel math multiline opengl opengl.shaders
-opengl.framebuffers opengl.gl opengl.demo-support
+opengl.framebuffers opengl.gl opengl.demo-support fry
-opengl.capabilities sequences ui.gadgets combinators accessors ;
+opengl.capabilities sequences ui.gadgets combinators accessors
+macros ;
 IN: bunny.outlined
 
 STRING: outlined-pass1-fragment-shader-main-source
@@ -176,24 +177,30 @@ TUPLE: bunny-outlined
         } cleave
     ] [ drop ] if ;
 
+MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
+    '[ _ _ (framebuffer-texture) [ @ drop ] keep ] ;
+
+: (make-framebuffer-textures) ( draw dim -- draw color normal depth )
+    {
+        [ drop ]
+        [ GL_RGBA16F_ARB GL_RGBA [ >>color-texture  ] (framebuffer-texture>>draw) ]
+        [ GL_RGBA16F_ARB GL_RGBA [ >>normal-texture ] (framebuffer-texture>>draw) ]
+        [
+            GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT
+            [ >>depth-texture ] (framebuffer-texture>>draw)
+        ]
+    } 2cleave ;
+
+: remake-framebuffer ( draw -- )
+    [ dispose-framebuffer ]
+    [ dup gadget>> dim>>
+        [ (make-framebuffer-textures) (make-framebuffer) >>framebuffer ]
+        [ >>framebuffer-dim drop ] bi
+    ] bi ;
+
 : remake-framebuffer-if-needed ( draw -- )
     dup [ gadget>> dim>> ] [ framebuffer-dim>> ] bi =
-    [ drop ] [
+    [ drop ] [ remake-framebuffer ] if ;
-        [ dispose-framebuffer ] [ dup ] [ gadget>> dim>> ] tri {
-            [
-                GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
-                [ >>color-texture drop ] keep
-            ] [
-                GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
-                [ >>normal-texture drop ] keep
-            ] [ 
-                GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
-                [ >>depth-texture drop ] keep
-            ]
-        } 2cleave
-        [ (make-framebuffer) >>framebuffer ] [ >>framebuffer-dim ] bi
-        drop
-    ] if ;
 
 : clear-framebuffer ( -- )
     GL_COLOR_ATTACHMENT0_EXT glDrawBuffer

extra/combinators/lib/lib-tests.factor

@@ -16,7 +16,7 @@ IN: combinators.lib.tests
 
 [ { "foo" "xbarx" } ]
 [
-    { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call
+    { "oof" "bar" } { [ reverse ] [ "x" dup surround ] } parallel-call
 ] unit-test
 
 { 1 1 } [

extra/combinators/lib/lib.factor

@@ -116,18 +116,9 @@ MACRO: construct-slots ( assoc tuple-class -- tuple )
         [ dip ] curry swap 1quotation [ keep ] curry compose
     ] { } assoc>map concat compose ;
 
-: either ( object first second -- ? )
-    >r keep swap [ r> drop ] [ r> call ] ?if ; inline
-
 : 2quot-with ( obj seq quot1 quot2 -- seq quot1 quot2 )
     >r pick >r with r> r> swapd with ;
 
-: or? ( obj quot1 quot2 -- ? )
-    [ keep ] dip rot [ 2nip ] [ call ] if* ; inline
-
-: and? ( obj quot1 quot2 -- ? )
-    [ keep ] dip rot [ call ] [ 2drop f ] if ; inline
-
 MACRO: multikeep ( word out-indexes -- ... )
     [
         dup >r [ \ npick \ >r 3array % ] each

extra/crypto/barrett/barrett.factor

@@ -8,5 +8,3 @@ IN: crypto.barrett
     #! size = word size in bits (8, 16, 32, 64, ...)
     [ [ log2 1+ ] [ / 2 * ] bi* ]
     [ 2^ rot ^ swap /i ] 2bi ;
-
-

extra/crypto/hmac/hmac.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: arrays combinators checksums checksums.md5
 checksums.sha1 checksums.md5.private io io.binary io.files
 io.streams.byte-array kernel math math.vectors memoize sequences

extra/crypto/timing/timing.factor

@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math threads system calendar ;
 IN: crypto.timing
 

extra/crypto/xor/xor.factor

@@ -8,5 +8,5 @@ IN: crypto.xor
 ERROR: empty-xor-key ;
 
 : xor-crypt ( seq key -- seq' )
-    dup empty? [ empty-xor-key ] when
+    [ empty-xor-key ] when-empty
     [ dup length ] dip '[ _ mod-nth bitxor ] 2map ;

extra/html/parser/utils/utils.factor

@@ -16,10 +16,10 @@ IN: html.parser.utils
     [ ?head drop ] [ ?tail drop ] bi ;
 
 : single-quote ( str -- newstr )
-    "'" swap "'" 3append ;
+    "'" dup surround ;
 
 : double-quote ( str -- newstr )
-    "\"" swap "\"" 3append ;
+    "\"" dup surround ;
 
 : quote ( str -- newstr )
     CHAR: ' over member?

extra/inverse/inverse.factor

@@ -9,14 +9,12 @@ combinators.short-circuit fry qualified ;
 RENAME: _ fry => __
 IN: inverse
 
-TUPLE: fail ;
+ERROR: fail ;
-: fail ( -- * ) \ fail new throw ;
 M: fail summary drop "Unification failed" ;
 
 : assure ( ? -- ) [ fail ] unless ;
 
-: =/fail ( obj1 obj2 -- )
+: =/fail ( obj1 obj2 -- ) = assure ;
-    = assure ;
 
 ! Inverse of a quotation
 
@@ -26,25 +24,26 @@ M: fail summary drop "Unification failed" ;
     pick 1quotation 3array "math-inverse" set-word-prop ;
 
 : define-pop-inverse ( word n quot -- )
-    >r dupd "pop-length" set-word-prop r>
+    [ dupd "pop-length" set-word-prop ] dip
     "pop-inverse" set-word-prop ;
 
-TUPLE: no-inverse word ;
+ERROR: no-inverse word ;
-: no-inverse ( word -- * ) \ no-inverse new throw ;
 M: no-inverse summary
     drop "The word cannot be used in pattern matching" ;
 
+ERROR: bad-math-inverse ;
+
 : next ( revquot -- revquot* first )
-    [ "Badly formed math inverse" throw ]
+    [ bad-math-inverse ]
     [ unclip-slice ] if-empty ;
 
 : constant-word? ( word -- ? )
     stack-effect
-    [ out>> length 1 = ] keep
+    [ out>> length 1 = ]
-    in>> length 0 = and ;
+    [ in>> empty? ] bi and ;
 
 : assure-constant ( constant -- quot )
-    dup word? [ "Badly formed math inverse" throw ] when 1quotation ;
+    dup word? [ bad-math-inverse ] when 1quotation ;
 
 : swap-inverse ( math-inverse revquot -- revquot* quot )
     next assure-constant rot second '[ @ swap @ ] ;
@@ -55,8 +54,7 @@ M: no-inverse summary
 : ?word-prop ( word/object name -- value/f )
     over word? [ word-prop ] [ 2drop f ] if ;
 
-: undo-literal ( object -- quot )
+: undo-literal ( object -- quot ) [ =/fail ] curry ;
-    [ =/fail ] curry ;
 
 PREDICATE: normal-inverse < word "inverse" word-prop ;
 PREDICATE: math-inverse < word "math-inverse" word-prop ;
@@ -65,13 +63,13 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
 
 : enough? ( stack word -- ? )
     dup deferred? [ 2drop f ] [
-        [ >r length r> 1quotation infer in>> >= ]
+        [ [ length ] dip 1quotation infer in>> >= ]
         [ 3drop f ] recover
     ] if ;
 
 : fold-word ( stack word -- stack )
     2dup enough?
-    [ 1quotation with-datastack ] [ >r % r> , { } ] if ;
+    [ 1quotation with-datastack ] [ [ % ] dip , { } ] if ;
 
 : fold ( quot -- folded-quot )
     [ { } swap [ fold-word ] each % ] [ ] make ; 
@@ -95,13 +93,15 @@ UNION: explicit-inverse normal-inverse math-inverse pop-inverse ;
         throw
     ] recover ;
 
+ERROR: undefined-inverse ;
+
 GENERIC: inverse ( revquot word -- revquot* quot )
 
 M: object inverse undo-literal ;
 
 M: symbol inverse undo-literal ;
 
-M: word inverse drop "Inverse is undefined" throw ;
+M: word inverse undefined-inverse ;
 
 M: normal-inverse inverse
     "inverse" word-prop ;
@@ -112,8 +112,8 @@ M: math-inverse inverse
     [ drop swap-inverse ] [ pull-inverse ] if ;
 
 M: pop-inverse inverse
-    [ "pop-length" word-prop cut-slice swap >quotation ] keep
+    [ "pop-length" word-prop cut-slice swap >quotation ]
-    "pop-inverse" word-prop compose call ;
+    [ "pop-inverse" word-prop ] bi compose call ;
 
 : (undo) ( revquot -- )
     [ unclip-slice inverse % (undo) ] unless-empty ;
@@ -129,7 +129,7 @@ MACRO: undo ( quot -- ) [undo] ;
 \ dup [ [ =/fail ] keep ] define-inverse
 \ 2dup [ over =/fail over =/fail ] define-inverse
 \ 3dup [ pick =/fail pick =/fail pick =/fail ] define-inverse
-\ pick [ >r pick r> =/fail ] define-inverse
+\ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
 \ not [ not ] define-inverse
@@ -151,9 +151,12 @@ MACRO: undo ( quot -- ) [undo] ;
 \ sq [ sqrt ] define-inverse
 \ sqrt [ sq ] define-inverse
 
+ERROR: missing-literal ;
+
 : assert-literal ( n -- n )
-    dup [ word? ] keep symbol? not and
+    dup
-    [ "Literal missing in pattern matching" throw ] when ;
+    [ word? ] [ symbol? not ] bi and
+    [ missing-literal ] when ;
 \ + [ - ] [ - ] define-math-inverse
 \ - [ + ] [ - ] define-math-inverse
 \ * [ / ] [ / ] define-math-inverse
@@ -162,7 +165,7 @@ MACRO: undo ( quot -- ) [undo] ;
 
 \ ? 2 [
     [ assert-literal ] bi@
-    [ swap >r over = r> swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
+    [ swap [ over = ] dip swap [ 2drop f ] [ = [ t ] [ fail ] if ] if ]
     2curry
 ] define-pop-inverse
 
@@ -217,7 +220,7 @@ DEFER: _
     dup wrapper? [ wrapped>> ] when ;
 
 : boa-inverse ( class -- quot )
-    [ deconstruct-pred ] keep slot-readers compose ;
+    [ deconstruct-pred ] [ slot-readers ] bi compose ;
 
 \ boa 1 [ ?wrapped boa-inverse ] define-pop-inverse
 
@@ -232,7 +235,7 @@ DEFER: _
 
 : recover-fail ( try fail -- )
     [ drop call ] [
-        >r nip r> dup fail?
+        [ nip ] dip dup fail?
         [ drop call ] [ nip throw ] if
     ] recover ; inline
 
@@ -243,12 +246,11 @@ DEFER: _
     in>> [ ndrop f ] curry [ recover-fail ] curry ;
 
 : [matches?] ( quot -- undoes?-quot )
-    [undo] dup infer [ true-out ] keep false-recover curry ;
+    [undo] dup infer [ true-out ] [ false-recover ] bi curry ;
 
 MACRO: matches? ( quot -- ? ) [matches?] ;
 
-TUPLE: no-match ;
+ERROR: no-match ;
-: no-match ( -- * ) \ no-match new throw ;
 M: no-match summary drop "Fall through in switch" ;
 
 : recover-chain ( seq -- quot )
@@ -256,7 +258,7 @@ M: no-match summary drop "Fall through in switch" ;
 
 : [switch]  ( quot-alist -- quot )
     [ dup quotation? [ [ ] swap 2array ] when ] map
-    reverse [ >r [undo] r> compose ] { } assoc>map
+    reverse [ [ [undo] ] dip compose ] { } assoc>map
     recover-chain ;
 
 MACRO: switch ( quot-alist -- ) [switch] ;

extra/io/paths/paths.factor

@@ -1,11 +1,13 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel sequences accessors
+USING: accessors arrays deques dlists io.files io.paths.private
-dlists deques arrays ;
+kernel sequences system vocabs.loader fry continuations ;
 IN: io.paths
 
 TUPLE: directory-iterator path bfs queue ;
 
+<PRIVATE
+
 : qualified-directory ( path -- seq )
     dup directory-files [ append-path ] with map ;
 
@@ -25,25 +27,32 @@ TUPLE: directory-iterator path bfs queue ;
         [ over push-directory next-file ] [ nip ] if
     ] if ;
 
-: iterate-directory ( iter quot -- obj )
+: iterate-directory ( iter quot: ( obj -- ? ) -- obj )
     over next-file [
         over call
-        [ 2drop ] [ iterate-directory ] if
+        [ 2nip ] [ iterate-directory ] if*
     ] [
         2drop f
     ] if* ; inline recursive
 
-: find-file ( path bfs? quot -- path/f )
+PRIVATE>
+
+: find-file ( path bfs? quot: ( obj -- ? ) -- path/f )
     [ <directory-iterator> ] dip
     [ keep and ] curry iterate-directory ; inline
 
-: each-file ( path bfs? quot -- )
+: each-file ( path bfs? quot: ( obj -- ? ) -- )
     [ <directory-iterator> ] dip
     [ f ] compose iterate-directory drop ; inline
 
-: find-all-files ( path bfs? quot -- paths )
+: find-all-files ( path bfs? quot: ( obj -- ? ) -- paths )
     [ <directory-iterator> ] dip
     pusher [ [ f ] compose iterate-directory drop ] dip ; inline
 
 : recursive-directory ( path bfs? -- paths )
     [ ] accumulator [ each-file ] dip ;
+
+: find-in-directories ( directories bfs? quot -- path' )
+    '[ _ _ find-file ] attempt-all ; inline
+
+os windows? [ "io.paths.windows" require ] when

extra/io/paths/windows/windows.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays continuations fry io.files io.paths
+kernel windows.shell32 sequences ;
+IN: io.paths.windows
+
+: program-files-directories ( -- array )
+    program-files program-files-x86 2array ; inline
+
+: find-in-program-files ( base-directory bfs? quot -- path )
+    [
+        [ program-files-directories ] dip '[ _ append-path ] map
+    ] 2dip find-in-directories ; inline

extra/irc/messages/messages.factor

@@ -90,11 +90,11 @@ M: end-of-names >>command-parameters ( names-reply params -- names-reply )
     first2 [ >>who ] [ >>channel ] bi* ;
 
 M: mode >>command-parameters ( mode params -- mode )
-    dup length 3 = [
+    dup length {
-        first3 [ >>name ] [ >>mode ] [ >>parameter ] tri*
+        { 3 [ first3 [ >>name ] [ >>mode ] [ >>parameter ] tri* ] }
-    ] [
+        { 2 [ first2 [ >>name ] [ >>mode ] bi* ] }
-        first2 [ >>name ] [ >>mode ] bi*
+        [ drop first >>name dup trailing>> >>mode ]
-    ] if ;
+    } case ;
 
 PRIVATE>
 
@@ -135,12 +135,12 @@ M: irc-message irc-message>server-line ( irc-message -- string )
 
 : copy-message-in ( command irc-message -- command )
     {
-        [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
         [ line>>      >>line ]
         [ prefix>>    >>prefix ]
         [ command>>   >>command ]
         [ trailing>>  >>trailing ]
         [ timestamp>> >>timestamp ]
+        [ parameters>> [ >>parameters ] [ >>command-parameters ] bi ]
     } cleave ;
 
 PRIVATE>

extra/irc/ui/ui.factor

@@ -9,7 +9,7 @@ USING: accessors kernel threads combinators concurrency.mailboxes
        ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
        io io.styles namespaces calendar calendar.format models continuations
        irc.client irc.client.private irc.messages
-       irc.ui.commandparser irc.ui.load vocabs.loader ;
+       irc.ui.commandparser irc.ui.load vocabs.loader classes prettyprint ;
 
 RENAME: join sequences => sjoin
 
@@ -30,6 +30,7 @@ TUPLE: irc-tab < frame chat client window ;
     foreground associate format ;
 : dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
 : dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
+: dark-blue T{ rgba f 0.0 0.0 0.5 1 } ;
 
 : dot-or-parens ( string -- string )
     [ "." ]
@@ -41,14 +42,14 @@ M: ping write-irc
     drop "* Ping" blue write-color ;
 
 M: privmsg write-irc
-    "<" blue write-color
+    "<" dark-blue write-color
     [ irc-message-sender write ] keep
-    "> " blue write-color
+    "> " dark-blue write-color
     trailing>> write ;
 
 M: notice write-irc
-    [ type>> blue write-color ] keep
+    [ type>> dark-blue write-color ] keep
-    ": " blue write-color
+    ": " dark-blue write-color
     trailing>> write ;
 
 TUPLE: own-message message nick timestamp ;
@@ -57,9 +58,9 @@ TUPLE: own-message message nick timestamp ;
     now own-message boa ;
 
 M: own-message write-irc
-    "<" blue write-color
+    "<" dark-blue write-color
     [ nick>> bold font-style associate format ] keep
-    "> " blue write-color
+    "> " dark-blue write-color
     message>> write ;
 
 M: join write-irc
@@ -87,26 +88,23 @@ M: kick write-irc
     " from the channel" dark-red write-color
     trailing>> dot-or-parens dark-red write-color ;
 
-: full-mode ( message -- mode )
-    parameters>> rest " " sjoin ;
-
 M: mode write-irc
-    "* " blue write-color
+    "* " dark-blue write-color
-    [ irc-message-sender write ] keep
+    [ name>> write ] keep
-    " has applied mode " blue write-color
+    " has applied mode " dark-blue write-color
-    [ full-mode write ] keep
+    [ mode>> write ] keep
-    " to " blue write-color
+    " to " dark-blue write-color
-    channel>> write ;
+    parameter>> write ;
 
 M: nick write-irc
-    "* " blue write-color
+    "* " dark-blue write-color
     [ irc-message-sender write ] keep
     " is now known as " blue write-color
     trailing>> write ;
 
 M: unhandled write-irc
     "UNHANDLED: " write
-    line>> blue write-color ;
+    line>> dark-blue write-color ;
 
 M: irc-end write-irc
     drop "* You have left IRC" dark-red write-color ;
@@ -121,7 +119,10 @@ M: irc-chat-end write-irc
     drop ;
 
 M: irc-message write-irc
-    drop ; ! catch all unimplemented writes, THIS WILL CHANGE    
+    "UNIMPLEMENTED" write
+    [ class pprint ] keep
+    ": " write
+    line>> dark-blue write-color ;
 
 GENERIC: time-happened ( message -- timestamp )
 

extra/lint/lint-tests.factor

@@ -0,0 +1,14 @@
+USING: io lint kernel math tools.test ;
+IN: lint.tests
+
+! Don't write code like this
+: lint1 ( -- ) [ "hi" print ] [ ] if ; ! when
+
+[ { { lint1 { [ [ ] if ] } } } ] [ \ lint1 lint-word ] unit-test
+
+: lint2 ( n -- n' ) 1 + ; ! 1+
+[ { [ 1 + ] } ] [ \ lint2 lint ] unit-test
+
+: lint3 dup -rot ; ! tuck
+
+[ { { lint3 { [ dup -rot ] } } } ] [ \ lint3 lint-word ] unit-test

extra/lint/lint.factor

@@ -0,0 +1,179 @@
+! Copyright (C) 2007, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.accessors arrays assocs
+combinators.short-circuit fry hashtables html.elements io
+kernel math namespaces prettyprint quotations sequences
+sequences.deep sets slots.private vectors vocabs words
+kernel.private ;
+IN: lint
+
+SYMBOL: def-hash
+SYMBOL: def-hash-keys
+
+: set-hash-vector ( val key hash -- )
+    2dup at -rot [ ?push ] 2dip set-at ;
+
+: more-defs ( hash -- )
+    {
+        { -rot [ swap >r swap r> ] }
+        { -rot [ swap swapd ] }
+        { rot [ >r swap r> swap ] }
+        { rot [ swapd swap ] }
+        { over [ dup swap ] }
+        { tuck [ dup -rot ] }
+        { swapd [ >r swap r> ] }
+        { 2nip [ nip nip ] }
+        { 2drop [ drop drop ] }
+        { 3drop [ drop drop drop ] }
+        { pop* [ pop drop ] }
+        { when [ [ ] if ] }
+        { >boolean [ f = not ] }
+    } swap '[ first2 _ set-hash-vector ] each ;
+
+: accessor-words ( -- seq )
+{
+    alien-signed-1 alien-signed-2 alien-signed-4 alien-signed-8
+    alien-unsigned-1 alien-unsigned-2 alien-unsigned-4 alien-unsigned-8
+    <displaced-alien> alien-unsigned-cell set-alien-signed-cell
+    set-alien-unsigned-1 set-alien-signed-1 set-alien-unsigned-2
+    set-alien-signed-2 set-alien-unsigned-4 set-alien-signed-4
+    set-alien-unsigned-8 set-alien-signed-8
+    alien-cell alien-signed-cell set-alien-cell set-alien-unsigned-cell
+    set-alien-float alien-float
+} ;
+
+: trivial-defs
+    {
+        [ drop ] [ 2array ]
+        [ bitand ]
+
+        [ . ]
+        [ get ]
+        [ t ] [ f ]
+        [ { } ]
+        [ drop f ]
+        [ "cdecl" ]
+        [ first ] [ second ] [ third ] [ fourth ]
+        [ ">" write-html ] [ "/>" write-html ]
+    } ;
+
+! ! Add definitions
+H{ } clone def-hash set-global
+
+all-words [
+    dup def>> dup callable?
+    [ def-hash get-global set-hash-vector ] [ drop ] if
+] each
+
+! ! Remove definitions
+
+! Remove empty word defs
+def-hash get-global [ drop empty? not ] assoc-filter
+
+! Remove constants [ 1 ]
+[ drop { [ length 1 = ] [ first number? ] } 1&& not ] assoc-filter
+
+! Remove words that are their own definition
+[ [ [ def>> ] [ 1quotation ] bi = not ] filter ] assoc-map
+
+! Remove set-alien-cell, etc.
+[ drop [ accessor-words diff ] keep [ length ] bi@ = ] assoc-filter
+
+! Remove trivial defs
+[ drop trivial-defs member? not ] assoc-filter
+
+! Remove numbers only defs
+[ drop [ number? ] all? not ] assoc-filter
+
+! Remove curry only defs
+[ drop [ \ curry = ] all? not ] assoc-filter
+
+! Remove tag defs
+[
+    drop {
+            [ length 3 = ]
+            [ first \ tag = ] [ second number? ] [ third \ eq? = ]
+    } 1&& not
+] assoc-filter
+
+[
+    drop {
+        [ [ wrapper? ] deep-contains? ]
+        [ [ hashtable? ] deep-contains? ]
+    } 1|| not
+] assoc-filter
+
+! Remove n m shift defs
+[
+    drop dup length 3 = [
+        [ first2 [ number? ] both? ]
+        [ third \ shift = ] bi and not
+    ] [ drop t ] if
+] assoc-filter 
+
+! Remove [ n slot ]
+[
+    drop dup length 2 =
+    [ first2 [ number? ] [ \ slot = ] bi* and not ] [ drop t ] if
+] assoc-filter
+
+
+dup more-defs
+
+[ def-hash set-global ] [ keys def-hash-keys set-global ] bi
+
+: find-duplicates ( -- seq )
+    def-hash get-global [ nip length 1 > ] assoc-filter ;
+
+GENERIC: lint ( obj -- seq )
+
+M: object lint ( obj -- seq ) drop f ;
+
+: subseq/member? ( subseq/member seq -- ? )
+    { [ start ] [ member? ] } 2|| ;
+
+M: callable lint ( quot -- seq )
+    [ def-hash-keys get-global ] dip '[ _ subseq/member? ] filter ;
+
+M: word lint ( word -- seq )
+    def>> dup callable? [ lint ] [ drop f ] if ;
+
+: word-path. ( word -- )
+    [ vocabulary>> ] [ unparse ] bi ":" glue print ;
+
+: 4bl ( -- ) bl bl bl bl ;
+
+: (lint.) ( pair -- )
+    first2 [ word-path. ] dip [
+        [ 4bl .  "-----------------------------------" print ]
+        [ def-hash get-global at [ 4bl word-path. ] each nl ] bi
+    ] each nl nl ;
+
+: lint. ( alist -- ) [ (lint.) ] each ;
+
+GENERIC: run-lint ( obj -- obj )
+
+: (trim-self) ( val key -- obj ? )
+    def-hash get-global at*
+    [ dupd remove empty? not ] [ drop f ] if ;
+
+: trim-self ( seq -- newseq )
+    [ [ (trim-self) ] filter ] assoc-map ;
+
+: filter-symbols ( alist -- alist )
+    [
+        nip first dup def-hash get-global at
+        [ first ] bi@ literalize = not
+    ] assoc-filter ;
+
+M: sequence run-lint ( seq -- seq )
+    [ dup lint ] { } map>assoc trim-self
+    [ second empty? not ] filter filter-symbols ;
+
+M: word run-lint ( word -- seq ) 1array run-lint ;
+
+: lint-all ( -- seq ) all-words run-lint dup lint. ;
+
+: lint-vocab ( vocab -- seq ) words run-lint dup lint. ;
+
+: lint-word ( word -- seq ) 1array run-lint dup lint. ;

extra/math/finance/finance-docs.factor

@@ -1,8 +1,6 @@
-! Copyright (C) 2008 John Benediktsson
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license
-
+USING: help.markup help.syntax math ;
-USING: help.markup help.syntax ;
-
 IN: math.finance
 
 HELP: sma
@@ -32,3 +30,59 @@ HELP: momentum
     { $list "MOM[t] = SEQ[t] - SEQ[t-n]" }
 } ;
 
+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." } ;
+
+ARTICLE: "time-period-calculations" "Calculations over periods of time"
+{ $subsection monthly }
+{ $subsection semimonthly }
+{ $subsection biweekly }
+{ $subsection weekly }
+{ $subsection daily-360 }
+{ $subsection daily-365 } ;
+
+ARTICLE: "math.finance" "Financial math"
+"The " { $vocab-link "math.finance" } " vocabulary contains financial calculation words." $nl
+"Calculating payroll over periods of time:"
+{ $subsection "time-period-calculations" } ;
+
+ABOUT: "math.finance"

extra/math/finance/finance-tests.factor

@@ -6,3 +6,4 @@ IN: math.finance.tests
 
 [ { 1 3 1 } ] [ { 1 3 2 6 3 } 2 momentum ] unit-test
 
+[ 4+1/6 ] [ 100 semimonthly ] unit-test

extra/math/finance/finance.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2008 John Benediktsson.
+! Copyright (C) 2008 John Benediktsson, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays assocs kernel grouping sequences shuffle
 math math.functions math.statistics math.vectors ;
@@ -26,3 +26,14 @@ PRIVATE>
 : momentum ( seq n -- newseq )
     [ tail-slice ] 2keep [ dup length ] dip - head-slice v- ;
 
+: 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

extra/math/numerical-integration/numerical-integration.factor

@@ -4,15 +4,16 @@ USING: arrays kernel sequences namespaces make math math.ranges
 math.vectors vectors ;
 IN: math.numerical-integration
 
-SYMBOL: num-steps 180 num-steps set-global
+SYMBOL: num-steps
+
+180 num-steps set-global
 
 : setup-simpson-range ( from to -- frange )
     2dup swap - num-steps get / <range> ;
 
 : generate-simpson-weights ( seq -- seq )
-    { 1 4 }
+    length 2 / 2 - { 2 4 } <repetition> concat
-    swap length 2 / 2 - { 2 4 } <repetition> concat
+    { 1 4 } { 1 } surround ;
-    { 1 } 3append ;
 
 : integrate-simpson ( from to f -- x )
     [ setup-simpson-range dup ] dip 

extra/multi-methods/multi-methods.factor

@@ -102,7 +102,7 @@ SYMBOL: total
         { 0 [ [ dup ] ] }
         { 1 [ [ over ] ] }
         { 2 [ [ pick ] ] }
-        [ 1- picker [ >r ] swap [ r> swap ] 3append ]
+        [ 1- picker [ >r ] [ r> swap ] surround ]
     } case ;
 
 : (multi-predicate) ( class picker -- quot )