Merge git://factorcode.org/git/factor

core/alien/compiler/compiler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generator generator.registers generator.fixup
 hashtables kernel math namespaces sequences words
-inference.backend inference.dataflow system math.functions
+inference.backend inference.dataflow system
 math.parser classes alien.arrays alien.c-types alien.structs
 alien.syntax cpu.architecture alien inspector quotations assocs
 kernel.private threads continuations.private libc combinators ;

core/alien/structs/structs.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic hashtables kernel kernel.private math
 namespaces parser sequences strings words libc slots
-alien.c-types math.functions math.vectors cpu.architecture ;
+alien.c-types cpu.architecture ;
 IN: alien.structs
 
 : align-offset ( offset type -- offset )

core/arrays/arrays-tests.factor

@@ -1,6 +1,5 @@
 USING: arrays kernel sequences sequences.private growable
-tools.test vectors layouts system math math.functions
+tools.test vectors layouts system math vectors.private ;
-vectors.private ;
 IN: temporary
 
 [ -2 { "a" "b" "c" } nth ] unit-test-fails

core/bootstrap/compiler/compiler.factor

@@ -5,7 +5,6 @@ hashtables.private sequences.private math tuples.private
 growable namespaces.private alien.remote-control assocs
 words generator command-line vocabs io prettyprint libc ;
 
-"bootstrap.math" vocab [
 "cpu." cpu append require
 
 global [ { "compiler" } add-use ] bind
@@ -49,4 +48,3 @@ words generator command-line vocabs io prettyprint libc ;
 } [ compile ] each
 
 [ recompile ] parse-hook set-global
-] when

core/bootstrap/image/image.factor

@@ -4,7 +4,7 @@ USING: alien arrays bit-arrays byte-arrays generic assocs
 hashtables assocs hashtables.private io kernel kernel.private
 math namespaces parser prettyprint sequences sequences.private
 strings sbufs vectors words quotations assocs system layouts
-splitting growable math.functions classes tuples words.private
+splitting growable classes tuples words.private
 io.binary io.files vocabs vocabs.loader source-files
 definitions debugger float-arrays quotations.private
 combinators.private combinators ;
@@ -160,7 +160,7 @@ GENERIC: ' ( obj -- ptr )
     { } unfold ;
 
 : emit-bignum ( n -- )
-    [ 0 < 1 0 ? ] keep abs bignum>seq
+    dup 0 < [ 1 swap neg ] [ 0 swap ] if bignum>seq
     dup length 1+ emit-fixnum
     swap emit emit-seq ;
 

core/bootstrap/stage1.factor

@@ -23,6 +23,7 @@ vocabs.loader system ;
     \ boot ,
 
     "math.integers" require
+    "math.floats" require
     "memory" require
     "io.streams.c" require
     "vocabs.loader" require

core/bootstrap/stage2.factor

@@ -19,11 +19,14 @@ IN: bootstrap.stage2
 
     parse-command-line
 
+    all-words [ dup ] H{ } map>assoc changed-words set-global
+
+    "-no-crossref" cli-args member? [
         "Cross-referencing..." print flush
-    H{ } clone changed-words set-global
         H{ } clone crossref set-global
         xref-words
         xref-sources
+    ] unless
 
     ! Set dll paths
     wince? [ "windows.ce" require ] when
@@ -34,12 +37,10 @@ IN: bootstrap.stage2
     ] [
         "listener" require
         "none" require
+        "listener" use+
     ] if
 
     [
-        ! Compile everything if compiler is loaded
-        all-words [ changed-word ] each
-
         "exclude" "include"
         [ get-global " " split [ empty? not ] subset ] 2apply
         seq-diff

core/bootstrap/syntax.factor

@@ -20,7 +20,6 @@ f swap set-vocab-source-loaded?
     "B{"
     "C:"
     "CHAR:"
-    "C{"
     "DEFER:"
     "F{"
     "FORGET:"

core/compiler/test/curry.factor

@@ -7,8 +7,8 @@ IN: temporary
 [ 3 ] [ [ 5 2 [ - ] 2curry call ] compile-1 ] unit-test
 [ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-1 ] unit-test
 [ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-1 ] unit-test
-[ 1/3 ] [ 5 2 [ [ - ] 2curry 1 swap call / ] compile-1 ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-1 ] unit-test
-[ 1/3 ] [ 5 2 [ [ - ] 2curry >r 1 r> call / ] compile-1 ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-1 ] unit-test
 
 [ -10 -20 ] [ 10 20 -1 [ [ * ] curry 2apply ] compile-1 ] unit-test
 

core/compiler/test/ifte.factor

@@ -33,12 +33,12 @@ math.private combinators ;
 
 : dead-code-rec
     t [
-        C{ 3 2 }
+        3.2
     ] [
         dead-code-rec
     ] if ;
 
-[ C{ 3 2 } ] [ dead-code-rec ] unit-test
+[ 3.2 ] [ dead-code-rec ] unit-test
 
 : one-rec [ f one-rec ] [ "hi" ] if ;
 

core/compiler/test/intrinsics.factor

@@ -1,11 +1,10 @@
 IN: temporary
 USING: arrays compiler kernel kernel.private math
-math.private sequences strings tools.test words continuations
+math.constants math.private sequences strings tools.test words
-sequences.private hashtables.private byte-arrays
+continuations sequences.private hashtables.private byte-arrays
-strings.private system random math.vectors layouts
+strings.private system random layouts vectors.private
-vectors.private sbufs.private strings.private slots.private
+sbufs.private strings.private slots.private alien alien.c-types
-alien alien.c-types alien.syntax namespaces libc math.constants
+alien.syntax namespaces libc ;
-math.functions ;
 
 ! Make sure that intrinsic ops compile to correct code.
 [ ] [ 1 [ drop ] compile-1 ] unit-test
@@ -327,9 +326,13 @@ cell 8 = [
     [ 500 <byte-array> length ] compile-1
 ] unit-test
 
-[ C{ 1 2 } ] [ 1 2 [ <complex> ] compile-1 ] unit-test
+[ 1 2 ] [
+    1 2 [ <complex> ] compile-1 dup real swap imaginary
+] unit-test
 
-[ 1/2 ] [ 1 2 [ <ratio> ] compile-1 ] unit-test
+[ 1 2 ] [
+    1 2 [ <ratio> ] compile-1 dup numerator swap denominator
+] unit-test
 
 [ \ + ] [ \ + [ <wrapper> ] compile-1 ] unit-test
 
@@ -412,8 +415,8 @@ cell 8 = [
 [ t ] [ pi <double> [ { byte-array } declare *double ] compile-1 pi = ] unit-test
 
 ! Silly
-[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - abs 0.001 < ] unit-test
+[ t ] [ pi 4 <byte-array> [ [ { float byte-array } declare 0 set-alien-float ] compile-1 ] keep *float pi - -0.001 0.001 between? ] unit-test
-[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - abs 0.001 < ] unit-test
+[ t ] [ pi <float> [ { byte-array } declare *float ] compile-1 pi - -0.001 0.001 between? ] unit-test
 
 [ t ] [ pi 8 <byte-array> [ [ { float byte-array } declare 0 set-alien-double ] compile-1 ] keep *double pi = ] unit-test
 

core/compiler/test/optimizer.factor

@@ -208,10 +208,6 @@ M: slice foozul ;
 [ -5 ] [ 5 [ -1 * ] compile-1 ] unit-test
 [ -5 ] [ 5 [ -1 swap * ] compile-1 ] unit-test
 
-[ 5 ] [ 5 [ 1 / ] compile-1 ] unit-test
-[ 1/5 ] [ 5 [ 1 swap / ] compile-1 ] unit-test
-[ -5 ] [ 5 [ -1 / ] compile-1 ] unit-test
-
 [ 0 ] [ 5 [ 1 mod ] compile-1 ] unit-test
 [ 0 ] [ 5 [ 1 rem ] compile-1 ] unit-test
 
@@ -246,8 +242,6 @@ M: slice foozul ;
 [ t ] [ 5 [ dup number= ] compile-1 ] unit-test
 [ t ] [ \ vector [ \ vector = ] compile-1 ] unit-test
 
-[ 3 ] [ 10/3 [ { ratio } declare 1 /i ] compile-1 ] unit-test
-
 GENERIC: detect-number ( obj -- obj )
 M: number detect-number ;
 
@@ -275,7 +269,11 @@ USE: sorting.private
 ] unit-test
 
 ! Regression
-[ 1 2 { real imaginary } ] [
+TUPLE: silly-tuple a b ;
-    C{ 1 2 }
+
-    [ { real imaginary } [ get-slots ] keep ] compile-1
+[ 1 2 { silly-tuple-a silly-tuple-b } ] [
+    T{ silly-tuple f 1 2 }
+    [
+        { silly-tuple-a silly-tuple-b } [ get-slots ] keep
+    ] compile-1
 ] unit-test

core/compiler/test/stack-trace.factor

@@ -27,8 +27,8 @@ words splitting ;
     [ { 1 "hi" } bleh ] catch drop \ + stack-trace-contains?
 ] unit-test
     
-[ f t ] [
+[ t f ] [
-    [ { C{ 1 2 } } bleh ] catch drop
+    [ { "hi" } bleh ] catch drop
     \ + stack-trace-contains?
     \ > stack-trace-contains?
 ] unit-test

core/compiler/test/templates.factor

@@ -1,9 +1,9 @@
 ! Black box testing of templating optimization
 
 USING: arrays compiler kernel kernel.private math
-hashtables.private math.private math.ratios.private namespaces
+hashtables.private math.private namespaces sequences
-sequences sequences.private tools.test namespaces.private
+sequences.private tools.test namespaces.private slots.private
-slots.private combinators.private byte-arrays alien layouts ;
+combinators.private byte-arrays alien layouts ;
 IN: temporary
 
 ! Oops!
@@ -37,41 +37,14 @@ unit-test
 
 : foo ;
 
-[ 4 4 ]
+[ 5 5 ]
-[ 1/2 [ tag [ foo ] keep ] compile-1 ]
+[ 1.2 [ tag [ foo ] keep ] compile-1 ]
 unit-test
 
 [ 1 2 2 ]
-[ 1/2 [ dup 1 slot swap 2 slot [ foo ] keep ] compile-1 ]
+[ { 1 2 } [ dup 2 slot swap 3 slot [ foo ] keep ] compile-1 ]
 unit-test
 
-[ 41 5 4 ] [
-    5/4 4/5 [
-        dup ratio? [
-            over ratio? [
-                2dup 2>fraction >r * swap r> * swap
-                + -rot denominator swap denominator
-            ] [
-                2drop f f f
-            ] if
-        ] [
-            2drop f f f
-        ] if
-    ] compile-1
-] unit-test
-
-: jxyz
-    over bignum? [
-        dup ratio? [
-            [ >fraction ] 2apply swapd
-            >r 2array swap r> 2array swap
-        ] when
-    ] when ;
-
-\ jxyz compile
-
-[ { 1 2 } { 1 1 } ] [ 1 >bignum 1/2 jxyz ] unit-test
-
 [ 3 ]
 [
     global [ 3 \ foo set ] bind

core/cpu/arm/4/4.factor

@@ -6,7 +6,7 @@ math math.private namespaces sequences words quotations
 byte-arrays hashtables.private hashtables generator
 generator.registers generator.fixup sequences.private
 strings.private ;
-IN: cpu.arm5.intrinsics
+IN: cpu.arm4
 
 : (%char-slot)
     "out" operand string-offset MOV

core/cpu/arm/4/summary.txt

@@ -0,0 +1 @@
+Additional compiler intrinsics for ARM4

core/cpu/arm/allot/allot.factor

@@ -1,49 +1,46 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cpu.architecture cpu.arm.assembler
-cpu.arm.architecture namespaces math math.functions sequences
+cpu.arm.architecture namespaces math sequences
 generator generator.registers generator.fixup system layouts
 alien ;
 IN: cpu.arm.allot
 
 : load-zone-ptr ( reg -- ) "nursery" f rot %alien-global ;
 
-: object@ "allot-tmp" operand swap cells <+> ;
-
 : %allot ( header size -- )
     #! Store a pointer to 'size' bytes allocated from the
-    #! nursery in allot-tmp.
+    #! nursery in R11
     8 align ! align the size
     R12 load-zone-ptr ! nusery -> r12
-    "allot-tmp" operand R12 cell <+> LDR ! nursery.here -> allot-tmp
+    R11 R12 cell <+> LDR ! nursery.here -> r11
-    "allot-tmp" operand dup pick ADD ! increment allot-tmp
+    R11 R11 pick ADD ! increment r11
-    "allot-tmp" operand R12 cell <+> STR ! allot-tmp -> nursery.here
+    R11 R12 cell <+> STR ! r11 -> nursery.here
-    "allot-tmp" operand dup rot SUB ! old value
+    R11 R11 rot SUB ! old value
     R12 swap type-number tag-header MOV ! compute header
-    R12 0 object@ STR ! store header
+    R12 R11 0 <+> STR ! store header
     ;
     
-: %tag-allot ( tag -- )
+: %store-tagged ( reg tag -- )
-    "allot-tmp" operand dup rot tag-number ORR
+    >r dup fresh-object v>operand R11 r> tag-number ORR ;
-    "allot-tmp" get fresh-object ;
 
 : %allot-bignum ( #digits -- )
     #! 1 cell header, 1 cell length, 1 cell sign, + digits
     #! length is the # of digits + sign
     bignum over 3 + cells %allot
     R12 swap 1+ v>operand MOV ! compute the length
-    R12 1 object@ STR ! store the length
+    R12 R11 cell <+> STR ! store the length
     ;
 
-: %allot-bignum-signed-1 ( reg -- )
+: %allot-bignum-signed-1 ( dst src -- )
     #! on entry, reg is a 30-bit quantity sign-extended to
     #! 32-bits.
-    #! exits with tagged ptr to bignum in allot-tmp.
+    #! exits with tagged ptr to bignum in reg.
     [
         "end" define-label
         ! is it zero?
         dup v>operand 0 CMP
-        0 >bignum "allot-tmp" operand EQ load-indirect
+        0 >bignum pick EQ load-literal
         "end" get EQ B
         ! ! it is non-zero
         1 %allot-bignum
@@ -56,29 +53,27 @@ IN: cpu.arm.allot
         ! positive sign
         R12 0 GE MOV
         ! store sign
-        R12 2 object@ STR
+        R12 R11 2 cells <+> STR
         ! store the number
-        v>operand 3 object@ STR
+        v>operand R11 3 cells <+> STR
         ! tag the bignum, store it in reg
-        bignum %tag-allot
+        bignum %store-tagged
         "end" resolve-label
     ] with-scope ;
 
-: %allot-alien ( ptr -- )
+M: arm-backend %box-alien ( dst src -- )
-    #! Tagged pointer to alien is in allot-tmp on exit.
-    [
-        "temp" set
     "end" define-label
-        "temp" operand 0 CMP
+    dup v>operand 0 CMP
-        "allot-tmp" operand f v>operand EQ MOV
+    over v>operand f v>operand EQ MOV
     "end" get EQ B
     alien 4 cells %allot
-        "temp" operand 2 object@ STR
+    ! Store offset
-        "temp" operand f v>operand MOV
+    v>operand R11 3 cells <+> STR
-        "temp" operand 1 object@ STR
+    R12 f v>operand MOV
-        "temp" operand 0 MOV
+    ! Store expired slot
-        "temp" operand 3 object@ STR
+    R12 R11 1 cells <+> STR
+    ! Store underlying-alien slot
+    R12 R11 2 cells <+> STR
     ! Store tagged ptr in reg
-        object %tag-allot
+    object %store-tagged
-        "end" resolve-label
+    "end" resolve-label ;
-    ] with-scope ;

core/cpu/arm/architecture/architecture.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays cpu.arm.assembler compiler
-kernel kernel.private math math.functions namespaces words
+kernel kernel.private math namespaces words
 words.private generator.registers generator.fixup generator
 cpu.architecture system layouts ;
 IN: cpu.arm.architecture
@@ -9,8 +9,8 @@ IN: cpu.arm.architecture
 TUPLE: arm-backend ;
 
 ! ARM register assignments:
-! R0, R1, R2, R3 integer vregs
+! R0-R4, R7-R10 integer vregs
-! R12 temporary
+! R11, R12 temporary
 ! R5 data stack
 ! R6 retain stack
 ! R7 primitives
@@ -22,7 +22,7 @@ M: temp-reg v>operand drop R12 ;
 
 M: int-regs return-reg drop R0 ;
 M: int-regs param-regs drop { R0 R1 R2 R3 } ;
-M: int-regs vregs drop { R0 R1 R2 R3 } ;
+M: int-regs vregs drop { R0 R1 R2 R3 R4 R7 R8 R9 R10 } ;
 
 ! No FPU support yet
 M: float-regs param-regs drop { } ;
@@ -44,15 +44,27 @@ M: immediate load-literal
         v>operand load-indirect
     ] if ;
 
-M: arm-backend stack-frame ( n -- i ) 4 + 8 align ;
+: lr-save ( n -- i ) cell - ;
+: next-save ( n -- i ) 2 cells - ;
+: xt-save ( n -- i ) 3 cells - ;
+: factor-area-size 5 cells ;
+
+M: arm-backend stack-frame ( n -- i )
+    factor-area-size + 8 align ;
+
+M: arm-backend %save-xt ( -- )
+    R12 PC 8 SUB ;
 
 M: arm-backend %prologue ( n -- )
-    LR SP 4 <-> STR
+    SP SP pick SUB
-    SP SP rot stack-frame SUB ;
+    R11 over MOV
+    R11 SP pick next-save <+> STR
+    R12 SP pick xt-save <+> STR
+    LR SP rot lr-save <+> STR ;
 
 M: arm-backend %epilogue ( n -- )
-    SP SP rot stack-frame ADD
+    LR SP pick lr-save <+> LDR
-    LR SP 4 <-> LDR ;
+    SP SP rot ADD ;
 
 : compile-dlsym ( symbol dll reg -- )
     [
@@ -83,26 +95,29 @@ M: arm-backend %profiler-prologue ( word -- )
     R0 R12 profile-count-offset <+> STR
     "end" resolve-label ;
 
-: primitive-addr ( word dst -- )
+M: arm-backend %call-label ( label -- ) BL ;
-    #! Load a word address into dst.
-    R7 rot word-primitive cells <+> LDR ;
 
-M: arm-backend %call ( label -- )
+M: arm-backend %jump-label ( label -- ) B ;
-    #! Far C call for primitives, near C call for compiled defs.
-    dup primitive? [ R0 primitive-addr R0 BLX ] [ BL ] if ;
 
-M: arm-backend %jump-label ( label -- )
+: %prepare-primitive ( word -- )
-    #! For tail calls. IP not saved on C stack.
+    #! Save stack pointer to stack_chain->callstack_top, load XT
-    #! WARNING: don't clobber LR here!
+    R1 SP MOV
-    dup primitive? [ PC primitive-addr ] [ B ] if ;
+    T{ temp-reg } load-literal
+    R12 R12 word-xt-offset <+> LDR ;
+
+M: arm-backend %call-primitive ( word -- )
+    %prepare-primitive R12 BLX ;
+
+M: arm-backend %jump-primitive ( word -- )
+    %prepare-primitive R12 BX ;
 
 M: arm-backend %jump-t ( label -- )
-    "flag" operand object tag-number CMP NE B ;
+    "flag" operand f v>operand CMP NE B ;
 
 : (%dispatch) ( word-table# reg -- )
     #! Load jump table target address into reg.
-    "n" operand PC "n" operand 1 <LSR> ADD
+    "scratch" operand PC "n" operand 1 <LSR> ADD
-    "n" operand 0 <+> LDR
+    "scratch" operand 0 <+> LDR
     rc-indirect-arm rel-dispatch ;
 
 M: arm-backend %call-dispatch ( word-table# -- )
@@ -112,7 +127,6 @@ M: arm-backend %call-dispatch ( word-table# -- )
     ] H{
         { +input+ { { f "n" } } }
         { +scratch+ { { f "scratch" } } }
-        { +clobber+ { "n" } }
     } with-template ;
 
 M: arm-backend %jump-dispatch ( word-table# -- )
@@ -121,21 +135,16 @@ M: arm-backend %jump-dispatch ( word-table# -- )
         PC (%dispatch)
     ] H{
         { +input+ { { f "n" } } }
-        { +clobber+ { "n" } }
+        { +scratch+ { { f "scratch" } } }
     } with-template ;
 
 M: arm-backend %return ( -- ) %epilogue-later PC LR MOV ;
 
 M: arm-backend %unwind drop %return ;
 
-: (%peek/replace)
+M: arm-backend %peek >r v>operand r> loc>operand LDR ;
-    >r drop >r v>operand r> loc>operand r> execute ;
 
-M: int-regs (%peek) \ LDR (%peek/replace) ;
+M: arm-backend %replace >r v>operand r> loc>operand STR ;
-M: int-regs (%replace) \ STR (%peek/replace) ;
-
-M: arm-backend %move-int>int ( dst src -- )
-    [ v>operand ] 2apply MOV ;
 
 : (%inc) ( n reg -- )
     dup rot cells dup 0 < [ neg SUB ] [ ADD ] if ;
@@ -215,11 +224,13 @@ M: arm-backend %box-small-struct ( size -- )
     R2 swap MOV
     "box_small_struct" f %alien-invoke ;
 
+: temp@ stack-frame* factor-area-size - swap - ;
+
 : struct-return@ ( size n -- n )
     [
         stack-frame* +
     ] [
-        stack-frame* swap - cell -
+        stack-frame* factor-area-size - swap -
     ] ?if ;
 
 M: arm-backend %prepare-box-struct ( size -- )
@@ -239,6 +250,15 @@ M: arm-backend %box-large-struct ( n size -- )
 M: arm-backend struct-small-enough? ( size -- ? )
     wince? [ drop f ] [ 4 <= ] if ;
 
+M: arm-backend %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 R12 %alien-global
+    SP R12 0 <+> STR
+    ds-reg R12 8 <+> STR
+    rs-reg R12 12 <+> STR ;
+
 M: arm-backend %alien-invoke ( symbol dll -- )
     ! Load target address
     R12 PC 4 <+> LDR
@@ -249,15 +269,13 @@ M: arm-backend %alien-invoke ( symbol dll -- )
     ! The target address
     0 , rc-absolute rel-dlsym ;
 
-: temp@ SP stack-frame* 2 cells - <+> ;
-
 M: arm-backend %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
-    R0 temp@ STR ;
+    R0 SP cell temp@ <+> STR ;
 
 M: arm-backend %alien-indirect ( -- )
-    IP temp@ LDR
+    R12 SP cell temp@ <+> LDR
-    IP BLX ;
+    R12 BLX ;
 
 M: arm-backend %alien-callback ( quot -- )
     R0 load-indirect
@@ -266,11 +284,11 @@ M: arm-backend %alien-callback ( quot -- )
 M: arm-backend %callback-value ( ctype -- )
     ! Save top of data stack
     %prepare-unbox
-    R0 temp@ STR
+    R0 SP cell temp@ <+> STR
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
     ! Place former top of data stack in R0
-    R0 temp@ LDR
+    R0 SP cell temp@ <+> LDR
     ! Unbox R0
     unbox-return ;
 
@@ -291,37 +309,50 @@ M: long-long-type c-type-stack-align? drop wince? not ;
 M: arm-backend fp-shadows-int? ( -- ? ) f ;
 
 ! Alien intrinsics
-: add-alien-offset "offset" operand tag-bits get <ASR> ADD ;
+M: arm-backend %unbox-byte-array ( dst src -- )
+    [ v>operand ] 2apply byte-array-offset ADD ;
 
-: (%unbox-alien) <+> roll call ; inline
+M: arm-backend %unbox-alien ( dst src -- )
+    [ v>operand ] 2apply alien-offset <+> LDR ;
 
-M: arm-backend %unbox-byte-array ( quot src -- )
+M: arm-backend %unbox-f ( dst src -- )
-    "address" operand "alien" operand add-alien-offset
+    drop v>operand 0 MOV ;
-    "address" operand alien-offset (%unbox-alien) ;
 
-M: arm-backend %unbox-alien ( quot src -- )
+M: arm-backend %unbox-any-c-ptr ( dst src -- )
-    "address" operand "alien" operand alien-offset <+> LDR
+    #! We need three registers here. R11 and R12 are reserved
-    "address" operand dup add-alien-offset
+    #! temporary registers. The third one is R14, which we have
-    "address" operand 0 (%unbox-alien) ;
+    #! to save/restore.
-
-M: arm-backend %unbox-f ( quot src -- )
-    "offset" operand dup %untag-fixnum
-    "offset" operand 0 (%unbox-alien) ;
-
-M: arm-backend %complex-alien-accessor ( quot src -- )
-    "is-f" define-label
-    "is-alien" define-label
     "end" define-label
-    "alien" operand f v>operand CMP
+    "start" define-label
-    "is-f" get EQ B
+    ! Save R14.
-    "address" operand "alien" operand header-offset neg <-> LDR
+    R14 SP 4 <-> STR
-    "address" operand alien type-number tag-header CMP
+    ! Address is computed in R11
-    "is-alien" get EQ B
+    R11 0 MOV
-    [ %unbox-byte-array ] 2keep
+    ! Load object into R12
-    "end" get B
+    R12 swap v>operand MOV
-    "is-alien" resolve-label
+    ! We come back here with displaced aliens
-    [ %unbox-alien ] 2keep
+    "start" resolve-label
-    "end" get B
+    ! Is the object f?
-    "is-f" resolve-label
+    R12 f v>operand CMP
-    %unbox-f
+    ! If so, done
-    "end" resolve-label ;
+    "end" get EQ B
+    ! Is the object an alien?
+    R14 R12 header-offset <+/-> LDR
+    R14 alien type-number tag-header CMP
+    ! Add byte array address to address being computed
+    R11 R11 R12 NE ADD
+    ! Add an offset to start of byte array's data area
+    R11 R11 byte-array-offset NE ADD
+    "end" get NE B
+    ! If alien, load the offset
+    R14 R12 alien-offset <+/-> LDR
+    ! Add it to address being computed
+    R11 R11 R14 ADD
+    ! Now recurse on the underlying alien
+    R12 R12 underlying-alien-offset <+/-> LDR
+    "start" get B
+    "end" resolve-label
+    ! Done, store address in destination register
+    v>operand R11 MOV
+    ! Restore R14.
+    R14 SP 4 <-> LDR ;

core/cpu/arm/arm.factor

@@ -1,7 +1,9 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types kernel math namespaces
-cpu.architecture cpu.arm.architecture cpu.arm.intrinsics
+cpu.architecture cpu.arm.architecture cpu.arm.assembler
-generator generator.registers continuations compiler io
+cpu.arm.intrinsics generator generator.registers continuations
-vocabs.loader ;
+compiler io vocabs.loader sequences ;
 
 ! EABI passes floats in integer registers.
 [ alien-float ]
@@ -24,27 +26,29 @@ vocabs.loader ;
 
 T{ arm-backend } compiler-backend set-global
 
-: (detect-arm5) ;
+! We don't auto-detect since that would require us to support
-
+! illegal instruction traps. This works on Linux but not on
-\ (detect-arm5) [
+! Windows CE.
-    ! The LDRH word is defined in the module we conditionally
-    ! load below...
-    ! R0 PC 0 <+> LDRH
-    HEX: e1df00b0 ,
-] H{
-    { +scratch+ { { 0 "scratch" } } }
-} define-intrinsic
-
-: detect-arm5 (detect-arm5) ;
-
-: arm5? ( -- ? ) [ detect-arm5 ] catch not ;
 
 "arm-variant" get [
-    \ detect-arm5 compile
+    "ARM variant: " write "arm-variant" get print
-    "Detecting ARM architecture variant..." print
+] [
-    arm5? "arm5" "arm3" ? "arm-variant" set
+    "==========" print
-] unless
+    "You should specify the -arm-variant=<variant> switch." print
+    "<variant> can be one of arm3, arm4, arm4t, or arm5." print
+    "Assuming arm3." print
+    "==========" print
+    "arm3" "arm-variant" set-global
+] if
 
-"ARM architecture variant: " write "arm-variant" get print
+"arm-variant" get { "arm4" "arm4t" "arm5" } member? [
+    "cpu.arm.4" require
+] when
 
-"arm-variant" "arm5" = [ "cpu.arm5" require ] when
+"arm-variant" get { "arm4t" "arm5" } member? [
+    t have-BX? set-global
+] when
+
+"arm-variant" get "arm5" = [
+    t have-BLX? set-global
+] when

core/cpu/arm/assembler/assembler.factor

@@ -4,8 +4,6 @@ USING: arrays generator generator.fixup kernel sequences words
 namespaces math math.bitfields ;
 IN: cpu.arm.assembler
 
-SYMBOL: arm-variant
-
 : define-registers ( seq -- )
     dup length [ "register" set-word-prop ] 2each ;
 
@@ -253,15 +251,77 @@ M: object addressing-mode-2 shifter-op { { 1 25 } 0 } bitfield ;
 : STR 0 0 addr2 ;
 : STRB 1 0 addr2 ;
 
-HOOK: BX arm-variant ( operand -- )
-
-HOOK: BLX arm-variant ( operand -- )
-
 ! We might have to simulate these instructions since older ARM
 ! chips don't have them.
-M: f BX PC swap MOV ;
+SYMBOL: have-BX?
+SYMBOL: have-BLX?
 
-M: f BLX LR PC MOV BX ;
+GENERIC# (BX) 1 ( Rm l -- )
+
+M: register (BX) ( Rm l -- )
+    {
+        { 1 24 }
+        { 1 21 }
+        { BIN: 1111 16 }
+        { BIN: 1111 12 }
+        { BIN: 1111 8 }
+        5
+        { 1 4 }
+        { register 0 }
+    } insn ;
+
+M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
+
+M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
+
+: BX have-BX? get [ 0 (BX) ] [ PC swap MOV ] if ;
+
+: BLX have-BLX? get [ 1 (BX) ] [ LR PC MOV BX ] if ;
+
+! More load and store instructions
+GENERIC: addressing-mode-3 ( addressing-mode -- n )
+
+: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
+
+M: addressing addressing-mode-3
+    [ addressing-p ] keep
+    [ addressing-u ] keep
+    [ addressing-w ] keep
+    delegate addressing-mode-3
+    { 0 21 23 24 } bitfield ;
+
+M: integer addressing-mode-3
+    b>n/n {
+        ! { 1 24 }
+        { 1 22 }
+        { 1 7 }
+        { 1 4 }
+        0
+        8
+    } bitfield ;
+
+M: object addressing-mode-3
+    shifter-op {
+        ! { 1 24 }
+        { 1 7 }
+        { 1 4 }
+        0
+    } bitfield ;
+
+: addr3 ( Rn Rd addressing-mode h l s -- )
+    {
+        6
+        20
+        5
+        { addressing-mode-3 0 }
+        { register 16 }
+        { register 12 }
+    } insn ;
+
+: LDRH 1 1 0 addr3 ;
+: LDRSB 0 1 1 addr3 ;
+: LDRSH 1 1 1 addr3 ;
+: STRH 1 0 0 addr3 ;
 
 ! Load and store multiple instructions
 

core/cpu/arm/bootstrap.factor

@@ -1,4 +1,119 @@
-USING: bootstrap.image.private kernel namespaces system ;
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private kernel namespaces system
+cpu.arm.assembler math layouts words vocabs ;
+IN: bootstrap.arm
+
+! We generate ARM3 code
+f have-BX? set
 
 4 \ cell set
 big-endian off
+
+4 jit-code-format set
+
+: ds-reg R5 ;
+
+: word-reg R0 ;
+: quot-reg R0 ;
+: scan-reg R2 ;
+: temp-reg R3 ;
+: xt-reg R12 ;
+
+: stack-frame 16 bootstrap-cells ;
+
+: next-save stack-frame 2 bootstrap-cells - ;
+: xt-save stack-frame 3 bootstrap-cells - ;
+: array-save stack-frame 4 bootstrap-cells - ;
+: scan-save stack-frame 5 bootstrap-cells - ;
+
+[
+    temp-reg quot-reg quot-array@ <+> LDR      ! load array
+    scan-reg temp-reg scan@ ADD                ! initialize scan pointer
+] { } make jit-setup set
+
+[
+    LR SP 4 <-> STR                            ! save return address
+    SP SP stack-frame SUB
+    xt-reg SP xt-save <+> STR                  ! save XT
+    xt-reg stack-frame MOV
+    xt-reg SP next-save <+> STR                ! save frame size
+    temp-reg SP array-save <+> STR             ! save array
+] { } make jit-prolog set
+
+[
+    temp-reg scan-reg 4 <!+> LDR               ! load literal and advance
+    temp-reg ds-reg 4 <!+> STR                 ! push literal
+] { } make jit-push-literal set
+
+[
+    temp-reg scan-reg 4 <!+> LDR               ! load wrapper and advance
+    temp-reg dup wrapper@ <+> LDR              ! load wrapped object
+    temp-reg ds-reg 4 <!+> STR                 ! push wrapped object
+] { } make jit-push-wrapper set
+
+[
+    R1 SP 4 SUB                                ! pass stack pointer to primitive
+] { } make jit-word-primitive-jump set
+
+[
+    R1 SP 4 SUB                                ! pass stack pointer to primitive
+] { } make jit-word-primitive-call set
+
+: load-word-xt ( -- )
+    word-reg scan-reg 4 <!+> LDR               ! load word and advance
+    xt-reg word-reg word-xt@ <+> LDR ;
+
+: jit-call
+    scan-reg SP scan-save <+> STR              ! save scan pointer
+    LR PC MOV                                  ! save return address
+    xt-reg BX                                  ! call
+    scan-reg SP scan-save <+> LDR              ! restore scan pointer
+    ;
+
+: jit-jump
+    xt-reg BX ;
+
+[ load-word-xt jit-call ] { } make jit-word-call set
+
+[ load-word-xt jit-jump ] { } make jit-word-jump set
+
+: load-quot-xt
+    xt-reg quot-reg quot-xt@ <+> LDR ;
+
+: load-branch
+    temp-reg ds-reg 4 <-!> LDR                 ! pop boolean
+    temp-reg \ f tag-number CMP                ! compare it with f
+    quot-reg scan-reg MOV                      ! point quot-reg at false branch
+    quot-reg dup 4 EQ ADD                      ! point quot-reg at true branch
+    quot-reg dup 4 <+> LDR                     ! load the branch
+    scan-reg dup 12 ADD                        ! advance scan pointer
+    load-quot-xt
+    ;
+
+[
+    load-branch jit-jump
+] { } make jit-if-jump set
+
+[
+    load-branch jit-call
+] { } make jit-if-call set
+
+[
+    temp-reg ds-reg 4 <-!> LDR                 ! pop index
+    temp-reg dup 1 <LSR> MOV                   ! turn it into an array offset
+    scan-reg dup 4 <+> LDR                     ! load array
+    temp-reg dup scan-reg ADD                  ! compute quotation location
+    quot-reg temp-reg array-start <+> LDR      ! load quotation
+    load-quot-xt
+    jit-jump
+] { } make jit-dispatch set
+
+[
+    SP SP stack-frame ADD                      ! pop stack frame
+    LR SP 4 <-> LDR                            ! load return address
+] { } make jit-epilog set
+
+[ LR BX ] { } make jit-return set
+
+"bootstrap.arm" forget-vocab

core/cpu/arm/intrinsics/intrinsics.factor

@@ -2,40 +2,58 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays cpu.architecture cpu.arm.assembler
 cpu.arm.architecture cpu.arm.allot kernel kernel.private math
-math.functions math.private namespaces sequences words
+math.private namespaces sequences words
 quotations byte-arrays hashtables.private hashtables generator
 generator.registers generator.fixup sequences.private sbufs
 sbufs.private vectors vectors.private system tuples.private
 layouts strings.private slots.private ;
 IN: cpu.arm.intrinsics
 
+: %slot-literal-known-tag
+    "val" operand
+    "obj" operand
+    "n" get cells
+    "obj" get operand-tag - <+/-> ;
+
+: %slot-literal-any-tag
+    "scratch" operand "obj" operand %untag
+    "val" operand "scratch" operand "n" get cells <+> ;
+
+: %slot-any
+    "scratch" operand "obj" operand %untag
+    "n" operand dup 1 <LSR> MOV
+    "val" operand "scratch" operand "n" operand <+> ;
+
 \ slot {
+    ! Slot number is literal and the tag is known
+    {
+        [ %slot-literal-known-tag LDR ] H{
+            { +input+ { { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { +scratch+ { { f "val" } } }
+            { +output+ { "val" } }
+        }
+    }
     ! Slot number is literal
     {
-        [
+        [ %slot-literal-any-tag LDR ] H{
-            "out" operand "obj" operand %untag
-            "out" operand dup "n" get cells <+> LDR
-        ] H{
             { +input+ { { f "obj" } { [ small-slot? ] "n" } } }
-            { +scratch+ { { f "out" } } }
+            { +scratch+ { { f "scratch" } { f "val" } } }
-            { +output+ { "out" } }
+            { +output+ { "val" } }
         }
     }
     ! Slot number in a register
     {
-        [
+        [ %slot-any LDR ] H{
-            "out" operand "obj" operand %untag
-            "out" operand dup "n" operand 1 <LSR> <+> LDR
-        ] H{
             { +input+ { { f "obj" } { f "n" } } }
-            { +scratch+ { { f "out" } } }
+            { +scratch+ { { f "val" } { f "scratch" } } }
-            { +output+ { "out" } }
+            { +output+ { "val" } }
+            { +clobber+ { "n" } }
         }
     }
 } define-intrinsics
 
-: generate-write-barrier ( -- )
+: %write-barrier ( -- )
-    "val" operand-immediate? "obj" get fresh-object? or [
+    "val" get operand-immediate? "obj" get fresh-object? or [
         "cards_offset" f R12 %alien-global
         "scratch" operand R12 "scratch" operand card-bits <LSR> ADD
         "val" operand "scratch" operand 0 LDRB
@@ -44,13 +62,17 @@ IN: cpu.arm.intrinsics
     ] unless ;
 
 \ set-slot {
+    ! Slot number is literal and tag is known
+    {
+        [ %slot-literal-known-tag STR %write-barrier ] H{
+            { +input+ { { f "val" } { f "obj" known-tag } { [ small-slot? ] "n" } } }
+            { +scratch+ { { f "scratch" } } }
+            { +clobber+ { "val" } }
+        }
+    }
     ! Slot number is literal
     {
-        [
+        [ %slot-literal-any-tag STR %write-barrier ] H{
-            "scratch" operand "obj" operand %untag
-            "val" operand "scratch" operand "n" get cells <+> STR
-            generate-write-barrier
-        ] H{
             { +input+ { { f "val" } { f "obj" } { [ small-slot? ] "n" } } }
             { +scratch+ { { f "scratch" } } }
             { +clobber+ { "val" } }
@@ -58,12 +80,7 @@ IN: cpu.arm.intrinsics
     }
     ! Slot number is in a register
     {
-        [
+        [ %slot-any STR %write-barrier ] H{
-            "scratch" operand "obj" operand %untag
-            "n" operand "scratch" operand "n" operand 1 <LSR> ADD
-            "val" operand "n" operand 0 STR
-            generate-write-barrier
-        ] H{
             { +input+ { { f "val" } { f "obj" } { f "n" } } }
             { +scratch+ { { f "scratch" } } }
             { +clobber+ { "val" "n" } }
@@ -135,19 +152,19 @@ IN: cpu.arm.intrinsics
 : overflow-check ( insn -- )
     [
         "end" define-label
-        [ "allot-tmp" operand "x" operand "y" operand roll S execute ] keep
+        [ "out" operand "x" operand "y" operand roll S execute ] keep
         "end" get VC B
         { "x" "y" } %untag-fixnums
         "x" operand "x" operand "y" operand roll execute
-        "x" get %allot-bignum-signed-1
+        "out" get "x" get %allot-bignum-signed-1
         "end" resolve-label
     ] with-scope ; inline
 
 : overflow-template ( word insn -- )
     [ overflow-check ] curry H{
         { +input+ { { f "x" } { f "y" } } }
-        { +scratch+ { { f "allot-tmp" } } }
+        { +scratch+ { { f "out" } } }
-        { +output+ { "allot-tmp" } }
+        { +output+ { "out" } }
         { +clobber+ { "x" "y" } }
     } define-intrinsic ;
 
@@ -156,12 +173,12 @@ IN: cpu.arm.intrinsics
 
 \ fixnum>bignum [
     "x" operand dup %untag-fixnum
-    "x" get %allot-bignum-signed-1
+    "out" get "x" get %allot-bignum-signed-1
 ] H{
     { +input+ { { f "x" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
     { +clobber+ { "x" } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ bignum>fixnum [
@@ -224,28 +241,39 @@ IN: cpu.arm.intrinsics
 } define-intrinsic
 
 \ type [
+    ! Get the tag
+    "out" operand "obj" operand tag-mask get AND
+    ! Compare with object tag number (3).
+    "out" operand object tag-number CMP
+    ! Tag the tag if it is not equal to 3
+    "out" operand dup NE %tag-fixnum
+    ! Load the object header if tag is equal to 3
+    "out" operand "obj" operand object tag-number <-> EQ LDR
+] H{
+    { +input+ { { f "obj" } } }
+    { +scratch+ { { f "out" } } }
+    { +output+ { "out" } }
+} define-intrinsic
+
+\ class-hash [
     "end" define-label
     ! Get the tag
-    "y" operand "obj" operand tag-mask get AND
+    "out" operand "obj" operand tag-mask get AND
+    ! Compare with tuple tag number (2).
+    "out" operand tuple tag-number CMP
+    "out" operand "obj" operand tuple-class-offset <+/-> EQ LDR
+    "out" operand dup class-hash-offset <+/-> EQ LDR
+    "end" get EQ B
     ! Compare with object tag number (3).
-    "y" operand object tag-number CMP
+    "out" operand object tag-number CMP
-    ! Tag the tag if it is not equal to 3
+    "out" operand "obj" operand object tag-number <-> EQ LDR
-    "x" operand "y" operand NE %tag-fixnum
+    ! Tag the tag
-    ! Jump to end if it is not equal to 3
+    "out" operand dup NE %tag-fixnum
-    "end" get NE B
-    ! Is the pointer itself equal to 3? Then its F_TYPE (9).
-    "obj" operand object tag-number CMP
-    ! Load F_TYPE (9) if it is equal
-    "x" operand f type v>operand EQ MOV
-    ! Load the object header if it is not equal
-    "x" operand "obj" operand object tag-number <-> NE LDR
-    ! Turn the header into a fixnum
-    "x" operand dup NE %untag
     "end" resolve-label
 ] H{
     { +input+ { { f "obj" } } }
-    { +scratch+ { { f "x" } { f "y" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "x" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 : userenv ( reg -- )
@@ -273,7 +301,7 @@ IN: cpu.arm.intrinsics
     { +clobber+ { "n" } }
 } define-intrinsic
 
-: %set-slot "allot-tmp" operand swap cells <+> STR ;
+: %set-slot R11 swap cells <+> STR ;
 
 : %store-length
     R12 "n" operand MOV
@@ -289,11 +317,11 @@ IN: cpu.arm.intrinsics
     ! Zero out the rest of the tuple
     R12 f v>operand MOV
     "n" get 1- [ 1+ R12 %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "class" } { [ inline-array? ] "n" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <array> [
@@ -301,11 +329,11 @@ IN: cpu.arm.intrinsics
     %store-length
     ! Store initial element
     "n" get [ "initial" operand %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { [ inline-array? ] "n" } { f "initial" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <byte-array> [
@@ -314,22 +342,22 @@ IN: cpu.arm.intrinsics
     ! Store initial element
     R12 0 MOV
     "n" get cell align cell /i [ R12 %fill-array ] each
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { [ inline-array? ] "n" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <ratio> [
     ratio 3 cells %allot
     "numerator" operand 1 %set-slot
     "denominator" operand 2 %set-slot
-    ratio %tag-allot
+    "out" get ratio %store-tagged
 ] H{
     { +input+ { { f "numerator" } { f "denominator" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <complex> [
@@ -337,22 +365,22 @@ IN: cpu.arm.intrinsics
     "real" operand 1 %set-slot
     "imaginary" operand 2 %set-slot
     ! Store tagged ptr in reg
-    complex %tag-allot
+    "out" get complex %store-tagged
 ] H{
     { +input+ { { f "real" } { f "imaginary" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ <wrapper> [
     wrapper 2 cells %allot
     "obj" operand 1 %set-slot
     ! Store tagged ptr in reg
-    wrapper %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "obj" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ (hashtable) [
@@ -362,80 +390,82 @@ IN: cpu.arm.intrinsics
     R12 2 %set-slot
     R12 3 %set-slot
     ! Store tagged ptr in reg
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ string>sbuf [
     sbuf 3 cells %allot
     "length" operand 1 %set-slot
     "string" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "string" } { f "length" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ array>vector [
     vector 3 cells %allot
     "length" operand 1 %set-slot
     "array" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "array" } { f "length" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 \ curry [
     \ curry 3 cells %allot
     "obj" operand 1 %set-slot
     "quot" operand 2 %set-slot
-    object %tag-allot
+    "out" get object %store-tagged
 ] H{
     { +input+ { { f "obj" } { f "quot" } } }
-    { +scratch+ { { f "allot-tmp" } } }
+    { +scratch+ { { f "out" } } }
-    { +output+ { "allot-tmp" } }
+    { +output+ { "out" } }
 } define-intrinsic
 
 ! Alien intrinsics
+: %alien-accessor ( quot -- )
+    "offset" operand dup %untag-fixnum
+    "offset" operand dup "alien" operand ADD
+    "value" operand "offset" operand 0 <+> roll call ; inline
+
 : alien-integer-get-template
     H{
         { +input+ {
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "output" } } }
+        { +scratch+ { { f "value" } } }
-        { +output+ { "output" } }
+        { +output+ { "value" } }
         { +clobber+ { "offset" } }
     } ;
 
-: %alien-get ( quot -- )
-    "output" get "address" set
-    "output" operand "alien" operand-class %alien-accessor ;
-
 : %alien-integer-get ( quot -- )
-    %alien-get
+    %alien-accessor
-    "output" operand dup %tag-fixnum ; inline
+    "value" operand dup %tag-fixnum ; inline
-
-: %alien-integer-set ( quot -- )
-    "value" operand dup %untag-fixnum
-    "value" operand "alien" operand-class %alien-accessor ; inline
 
 : alien-integer-set-template
     H{
         { +input+ {
             { f "value" fixnum }
-            { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-        { +scratch+ { { f "address" } } }
         { +clobber+ { "value" "offset" } }
     } ;
 
+: %alien-integer-set ( quot -- )
+    "offset" get "value" get = [
+        "value" operand dup %untag-fixnum
+    ] unless
+    %alien-accessor ; inline
+
 : define-alien-integer-intrinsics ( word get-quot word set-quot -- )
     [ %alien-integer-set ] curry
     alien-integer-set-template
@@ -448,15 +478,31 @@ IN: cpu.arm.intrinsics
 \ set-alien-unsigned-1 [ STRB ]
 define-alien-integer-intrinsics
 
-\ alien-cell [
+: alien-cell-template
-    [ LDR ] %alien-get
+    H{
-    "output" get %allot-alien
-] H{
         { +input+ {
-        { f "alien" simple-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
             { f "offset" fixnum }
         } }
-    { +scratch+ { { f "output" } { f "allot-tmp" } } }
+        { +scratch+ { { unboxed-alien "value" } } }
-    { +output+ { "allot-tmp" } }
+        { +output+ { "value" } }
         { +clobber+ { "offset" } }
-} define-intrinsic
+    } ;
+
+\ alien-cell
+[ [ LDR ] %alien-accessor ]
+alien-cell-template define-intrinsic
+
+: set-alien-cell-template
+    H{
+        { +input+ {
+            { unboxed-c-ptr "value" pinned-c-ptr }
+            { unboxed-c-ptr "alien" c-ptr }
+            { f "offset" fixnum }
+        } }
+        { +clobber+ { "offset" } }
+    } ;
+
+\ set-alien-cell
+[ [ STR ] %alien-accessor ]
+set-alien-cell-template define-intrinsic

core/cpu/arm5/arm5.factor

@@ -1,4 +0,0 @@
-USING: cpu.arm.assembler cpu.arm5.assembler cpu.arm5.intrinsics
-namespaces ;
-
-T{ arm5-variant } arm-variant set-global

core/cpu/arm5/assembler/assembler.factor

@@ -1,74 +0,0 @@
-! Copyright (C) 2007 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: arrays generator generator.fixup kernel sequences words
-namespaces math math.bitfields cpu.arm.assembler ;
-IN: cpu.arm5.assembler
-
-TUPLE: arm5-variant ;
-
-GENERIC# (BX) 1 ( Rm l -- )
-
-M: register (BX) ( Rm l -- )
-    {
-        { 1 24 }
-        { 1 21 }
-        { BIN: 1111 16 }
-        { BIN: 1111 12 }
-        { BIN: 1111 8 }
-        5
-        { 1 4 }
-        { register 0 }
-    } insn ;
-
-M: word (BX) 0 swap (BX) rc-relative-arm-3 rel-word ;
-
-M: label (BX) 0 swap (BX) rc-relative-arm-3 label-fixup ;
-
-M: arm5-variant BX 0 (BX) ;
-
-M: arm5-variant BLX 1 (BX) ;
-
-! More load and store instructions
-GENERIC: addressing-mode-3 ( addressing-mode -- n )
-
-: b>n/n ( b -- n n ) dup -4 shift swap HEX: f bitand ;
-
-M: addressing addressing-mode-3
-    [ addressing-p ] keep
-    [ addressing-u ] keep
-    [ addressing-w ] keep
-    delegate addressing-mode-3
-    { 0 21 23 24 } bitfield ;
-
-M: integer addressing-mode-3
-    b>n/n {
-        ! { 1 24 }
-        { 1 22 }
-        { 1 7 }
-        { 1 4 }
-        0
-        8
-    } bitfield ;
-
-M: object addressing-mode-3
-    shifter-op {
-        ! { 1 24 }
-        { 1 7 }
-        { 1 4 }
-        0
-    } bitfield ;
-
-: addr3 ( Rn Rd addressing-mode h l s -- )
-    {
-        6
-        20
-        5
-        { addressing-mode-3 0 }
-        { register 16 }
-        { register 12 }
-    } insn ;
-
-: LDRH 1 1 0 addr3 ;
-: LDRSB 0 1 1 addr3 ;
-: LDRSH 1 1 1 addr3 ;
-: STRH 1 0 0 addr3 ;

core/cpu/arm5/summary.txt

@@ -1 +0,0 @@
-Additional compiler intrinsics for ARM5

core/cpu/ppc/allot/allot.factor

@@ -3,7 +3,7 @@
 USING: kernel cpu.ppc.architecture cpu.ppc.assembler
 kernel.private namespaces math sequences generic arrays
 generator generator.registers generator.fixup system layouts
-math.functions cpu.architecture alien ;
+cpu.architecture alien ;
 IN: cpu.ppc.allot
 
 : load-zone-ptr ( reg -- )

core/cpu/ppc/architecture/architecture.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
 kernel kernel.private math memory namespaces sequences words
 assocs generator generator.registers generator.fixup system
-layouts math.functions classes words.private alien combinators ;
+layouts classes words.private alien combinators ;
 IN: cpu.ppc.architecture
 
 TUPLE: ppc-backend ;
@@ -15,10 +15,8 @@ TUPLE: ppc-backend ;
 ! r14: data stack
 ! r15: retain stack
 
-! For stack frame layout, see vm/cpu-ppc.h.
+: ds-reg 14 ; inline
-
+: rs-reg 15 ; inline
-: ds-reg 14 ;
-: rs-reg 15 ;
 
 : reserved-area-size
     os {
@@ -59,13 +57,11 @@ M: int-regs vregs
     } ;
 
 M: float-regs return-reg drop 1 ;
-
 M: float-regs param-regs 
     drop os H{
         { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
         { "linux" { 1 2 3 4 5 6 7 8 } }
     } at ;
-
 M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
 GENERIC: loc>operand ( loc -- reg n )
@@ -123,7 +119,7 @@ M: ppc-backend %call-label ( label -- ) BL ;
 M: ppc-backend %jump-label ( label -- ) B ;
 
 : %prepare-primitive ( word -- )
-    ! Save stack pointer to stack_chain->callstack_top, load XT
+    #! Save stack pointer to stack_chain->callstack_top, load XT
     4 1 MR 11 %load-xt ;
 
 : (%call) 11 MTLR BLRL ;
@@ -137,7 +133,7 @@ M: ppc-backend %jump-primitive ( word -- )
     %prepare-primitive (%jump) ;
 
 M: ppc-backend %jump-t ( label -- )
-    0 "flag" operand \ f tag-number CMPI BNE ;
+    0 "flag" operand f v>operand CMPI BNE ;
 
 : dispatch-template ( word-table# quot -- )
     [

core/cpu/ppc/assembler/assembler.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: cpu.ppc.assembler
 USING: generator.fixup generic kernel math memory namespaces
-words math.bitfields math.functions io.binary ;
+words math.bitfields io.binary ;
 
 ! See the Motorola or IBM documentation for details. The opcode
 ! names are standard, and the operand order is the same as in

core/cpu/ppc/bootstrap.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: bootstrap.image.private kernel namespaces system
-cpu.ppc.assembler math math.functions layouts words vocabs ;
+cpu.ppc.assembler math layouts words vocabs ;
 IN: bootstrap.ppc
 
 4 \ cell set
@@ -62,6 +62,7 @@ big-endian on
 ] { } make jit-word-primitive-call set
 
 : load-xt ( -- )
+    word-reg scan-reg 4 LWZU                   ! load word and advance
     xt-reg word-reg word-xt@ LWZ ;
 
 : jit-call
@@ -74,17 +75,9 @@ big-endian on
 : jit-jump
     xt-reg MTCTR BCTR ;
 
-[
+[ load-xt jit-call ] { } make jit-word-call set
-    word-reg scan-reg 4 LWZU                   ! load word and advance
-    load-xt
-    jit-call
-] { } make jit-word-call set
 
-[
+[ load-xt jit-jump ] { } make jit-word-jump set
-    word-reg scan-reg 4 LWZ                    ! load word
-    load-xt                                    ! jump to word XT
-    jit-jump
-] { } make jit-word-jump set
 
 : load-branch
     temp-reg ds-reg 0 LWZ                      ! load boolean

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -5,7 +5,7 @@ cpu.ppc.architecture cpu.ppc.allot cpu.architecture kernel
 kernel.private math math.private namespaces sequences words
 generic quotations byte-arrays hashtables hashtables.private
 generator generator.registers generator.fixup sequences.private
-sbufs vectors system layouts math.functions math.floats.private
+sbufs vectors system layouts math.floats.private
 classes tuples tuples.private sbufs.private vectors.private
 strings.private slots.private combinators bit-arrays
 float-arrays ;
@@ -374,14 +374,6 @@ IN: cpu.ppc.intrinsics
     { +output+ { "out" } }
 } define-intrinsic
 
-! \ fsqrt [
-!     "y" operand "x" operand FSQRT
-! ] H{
-!     { +input+ { { float "x" } } }
-!     { +scratch+ { { float "y" } } }
-!     { +output+ { "y" } }
-! } define-intrinsic
-
 \ tag [
     "out" operand "in" operand tag-mask get ANDI
     "out" operand dup %tag-fixnum

core/cpu/x86/32/32.factor

@@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
 cpu.architecture kernel kernel.private math namespaces sequences
 generator.registers generator.fixup generator system
-math.functions alien.compiler combinators command-line
+alien.compiler combinators command-line
 compiler io vocabs.loader ;
 IN: cpu.x86.32
 

core/cpu/x86/64/64.factor

@@ -4,7 +4,7 @@ USING: alien.c-types arrays cpu.x86.assembler
 cpu.x86.architecture cpu.x86.intrinsics cpu.x86.sse2
 cpu.x86.allot cpu.architecture kernel kernel.private math
 namespaces sequences generator.registers generator.fixup system
-alien alien.compiler alien.structs slots splitting math.functions ;
+alien alien.compiler alien.structs slots splitting ;
 IN: cpu.x86.64
 
 PREDICATE: x86-backend amd64-backend
@@ -13,8 +13,8 @@ PREDICATE: x86-backend amd64-backend
 M: amd64-backend ds-reg R14 ;
 M: amd64-backend rs-reg R15 ;
 M: amd64-backend stack-reg RSP ;
-M: x86-backend xt-reg RCX ;
+M: amd64-backend xt-reg RCX ;
-M: x86-backend stack-save-reg RSI ;
+M: amd64-backend stack-save-reg RSI ;
 
 M: temp-reg v>operand drop RBX ;
 

core/cpu/x86/allot/allot.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel cpu.architecture cpu.x86.assembler
 cpu.x86.architecture kernel.private namespaces math
-math.functions sequences generic arrays generator
+sequences generic arrays generator generator.fixup
-generator.fixup generator.registers system layouts alien ;
+generator.registers system layouts alien ;
 IN: cpu.x86.allot
 
 : allot-reg

core/cpu/x86/architecture/architecture.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.compiler arrays
 cpu.x86.assembler cpu.architecture kernel kernel.private math
-math.functions memory namespaces sequences words generator
+memory namespaces sequences words generator generator.registers
-generator.registers generator.fixup system layouts combinators ;
+generator.fixup system layouts combinators ;
 IN: cpu.x86.architecture
 
 TUPLE: x86-backend cell ;

core/cpu/x86/intrinsics/intrinsics.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays cpu.x86.assembler cpu.x86.allot
 cpu.x86.architecture cpu.architecture kernel kernel.private math
-math.functions math.private namespaces quotations sequences
+math.private namespaces quotations sequences
 words generic byte-arrays hashtables hashtables.private
 generator generator.registers generator.fixup sequences.private
 sbufs sbufs.private vectors vectors.private layouts system

core/generator/generator.factor

@@ -312,3 +312,4 @@ M: #return generate-node drop end-basic-block %return f ;
 : underlying-alien-offset cell object tag-number - ;
 : tuple-class-offset 2 cells tuple tag-number - ;
 : class-hash-offset cell object tag-number - ;
+: word-xt-offset 8 cells object tag-number - ;

core/generic/generic-tests.factor

@@ -34,7 +34,7 @@ M: f bool>str drop "false" ;
 [ f ] [ f bool>str str>bool ] unit-test
 
 ! Testing unions
-UNION: funnies quotation ratio complex ;
+UNION: funnies quotation float complex ;
 
 GENERIC: funny ( x -- y )
 M: funnies funny drop 2 ;
@@ -48,7 +48,7 @@ PREDICATE: funnies very-funny number? ;
 GENERIC: gooey ( x -- y )
 M: very-funny gooey sq ;
 
-[ 1/4 ] [ 1/2 gooey ] unit-test
+[ 0.25 ] [ 0.5 gooey ] unit-test
 
 DEFER: complement-test
 FORGET: complement-test

core/generic/generic.factor

@@ -21,7 +21,7 @@ M: object perform-combination
     #! method combination, and a method on the generic, and the
     #! method combination is forgotten first, then forgetting
     #! the method will throw an error. We don't want that.
-    nip [ "Invalid method combination" throw ] curry ;
+    nip [ "Invalid method combination" throw ] curry [ ] like ;
 
 : make-generic ( word -- )
     dup

core/growable/growable-tests.factor

@@ -22,5 +22,5 @@ unit-test-fails
 
 [ ] [
     10 V{ } [ set-length ] keep
-    1/2 swap set-length
+    0.5 swap set-length
 ] unit-test

core/hashtables/hashtables-tests.factor

@@ -34,11 +34,11 @@ unit-test
 
 16 <hashtable> "testhash" set
 
-t C{ 2 3 } "testhash" get set-at
+t { 2 3 } "testhash" get set-at
 f 100000000000000000000000000 "testhash" get set-at
 { } { [ { } ] } "testhash" get set-at
 
-[ t ] [ C{ 2 3 } "testhash" get at ] unit-test
+[ t ] [ { 2 3 } "testhash" get at ] unit-test
 [ f ] [ 100000000000000000000000000 "testhash" get at* drop ] unit-test
 [ { } ] [ { [ { } ] } clone "testhash" get at* drop ] unit-test
 
@@ -122,7 +122,7 @@ H{ } "x" set
 100 [ drop "x" get clear-assoc ] each
 
 ! Crash discovered by erg
-[ t ] [ 3/4 <hashtable> dup clone = ] unit-test
+[ t ] [ 0.75 <hashtable> dup clone = ] unit-test
 
 ! Another crash discovered by erg
 [ ] [

core/inference/backend/backend.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: inference.backend
 USING: inference.dataflow arrays generic io io.streams.string
-kernel math math.vectors namespaces parser prettyprint sequences
+kernel math namespaces parser prettyprint sequences
 strings vectors words quotations effects classes continuations
 debugger assocs combinators ;
 

core/inference/class/class.factor

@@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs hashtables inference kernel
 math namespaces sequences words parser math.intervals
-math.vectors effects classes inference.dataflow
+effects classes inference.dataflow inference.backend ;
-inference.backend ;
 IN: inference.class
 
 ! Class inference

core/inference/inference-tests.factor

@@ -230,8 +230,8 @@ DEFER: do-crap*
 ! Error reporting is wrong
 MATH: xyz
 M: fixnum xyz 2array ;
-M: ratio xyz 
+M: float xyz
-    [ >fraction ] 2apply swapd >r 2array swap r> 2array swap ;
+    [ 3 ] 2apply swapd >r 2array swap r> 2array swap ;
 
 [ t ] [ [ [ xyz ] infer short-effect ] catch inference-error? ] unit-test
 

core/io/files/files.factor

@@ -29,9 +29,8 @@ M: object root-directory? ( path -- ? ) "/" = ;
     "/\\" member? ;
 
 : path+ ( str1 str2 -- str )
-    >r [ path-separator? ] rtrim r>
+    >r [ path-separator? ] right-trim "/" r>
-    [ path-separator? ] ltrim
+    [ path-separator? ] left-trim 3append ;
-    >r "/" r> 3append ;
 
 : stat ( path -- directory? permissions length modified )
     normalize-pathname (stat) ;

core/io/utf16/utf16.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2007 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math kernel sequences sbufs vectors namespaces io.binary
-io.encodings combinators splitting math.functions ;
+io.encodings combinators splitting ;
 IN: io.utf16
 
 SYMBOL: double

core/math/complex/complex-tests.factor

@@ -1,65 +0,0 @@
-USING: kernel math math.constants math.functions tools.test ;
-IN: temporary
-
-[ 1 C{ 0 1 } rect> ] unit-test-fails
-[ C{ 0 1 } 1 rect> ] unit-test-fails
-
-[ f ] [ C{ 5 12.5 } 5  = ] unit-test
-[ t ] [ C{ 1.0 2.0 } C{ 1 2 }  = ] unit-test
-[ f ] [ C{ 1.0 2.3 } C{ 1 2 }  = ] unit-test
-
-[ C{ 2 5 } ] [ 2 5  rect> ] unit-test
-[ 2 5 ] [ C{ 2 5 }  >rect ] unit-test
-[ C{ 1/2 1 } ] [ 1/2 i  + ] unit-test
-[ C{ 1/2 1 } ] [ i 1/2  + ] unit-test
-[ t ] [ C{ 11 64 } C{ 11 64 }  = ] unit-test
-[ C{ 2 1 } ] [ 2 i  + ] unit-test
-[ C{ 2 1 } ] [ i 2  + ] unit-test
-[ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 }  + ] unit-test
-[ 5 ] [ C{ 2 2 } C{ 3 -2 }  + ] unit-test
-[ C{ 1.0 1 } ] [ 1.0 i  + ] unit-test
-
-[ C{ 1/2 -1 } ] [ 1/2 i  - ] unit-test
-[ C{ -1/2 1 } ] [ i 1/2  - ] unit-test
-[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i * + 1 4 / i *  - ] unit-test
-[ C{ -1/3 -1/4 } ] [ 1 4 / i * 1 3 / 1 2 / i * +  - ] unit-test
-[ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 }  - ] unit-test
-[ 4 ] [ C{ 5 10/3 } C{ 1 10/3 }  - ] unit-test
-[ C{ 1.0 -1 } ] [ 1.0 i  - ] unit-test
-
-[ C{ 0 1 } ] [ i 1  * ] unit-test
-[ C{ 0 1 } ] [ 1 i  * ] unit-test
-[ C{ 0 1.0 } ] [ 1.0 i  * ] unit-test
-[ -1 ] [ i i  * ] unit-test
-[ C{ 0 1 } ] [ 1 i  * ] unit-test
-[ C{ 0 1 } ] [ i 1  * ] unit-test
-[ C{ 0 1/2 } ] [ 1/2 i  * ] unit-test
-[ C{ 0 1/2 } ] [ i 1/2  * ] unit-test
-[ 2 ] [ C{ 1 1 } C{ 1 -1 }  * ] unit-test
-[ 1 ] [ i -i  * ] unit-test
-
-[ -1 ] [ i -i  / ] unit-test
-[ C{ 0 1 } ] [ 1 -i  / ] unit-test
-[ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 }  = ] unit-test
-
-[ C{ -3 4 } ] [ C{ 3 -4 }  neg ] unit-test
-
-[ 5 ] [ C{ 3 4 } abs ] unit-test
-[ 5 ] [ -5.0 abs ] unit-test
-
-! Make sure arguments are sane
-[ 0 ] [ 0 arg ] unit-test
-[ 0 ] [ 1 arg ] unit-test
-[ t ] [ -1 arg 3.14 3.15 between? ] unit-test
-[ t ] [ i arg 1.57 1.58 between? ] unit-test
-[ t ] [ -i arg -1.58 -1.57 between? ] unit-test
-
-[ 1 0 ] [ 1 >polar ] unit-test
-[ 1 ] [ -1 >polar drop ] unit-test
-[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
-
-! I broke something
-[ ] [ C{ 1 4 } tanh drop ] unit-test
-[ ] [ C{ 1 4 } tan drop ] unit-test
-[ ] [ C{ 1 4 } coth drop ] unit-test
-[ ] [ C{ 1 4 } cot drop ] unit-test

core/math/floats/floats-tests.factor

@@ -25,9 +25,6 @@ IN: temporary
 
 [ 2.1 ] [ -2.1 neg ] unit-test
 
-[ 1 ] [ 0.5 1/2 + ] unit-test
-[ 1 ] [ 1/2 0.5 + ] unit-test
-
 [ 3 ] [ 3.1415 >fixnum ] unit-test
 [ 3 ] [ 3.1415 >bignum ] unit-test
 
@@ -48,23 +45,6 @@ unit-test
 [ 2.0 ] [ 1.0 1+ ] unit-test
 [ 0.0 ] [ 1.0 1- ] unit-test
 
-[ 4.0 ] [ 4.5 truncate ] unit-test
-[ 4.0 ] [ 4.5 floor ] unit-test
-[ 5.0 ] [ 4.5 ceiling ] unit-test
-
-[ -4.0 ] [ -4.5 truncate ] unit-test
-[ -5.0 ] [ -4.5 floor ] unit-test
-[ -4.0 ] [ -4.5 ceiling ] unit-test
-
-[ -4.0 ] [ -4.0 truncate ] unit-test
-[ -4.0 ] [ -4.0 floor ] unit-test
-[ -4.0 ] [ -4.0 ceiling ] unit-test
-
-[ -5.0 ] [ -4.5 round ] unit-test
-[ -4.0 ] [ -4.4 round ] unit-test
-[ 5.0 ] [ 4.5 round ] unit-test
-[ 4.0 ] [ 4.4 round ] unit-test
-
 ! [ t ] [ -0.0 -0.0 = ] unit-test
 ! [ f ] [ 0.0 -0.0 = ] unit-test
 

core/math/floats/floats.factor

@@ -1,17 +1,11 @@
 ! Copyright (C) 2004, 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.functions math.private math.libm ;
+USING: kernel math math.private ;
 IN: math.floats.private
 
 M: fixnum >float fixnum>float ;
 M: bignum >float bignum>float ;
 
-M: real abs dup 0 < [ neg ] when ;
-M: real absq sq ;
-
-M: real hashcode* nip >fixnum ;
-M: real <=> - ;
-
 M: float zero? dup 0.0 float= swap -0.0 float= or ;
 
 M: float >fixnum float>fixnum ;
@@ -29,6 +23,3 @@ M: float - float- ;
 M: float * float* ;
 M: float / float/f ;
 M: float mod float-mod ;
-
-M: real sqrt
-    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;

core/math/integers/integers-docs.factor

@@ -1,5 +1,4 @@
-USING: help.markup help.syntax math math.private math.functions
+USING: help.markup help.syntax math math.private ;
-math.ratios.private ;
 IN: math.integers
 
 ARTICLE: "integers" "Integers"
@@ -45,10 +44,6 @@ HELP: odd?
 { $values { "n" integer } { "?" "a boolean" } }
 { $description "Tests if an integer is odd." } ;
 
-HELP: fraction>
-{ $values { "a" integer } { "b" "a positive integer" } { "a/b" rational } }
-{ $description "Creates a new ratio, or outputs the numerator if the denominator is 1. This word does not reduce the fraction to lowest terms, and should not be called directly; use " { $link / } " instead." } ;
-
 ! Unsafe primitives
 HELP: fixnum+ ( x y -- z )
 { $values { "x" fixnum } { "y" fixnum } { "z" integer } }

core/math/integers/integers-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel math namespaces prettyprint math.functions
+USING: kernel math namespaces prettyprint
 math.private continuations tools.test sequences ;
 IN: temporary
 
@@ -57,15 +57,6 @@ IN: temporary
 [ 134217728 dup + dup + dup + dup + dup + dup + unparse ]
 unit-test
 
-[ t ] [ 0 0 ^ fp-nan? ] unit-test
-[ 1 ] [ 10 0 ^ ] unit-test
-[ 1/8 ] [ 1/2 3 ^ ] unit-test
-[ 1/8 ] [ 2 -3 ^ ] unit-test
-[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
-
-[ t ] [ 256 power-of-2? ] unit-test
-[ f ] [ 123 power-of-2? ] unit-test
-
 [ 7 ] [ 255 log2 ] unit-test
 [ 8 ] [ 256 log2 ] unit-test
 [ 8 ] [ 257 log2 ] unit-test
@@ -100,11 +91,6 @@ unit-test
 [ f ] [ BIN: -1101 >bignum 3 bit? ] unit-test
 [ t ] [ BIN: -1101 >bignum 4 bit? ] unit-test
 
-[ 1 ] [ 7/8 ceiling ] unit-test
-[ 2 ] [ 3/2 ceiling ] unit-test
-[ 0 ] [ -7/8 ceiling ] unit-test
-[ -1 ] [ -3/2 ceiling ] unit-test
-
 [ 2 ] [ 0 next-power-of-2 ] unit-test
 [ 2 ] [ 1 next-power-of-2 ] unit-test
 [ 2 ] [ 2 next-power-of-2 ] unit-test
@@ -112,10 +98,8 @@ unit-test
 [ 16 ] [ 13 next-power-of-2 ] unit-test
 [ 16 ] [ 16 next-power-of-2 ] unit-test
 
-[ 268435456 ] [ -268435456 >fixnum -1 / ] unit-test
 [ 268435456 ] [ -268435456 >fixnum -1 /i ] unit-test
 [ 268435456 0 ] [ -268435456 >fixnum -1 /mod ] unit-test
-[ 1/268435456 ] [ -1 -268435456 >fixnum / ] unit-test
 [ 0 ] [ -1 -268435456 >fixnum /i ] unit-test
 [ 0 -1 ] [ -1 -268435456 >fixnum /mod ] unit-test
 [ 14355 ] [ 1591517158873146351817850880000000 32769 mod ] unit-test

core/math/integers/integers.factor

@@ -4,9 +4,6 @@ USING: kernel kernel.private sequences
 sequences.private math math.private combinators ;
 IN: math.integers.private
 
-M: integer hashcode* nip >fixnum ;
-M: integer <=> - ;
-
 M: integer numerator ;
 M: integer denominator drop 1 ;
 

core/math/intervals/intervals-tests.factor

@@ -1,5 +1,5 @@
 USING: math.intervals kernel sequences words math arrays
-prettyprint tools.test random ;
+prettyprint tools.test random vocabs ;
 IN: temporary
 
 [ T{ interval f { 1 t } { 2 t } } ] [ 1 2 [a,b] ] unit-test
@@ -39,11 +39,11 @@ IN: temporary
 ] unit-test
 
 [ t ] [
-    1 2 [a,b] -1/2 1/2 [a,b] interval* -1 1 [a,b] =
+    1 2 [a,b] -0.5 0.5 [a,b] interval* -1 1 [a,b] =
 ] unit-test
 
 [ t ] [
-    1 2 [a,b] -1/2 1/2 (a,b] interval* -1 1 (a,b] =
+    1 2 [a,b] -0.5 0.5 (a,b] interval* -1 1 (a,b] =
 ] unit-test
 
 [ t ] [
@@ -77,7 +77,7 @@ IN: temporary
 ] unit-test
 
 [ t ] [
-    1/2 0 1 (a,b) interval-contains?
+    0.5 0 1 (a,b) interval-contains?
 ] unit-test
 
 [ f ] [
@@ -88,9 +88,11 @@ IN: temporary
 
 [ f ] [ -1 1 (a,b) 0 1 (a,b) interval/ ] unit-test
 
+"math.ratios.private" vocab [
     [ t ] [
-    -1 1 (a,b) 1/2 1 (a,b) interval/ -2 2 (a,b) =
+        -1 1 (a,b) 0.5 1 (a,b) interval/ -2 2 (a,b) =
     ] unit-test
+] when
 
 [ t ] [ 0 5 [a,b] 5 interval<= ] unit-test
 
@@ -125,12 +127,15 @@ IN: temporary
         { + interval+ }
         { - interval- }
         { * interval* }
-        { / interval/ }
         { /i interval/i }
         { shift interval-shift }
         { min interval-min }
         { max interval-max }
-    } random ;
+    }
+    "math.ratios.private" vocab [
+        { / interval/ } add
+    ] when
+    random ;
 
 : interval-test
     random-interval random-interval random-op

core/math/math-docs.factor

@@ -243,26 +243,6 @@ HELP: 1-
     { $code "1-" "1 -" }
 } ;
 
-HELP: truncate
-{ $values { "x" real } { "y" "a whole real number" } }
-{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
-{ $notes "The result is not necessarily an integer." } ;
-
-HELP: floor
-{ $values { "x" real } { "y" "a whole real number" } }
-{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
-{ $notes "The result is not necessarily an integer." } ;
-
-HELP: ceiling
-{ $values { "x" real } { "y" "a whole real number" } }
-{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
-{ $notes "The result is not necessarily an integer." } ;
-
-HELP: round
-{ $values { "x" real } { "y" "a whole real number" } }
-{ $description "Outputs the whole number closest to " { $snippet "x" } "." }
-{ $notes "The result is not necessarily an integer." } ;
-
 HELP: sq
 { $values { "x" number } { "y" number } }
 { $description "Multiplies a number by itself." } ;
@@ -351,22 +331,9 @@ HELP: imaginary ( z -- y )
 { $values { "z" number } { "y" real } }
 { $description "Outputs the imaginary part of a complex number. This outputs zero for real numbers." } ;
 
-HELP: (rect>)
-{ $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." }
-{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
-
 HELP: number
 { $class-description "The class of numbers." } ;
 
-HELP: rect>
-{ $values { "x" real } { "y" real } { "z" number } }
-{ $description "Creates a complex number from real and imaginary components." } ;
-
-HELP: >rect
-{ $values { "z" number } { "x" real } { "y" real } }
-{ $description "Extracts the real and imaginary components of a complex number." } ;
-
 HELP: next-power-of-2
 { $values { "m" "a non-negative integer" } { "n" "an integer" } }
 { $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;

core/math/math.factor

@@ -8,6 +8,7 @@ GENERIC: >bignum ( x -- y ) foldable
 GENERIC: >float ( x -- y ) foldable
 
 MATH: number= ( x y -- ? ) foldable
+
 M: object number= 2drop f ;
 
 MATH: <  ( x y -- ? ) foldable
@@ -48,8 +49,6 @@ GENERIC: zero? ( x -- ? ) foldable
 
 M: object zero? drop f ;
 
-GENERIC: sqrt ( x -- y ) foldable
-
 : 1+ ( x -- y ) 1 + ; foldable
 : 1- ( x -- y ) 1 - ; foldable
 : 2/ ( x -- y ) -1 shift ; foldable
@@ -66,15 +65,8 @@ GENERIC: sqrt ( x -- y ) foldable
     pick >= [ >= ] [ 2drop f ] if ; inline
 
 : rem ( x y -- z ) tuck mod over + swap mod ; foldable
+
 : sgn ( x -- n ) dup 0 < -1 0 ? swap 0 > 1 0 ? bitor ; foldable
-: truncate ( x -- y ) dup 1 mod - ; inline
-: round ( x -- y ) dup sgn 2 / + truncate ; inline
-
-: floor ( x -- y )
-    dup 1 mod dup zero?
-    [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
-
-: ceiling ( x -- y ) neg floor neg ; foldable
 
 : [-] ( x y -- z ) - 0 max ; inline
 
@@ -84,9 +76,6 @@ GENERIC: sqrt ( x -- y ) foldable
 
 : odd? ( n -- ? ) 1 bitand 1 number= ;
 
-: >fraction ( a/b -- a b )
-    dup numerator swap denominator ; inline
-
 UNION: integer fixnum bignum ;
 
 UNION: rational integer ratio ;
@@ -95,6 +84,19 @@ UNION: real rational float ;
 
 UNION: number real complex ;
 
+M: number equal? number= ;
+
+M: real hashcode* nip >fixnum ;
+
+M: real <=> - ;
+
+! real and sequence overlap. we disambiguate:
+M: integer equal? number= ;
+
+M: integer hashcode* nip >fixnum ;
+
+M: integer <=> - ;
+
 GENERIC: fp-nan? ( x -- ? )
 
 M: object fp-nan?
@@ -104,25 +106,6 @@ M: float fp-nan?
     double>bits -51 shift BIN: 111111111111 [ bitand ] keep
     number= ;
 
-<PRIVATE
-
-: (rect>) ( x y -- z )
-    dup zero? [ drop ] [ <complex> ] if ; inline
-
-PRIVATE>
-
-: rect> ( x y -- z )
-    over real? over real? and [
-        (rect>)
-    ] [
-        "Complex number must have real components" throw
-    ] if ; inline
-
-: >rect ( z -- x y ) dup real swap imaginary ; inline
-
-: >float-rect ( z -- x y )
-    >rect swap >float swap >float ; inline
-
 : (next-power-of-2) ( i n -- n )
     2dup >= [
         drop
@@ -132,6 +115,8 @@ PRIVATE>
 
 : next-power-of-2 ( m -- n ) 2 swap (next-power-of-2) ; foldable
 
+: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
+
 <PRIVATE
 
 : iterate-prep 0 -rot ; inline

core/math/parser/parser-tests.factor

@@ -77,22 +77,6 @@ unit-test
 [ "-101.0e-2" string>number number>string ]
 unit-test
 
-[ 5 ]
-[ "10/2" string>number ]
-unit-test
-
-[ -5 ]
-[ "-10/2" string>number ]
-unit-test
-
-[ -5 ]
-[ "10/-2" string>number ]
-unit-test
-
-[ 5 ]
-[ "-10/-2" string>number ]
-unit-test
-
 [ 5.0 ]
 [ "10.0/2" string>number ]
 unit-test
@@ -105,10 +89,6 @@ unit-test
 [ "e/2" string>number ]
 unit-test
 
-[ "33/100" ]
-[ "66/200" string>number number>string ]
-unit-test
-
 [ f ] [ "12" bin> ] unit-test
 [ f ] [ "fdsf" bin> ] unit-test
 [ 3 ] [ "11" bin> ] unit-test

core/optimizer/known-words/known-words.factor

@@ -6,7 +6,7 @@ inference.class kernel assocs math math.private kernel.private
 sequences words parser vectors strings sbufs io namespaces
 assocs quotations sequences.private io.binary io.crc32
 io.buffers io.streams.string layouts splitting math.intervals
-math.floats.private math.vectors tuples tuples.private classes
+math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
 float-arrays combinators.private ;
 
@@ -92,7 +92,7 @@ float-arrays combinators.private ;
 ] each
 
 ! Specializers
-{ 1+ 1- sq neg recip sgn truncate } [
+{ 1+ 1- sq neg recip sgn } [
     { number } "specializer" set-word-prop
 ] each
 
@@ -102,20 +102,6 @@ float-arrays combinators.private ;
     { number number } "specializer" set-word-prop
 ] each
 
-{ vneg norm-sq norm normalize } [
-    { { float-array array } } "specializer" set-word-prop
-] each
-
-\ n*v { * { float-array array } } "specializer" set-word-prop
-\ v*n { { float-array array } * } "specializer" set-word-prop
-\ n/v { * { float-array array } } "specializer" set-word-prop
-\ v/n { { float-array array } * } "specializer" set-word-prop
-
-{ v+ v- v* v/ vmax vmin v. } [
-    { { float-array array } { float-array array } }
-    "specializer" set-word-prop
-] each
-
 { first first2 first3 first4 }
 [ { array } "specializer" set-word-prop ] each
 

core/optimizer/math/math.factor

@@ -5,7 +5,7 @@ USING: alien arrays generic hashtables kernel assocs math
 math.private kernel.private sequences words parser
 inference.class inference.dataflow vectors strings sbufs io
 namespaces assocs quotations math.intervals sequences.private
-math.libm combinators splitting layouts math.parser classes
+combinators splitting layouts math.parser classes
 generic.math optimizer.pattern-match optimizer.backend
 optimizer.def-use generic.standard ;
 
@@ -439,17 +439,3 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
-
-! This will go away when we have cross-word type inference
-{
-    facos fasin fatan
-    fcos fexp fcosh flog fpow
-    fsin fsinh fsqrt
-} [
-    [ drop { float } f ]
-    "output-classes" set-word-prop
-] each
-
-\ fatan2
-[ drop { float float } f ]
-"output-classes" set-word-prop

core/prettyprint/backend/backend.factor

@@ -138,7 +138,6 @@ M: pathname pprint* dup pathname-string "P\" " pprint-string ;
 
 GENERIC: pprint-delims ( obj -- start end )
 
-M: complex pprint-delims drop \ C{ \ } ;
 M: quotation pprint-delims drop \ [ \ ] ;
 M: curry pprint-delims drop \ [ \ ] ;
 M: array pprint-delims drop \ { \ } ;
@@ -155,7 +154,6 @@ GENERIC: >pprint-sequence ( obj -- seq )
 
 M: object >pprint-sequence ;
 
-M: complex >pprint-sequence >rect 2array ;
 M: hashtable >pprint-sequence >alist ;
 M: tuple >pprint-sequence tuple>array ;
 M: wrapper >pprint-sequence wrapped 1array ;

core/prettyprint/prettyprint-tests.factor

@@ -7,7 +7,6 @@ IN: temporary
 
 [ "4" ] [ 4 unparse ] unit-test
 [ "1.0" ] [ 1.0 unparse ] unit-test
-[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test
 [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
 
 [ "+" ] [ \ + unparse ] unit-test

core/sequences/sequences-docs.factor

@@ -943,3 +943,21 @@ HELP: unclip
 HELP: unclip-slice
 { $values { "seq" sequence } { "rest" slice } { "first" object } }
 { $description "Outputs a tail sequence and the first element of " { $snippet "seq" } "; the tail sequence consists of all elements of " { $snippet "seq" } " but the first. Unlike " { $link unclip } ", this word does not make a copy of the input sequence, and runs in constant time." } ;
+
+HELP: sum
+{ $values { "seq" "a sequence of numbers" } { "n" "a number" } }
+{ $description "Outputs the sum of all elements of " { $snippet "seq" } ". Outputs zero given an empty sequence." } ;
+
+HELP: product
+{ $values { "seq" "a sequence of numbers" } { "n" "a number" } }
+{ $description "Outputs the product of all elements of " { $snippet "seq" } ". Outputs one given an empty sequence." } ;
+
+HELP: infimum
+{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
+{ $description "Outputs the least element of " { $snippet "seq" } "." }
+{ $errors "Throws an error if the sequence is empty." } ;
+
+HELP: supremum
+{ $values { "seq" "a sequence of real numbers" } { "n" "a number" } }
+{ $description "Outputs the greatest element of " { $snippet "seq" } "." }
+{ $errors "Throws an error if the sequence is empty." } ;

core/sequences/sequences-tests.factor

@@ -43,9 +43,9 @@ IN: temporary
 
 [ f ] [ CHAR: a 0 "tuvwxyz" >vector index* ] unit-test
 
-[ f ] [ [ "Hello" { } 4/3 ] [ string? ] all? ] unit-test
+[ f ] [ [ "Hello" { } 0.75 ] [ string? ] all? ] unit-test
 [ t ] [ [ ] [ ] all? ] unit-test
-[ t ] [ [ "hi" t 1/2 ] [ ] all? ] unit-test
+[ t ] [ [ "hi" t 0.5 ] [ ] all? ] unit-test
 
 [ [ 1 2 3 ] ] [ [ 1 4 2 5 3 6 ] [ 4 < ] subset ] unit-test
 [ { 4 2 6 } ] [ { 1 4 2 5 3 6 } [ 2 mod 0 = ] subset ] unit-test
@@ -68,8 +68,8 @@ unit-test
 [ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
 [ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
 [ t ] [ [ ] all-equal? ] unit-test
-[ t ] [ [ 1/2 ] all-equal? ] unit-test
+[ t ] [ [ 1234 ] all-equal? ] unit-test
-[ t ] [ [ 1.0 10/10 1 ] all-equal? ] unit-test
+[ t ] [ [ 1.0 1 1 ] all-equal? ] unit-test
 [ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
 [ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
 [ [ 2 3 4 ] ] [ [ 1 2 3 ] 1 [ + ] curry map ] unit-test
@@ -190,7 +190,7 @@ unit-test
     "cache-test" get
 ] unit-test
 
-[ 1 ] [ 1/2 { 1 2 3 } nth ] unit-test
+[ 1 ] [ 0.5 { 1 2 3 } nth ] unit-test
 
 ! Pathological case
 [ "ihbye" ] [ "hi" <reversed> "bye" append ] unit-test
@@ -236,9 +236,11 @@ unit-test
 
 [ -1./0. 0 delete-nth ] unit-test-fails
 [ "" ] [ "" [ blank? ] trim ] unit-test
-[ "" ] [ "" [ blank? ] ltrim ] unit-test
+[ "" ] [ "" [ blank? ] left-trim ] unit-test
-[ "" ] [ "" [ blank? ] rtrim ] unit-test
+[ "" ] [ "" [ blank? ] right-trim ] unit-test
+[ "" ] [ "  " [ blank? ] left-trim ] unit-test
+[ "" ] [ "  " [ blank? ] right-trim ] unit-test
 [ "asdf" ] [ " asdf " [ blank? ] trim ] unit-test
-[ "asdf " ] [ " asdf " [ blank? ] ltrim ] unit-test
+[ "asdf " ] [ " asdf " [ blank? ] left-trim ] unit-test
-[ " asdf" ] [ " asdf " [ blank? ] rtrim ] unit-test
+[ " asdf" ] [ " asdf " [ blank? ] right-trim ] unit-test
 

core/sequences/sequences.factor

@@ -414,6 +414,13 @@ PRIVATE>
 : interleave ( seq between quot -- )
     [ (interleave) ] 2curry iterate-seq 2each ; inline
 
+: unfold ( obj pred quot exemplar -- seq )
+    [
+        10 swap new-resizable [
+            [ push ] curry compose [ drop ] while
+        ] keep
+    ] keep like ; inline
+
 : index ( obj seq -- n )
     [ = ] curry* find drop ;
 
@@ -645,20 +652,19 @@ PRIVATE>
     dup slice? [ { } like ] when 0 over length rot <slice> ;
     inline
 
-: ltrim ( seq quot -- newseq )
+: left-trim ( seq quot -- newseq )
-    over >r [ not ] compose find drop
+    over >r [ not ] compose find drop r> swap
-    r> swap [ tail ] when* ; inline
+    [ tail ] [ dup length tail ] if* ; inline
 
-: rtrim ( seq quot -- newseq )
+: right-trim ( seq quot -- newseq )
-    over >r [ not ] compose find-last drop
+    over >r [ not ] compose find-last drop r> swap
-    r> swap [ 1+ head ] when* ; inline
+    [ 1+ head ] [ 0 head ] if* ; inline
 
 : trim ( seq quot -- newseq )
-    [ ltrim ] keep rtrim ; inline
+    [ left-trim ] keep right-trim ; inline
 
-: unfold ( obj pred quot exemplar -- seq )
+: sum ( seq -- n ) 0 [ + ] reduce ;
-    [
+: product ( seq -- n ) 1 [ * ] reduce ;
-        10 swap new-resizable [
+
-            [ push ] curry compose [ drop ] while
+: infimum ( seq -- n ) dup first [ min ] reduce ;
-        ] keep
+: supremum ( seq -- n ) dup first [ max ] reduce ;
-    ] keep like ; inline

core/syntax/syntax.factor

@@ -77,7 +77,6 @@ IN: bootstrap.syntax
 "?{" [ \ } [ >bit-array ] parse-literal ] define-syntax
 "F{" [ \ } [ >float-array ] parse-literal ] define-syntax
 "H{" [ \ } [ >hashtable ] parse-literal ] define-syntax
-"C{" [ \ } [ first2 rect> ] parse-literal ] define-syntax
 "T{" [ \ } [ >tuple ] parse-literal ] define-syntax
 "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
 
@@ -165,5 +164,3 @@ IN: bootstrap.syntax
 ] define-syntax
 
 "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
-
-"bootstrap.syntax" forget-vocab

core/threads/threads-tests.factor

@@ -8,6 +8,5 @@ IN: temporary
 [ ] [ [ "Errors, errors" throw ] in-thread ] unit-test
 yield
 
-[ ] [ 1/2 sleep ] unit-test
 [ ] [ 0.3 sleep ] unit-test
 [ "hey" sleep ] unit-test-fails

core/vectors/vectors-tests.factor

@@ -10,7 +10,7 @@ IN: temporary
 
 [ -3 V{ } nth ] unit-test-fails
 [ 3 V{ } nth ] unit-test-fails
-[ 3 C{ 1 2 } nth ] unit-test-fails
+[ 3 54.3 nth ] unit-test-fails
 
 [ "hey" [ 1 2 ] set-length ] unit-test-fails
 [ "hey" V{ 1 2 } set-length ] unit-test-fails

extra/benchmark/raytracer/raytracer.factor

@@ -2,7 +2,7 @@
 ! http://www.ffconsultancy.com/free/ray_tracer/languages.html
 
 USING: float-arrays compiler generic io io.files kernel math
-math.vectors math.parser namespaces sequences
+math.functions math.vectors math.parser namespaces sequences
 sequences.private words ;
 IN: benchmark.raytracer
 

extra/benchmark/spectral-norm/spectral-norm.factor

@@ -1,7 +1,7 @@
 ! Factor port of
 ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all
-USING: float-arrays kernel math math.vectors sequences
+USING: float-arrays kernel math math.functions math.vectors
-sequences.private prettyprint words tools.time hints ;
+sequences sequences.private prettyprint words tools.time hints ;
 IN: benchmark.spectral-norm
 
 : fast-truncate >fixnum >float ; inline

extra/boids/ui/ui.factor

@@ -1,6 +1,7 @@
 
 USING: kernel namespaces
        math
+       math.functions
        math.vectors
        math.parser
        hashtables sequences threads

extra/calendar/calendar.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays hashtables io io.streams.string kernel math
-math.vectors math.parser
+math.vectors math.functions math.parser
 namespaces sequences strings tuples system ;
 IN: calendar
 

extra/color-picker/color-picker.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2006, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.parser models sequences ui ui.gadgets
+USING: kernel math math.functions math.parser models sequences
-ui.gadgets.controls ui.gadgets.frames ui.gadgets.labels
+ui ui.gadgets ui.gadgets.controls ui.gadgets.frames
-ui.gadgets.packs ui.gadgets.sliders ui.render ;
+ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render
+;
 IN: color-picker
 
 ! Simple example demonstrating the use of models.

extra/colors/hsv/hsv.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2007 Eduardo Cavazos
 ! See http://factorcode.org/license.txt for BSD license.
 
-USING: kernel combinators arrays sequences math combinators.lib ;
+USING: kernel combinators arrays sequences math math.functions
+combinators.lib ;
 
 IN: colors.hsv
 

extra/crypto/sha1/sha1.factor

@@ -127,7 +127,7 @@ SYMBOL: K
 : file>sha1 ( file -- sha1 ) <file-reader> stream>sha1 ;
 
 : string>sha1-interleave ( string -- )
-    [ zero? ] ltrim
+    [ zero? ] left-trim
     dup length odd? [ 1 tail ] when
     seq>2seq [ string>sha1 ] 2apply
     swap 2seq>seq ;

extra/factory/commands/commands.factor

@@ -1,5 +1,5 @@
 
-USING: kernel combinators sequences math math.vectors mortar slot-accessors
+USING: kernel combinators sequences math math.functions math.vectors mortar slot-accessors
        x x.widgets.wm.root x.widgets.wm.frame combinators.lib ;
 
 IN: factory.commands

extra/io/windows/nt/backend/backend.factor

@@ -32,7 +32,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
                 dup first CHAR: \\ = [ CHAR: \\ , ] unless %
             ] "" make
         ] }
-    } cond [ "/\\." member? ] rtrim ;
+    } cond [ "/\\." member? ] right-trim ;
 
 SYMBOL: io-hash
 

extra/io/windows/windows.factor

@@ -17,7 +17,7 @@ M: windows-io (socket-destructor) ( obj -- )
     destructor-obj closesocket drop ;
 
 M: windows-io root-directory? ( path -- ? )
-    [ path-separator? ] rtrim
+    [ path-separator? ] right-trim
     dup length 2 = [
         dup first Letter?
         swap second CHAR: : = and

extra/irc/irc.factor

@@ -72,7 +72,7 @@ TUPLE: part-command channel text ;
 
 SYMBOL: irc-client
 : irc-stream> ( -- stream ) irc-client get irc-client-stream ;
-: trim-: ( seq -- seq ) [ CHAR: : = ] ltrim ;
+: trim-: ( seq -- seq ) [ CHAR: : = ] left-trim ;
 : parse-name ( string -- string )
     trim-: "!" split first ;
 : irc-split ( string -- seq )

extra/math/complex/complex-tests.factor

@@ -0,0 +1,68 @@
+USING: kernel math math.constants math.functions tools.test
+prettyprint ;
+IN: temporary
+
+[ 1 C{ 0 1 } rect> ] unit-test-fails
+[ C{ 0 1 } 1 rect> ] unit-test-fails
+
+[ f ] [ C{ 5 12.5 } 5  = ] unit-test
+[ t ] [ C{ 1.0 2.0 } C{ 1 2 }  = ] unit-test
+[ f ] [ C{ 1.0 2.3 } C{ 1 2 }  = ] unit-test
+
+[ C{ 2 5 } ] [ 2 5  rect> ] unit-test
+[ 2 5 ] [ C{ 2 5 }  >rect ] unit-test
+[ C{ 1/2 1 } ] [ 1/2 C{ 0 1 }  + ] unit-test
+[ C{ 1/2 1 } ] [ C{ 0 1 } 1/2  + ] unit-test
+[ t ] [ C{ 11 64 } C{ 11 64 }  = ] unit-test
+[ C{ 2 1 } ] [ 2 C{ 0 1 }  + ] unit-test
+[ C{ 2 1 } ] [ C{ 0 1 } 2  + ] unit-test
+[ C{ 5 4 } ] [ C{ 2 2 } C{ 3 2 }  + ] unit-test
+[ 5 ] [ C{ 2 2 } C{ 3 -2 }  + ] unit-test
+[ C{ 1.0 1 } ] [ 1.0 C{ 0 1 }  + ] unit-test
+
+[ C{ 1/2 -1 } ] [ 1/2 C{ 0 1 }  - ] unit-test
+[ C{ -1/2 1 } ] [ C{ 0 1 } 1/2  - ] unit-test
+[ C{ 1/3 1/4 } ] [ 1 3 / 1 2 / i* + 1 4 / i*  - ] unit-test
+[ C{ -1/3 -1/4 } ] [ 1 4 / i* 1 3 / 1 2 / i* +  - ] unit-test
+[ C{ 1/5 1/4 } ] [ C{ 3/5 1/2 } C{ 2/5 1/4 }  - ] unit-test
+[ 4 ] [ C{ 5 10/3 } C{ 1 10/3 }  - ] unit-test
+[ C{ 1.0 -1 } ] [ 1.0 C{ 0 1 }  - ] unit-test
+
+[ C{ 0 1 } ] [ C{ 0 1 } 1  * ] unit-test
+[ C{ 0 1 } ] [ 1 C{ 0 1 }  * ] unit-test
+[ C{ 0 1.0 } ] [ 1.0 C{ 0 1 }  * ] unit-test
+[ -1 ] [ C{ 0 1 } C{ 0 1 }  * ] unit-test
+[ C{ 0 1 } ] [ 1 C{ 0 1 }  * ] unit-test
+[ C{ 0 1 } ] [ C{ 0 1 } 1  * ] unit-test
+[ C{ 0 1/2 } ] [ 1/2 C{ 0 1 }  * ] unit-test
+[ C{ 0 1/2 } ] [ C{ 0 1 } 1/2  * ] unit-test
+[ 2 ] [ C{ 1 1 } C{ 1 -1 }  * ] unit-test
+[ 1 ] [ C{ 0 1 } C{ 0 -1 }  * ] unit-test
+
+[ -1 ] [ C{ 0 1 } C{ 0 -1 }  / ] unit-test
+[ C{ 0 1 } ] [ 1 C{ 0 -1 }  / ] unit-test
+[ t ] [ C{ 12 13 } C{ 13 14 } / C{ 13 14 } * C{ 12 13 }  = ] unit-test
+
+[ C{ -3 4 } ] [ C{ 3 -4 }  neg ] unit-test
+
+[ 5 ] [ C{ 3 4 } abs ] unit-test
+[ 5 ] [ -5.0 abs ] unit-test
+
+! Make sure arguments are sane
+[ 0 ] [ 0 arg ] unit-test
+[ 0 ] [ 1 arg ] unit-test
+[ t ] [ -1 arg 3.14 3.15 between? ] unit-test
+[ t ] [ C{ 0 1 } arg 1.57 1.58 between? ] unit-test
+[ t ] [ C{ 0 -1 } arg -1.58 -1.57 between? ] unit-test
+
+[ 1 0 ] [ 1 >polar ] unit-test
+[ 1 ] [ -1 >polar drop ] unit-test
+[ t ] [ -1 >polar nip 3.14 3.15 between? ] unit-test
+
+! I broke something
+[ ] [ C{ 1 4 } tanh drop ] unit-test
+[ ] [ C{ 1 4 } tan drop ] unit-test
+[ ] [ C{ 1 4 } coth drop ] unit-test
+[ ] [ C{ 1 4 } cot drop ] unit-test
+
+[ "C{ 1/2 2/3 }" ] [ C{ 1/2 2/3 } unparse ] unit-test

extra/math/complex/complex.factor

@@ -2,13 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: math.complex.private
 USING: kernel kernel.private math math.private
-math.libm math.functions ;
+math.libm math.functions prettyprint.backend arrays
+math.functions.private sequences parser ;
 
 M: real real ;
 M: real imaginary drop 0 ;
 
-M: number equal? number= ;
-
 M: complex absq >rect [ sq ] 2apply + ;
 
 : 2>rect ( x y -- xr yr xi yi )
@@ -34,3 +33,11 @@ M: complex abs absq >float fsqrt ;
 M: complex sqrt >polar swap fsqrt swap 2.0 / polar> ;
 
 M: complex hashcode* nip >rect >fixnum swap >fixnum bitxor ;
+
+IN: syntax
+
+: C{ \ } [ first2 rect> ] parse-literal ; parsing
+
+M: complex pprint-delims drop \ C{ \ } ;
+
+M: complex >pprint-sequence >rect 2array ;

extra/math/constants/constants-docs.factor

@@ -3,8 +3,6 @@ IN: math.constants
 
 ARTICLE: "math-constants" "Constants"
 "Standard mathematical constants:"
-{ $subsection i }
-{ $subsection -i }
 { $subsection e }
 { $subsection pi }
 "Various limits:"
@@ -14,12 +12,6 @@ ARTICLE: "math-constants" "Constants"
 
 ABOUT: "math-constants"
 
-HELP: i
-{ $values { "i" "the imaginary unit" } } ;
-
-HELP: -i
-{ $values { "-i" "the negated imaginary unit" } } ;
-
 HELP: e
 { $values { "e" "base of natural logarithm" } } ;
 

extra/math/constants/constants.factor

@@ -2,8 +2,6 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: math.constants
 
-: i ( -- i ) C{ 0 1 } ; inline
-: -i ( -- -i ) C{ 0 -1 } ; inline
 : e ( -- e ) 2.7182818284590452354 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline

extra/math/functions/functions-docs.factor

@@ -1,5 +1,5 @@
 USING: help.markup help.syntax kernel math
-sequences quotations ;
+sequences quotations math.functions.private ;
 IN: math.functions
 
 ARTICLE: "integer-functions" "Integer functions"
@@ -94,6 +94,19 @@ ARTICLE: "math-functions" "Mathematical functions"
 
 ABOUT: "math-functions"
 
+HELP: (rect>)
+{ $values { "x" real } { "y" real } { "z" number } }
+{ $description "Creates a complex number from real and imaginary components." }
+{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ;
+
+HELP: rect>
+{ $values { "x" real } { "y" real } { "z" number } }
+{ $description "Creates a complex number from real and imaginary components." } ;
+
+HELP: >rect
+{ $values { "z" number } { "x" real } { "y" real } }
+{ $description "Extracts the real and imaginary components of a complex number." } ;
+
 HELP: power-of-2?
 { $values { "n" integer } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "n" } " is a power of 2." } ;
@@ -281,3 +294,24 @@ HELP: ~
         { { $snippet "epsilon" } " is negative: relative distance test." }
     }
 } ;
+
+
+HELP: truncate
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the number that results from subtracting the fractional component of " { $snippet "x" } "." }
+{ $notes "The result is not necessarily an integer." } ;
+
+HELP: floor
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the greatest whole number smaller than or equal to " { $snippet "x" } "." }
+{ $notes "The result is not necessarily an integer." } ;
+
+HELP: ceiling
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the least whole number greater than or equal to " { $snippet "x" } "." }
+{ $notes "The result is not necessarily an integer." } ;
+
+HELP: round
+{ $values { "x" real } { "y" "a whole real number" } }
+{ $description "Outputs the whole number closest to " { $snippet "x" } "." }
+{ $notes "The result is not necessarily an integer." } ;

extra/math/functions/functions-tests.factor

@@ -74,3 +74,34 @@ IN: temporary
 [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
 
 [ 2 10 mod-inv ] unit-test-fails
+
+[ t ] [ 0 0 ^ fp-nan? ] unit-test
+[ 1 ] [ 10 0 ^ ] unit-test
+[ 1/8 ] [ 1/2 3 ^ ] unit-test
+[ 1/8 ] [ 2 -3 ^ ] unit-test
+[ t ] [ 1 100 shift 2 100 ^ = ] unit-test
+
+[ t ] [ 256 power-of-2? ] unit-test
+[ f ] [ 123 power-of-2? ] unit-test
+
+[ 1 ] [ 7/8 ceiling ] unit-test
+[ 2 ] [ 3/2 ceiling ] unit-test
+[ 0 ] [ -7/8 ceiling ] unit-test
+[ -1 ] [ -3/2 ceiling ] unit-test
+
+[ 4.0 ] [ 4.5 truncate ] unit-test
+[ 4.0 ] [ 4.5 floor ] unit-test
+[ 5.0 ] [ 4.5 ceiling ] unit-test
+
+[ -4.0 ] [ -4.5 truncate ] unit-test
+[ -5.0 ] [ -4.5 floor ] unit-test
+[ -4.0 ] [ -4.5 ceiling ] unit-test
+
+[ -4.0 ] [ -4.0 truncate ] unit-test
+[ -4.0 ] [ -4.0 floor ] unit-test
+[ -4.0 ] [ -4.0 ceiling ] unit-test
+
+[ -5.0 ] [ -4.5 round ] unit-test
+[ -4.0 ] [ -4.4 round ] unit-test
+[ 5.0 ] [ 4.5 round ] unit-test
+[ 4.0 ] [ 4.4 round ] unit-test

extra/math/functions/functions.factor

@@ -1,8 +1,28 @@
 ! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math kernel math.constants math.libm combinators ;
+USING: math kernel math.constants math.private
+math.libm combinators ;
 IN: math.functions
 
+<PRIVATE
+
+: (rect>) ( x y -- z )
+    dup zero? [ drop ] [ <complex> ] if ; inline
+
+PRIVATE>
+
+: rect> ( x y -- z )
+    over real? over real? and [
+        (rect>)
+    ] [
+        "Complex number must have real components" throw
+    ] if ; inline
+
+GENERIC: sqrt ( x -- y ) foldable
+
+M: real sqrt
+    >float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
+
 : each-bit ( n quot -- )
     over 0 number= pick -1 number= or [
         2drop
@@ -62,8 +82,12 @@ M: integer (^)
 
 GENERIC: abs ( x -- y ) foldable
 
+M: real abs dup 0 < [ neg ] when ;
+
 GENERIC: absq ( x -- y ) foldable
 
+M: real absq sq ;
+
 : ~abs ( x y epsilon -- ? )
     >r - abs r> < ;
 
@@ -81,10 +105,13 @@ GENERIC: absq ( x -- y ) foldable
 : power-of-2? ( n -- ? )
     dup 0 < [ drop f ] [ dup 1- bitand zero? ] if ; foldable
 
-: align ( m w -- n ) 1- [ + ] keep bitnot bitand ; inline
+: >rect ( z -- x y ) dup real swap imaginary ; inline
 
 : conjugate ( z -- z* ) >rect neg rect> ; inline
 
+: >float-rect ( z -- x y )
+    >rect swap >float swap >float ; inline
+
 : arg ( z -- arg ) >float-rect swap fatan2 ; inline
 
 : >polar ( z -- abs arg )
@@ -160,6 +187,10 @@ M: number (^)
 : [-1,1]? ( x -- ? )
     dup complex? [ drop f ] [ abs 1 <= ] if ; inline
 
+: i* ( x -- y ) >rect neg swap rect> ;
+
+: -i* ( x -- y ) >rect swap neg rect> ;
+
 : asin ( x -- y )
     dup [-1,1]? [ >float fasin ] [ i* asinh -i* ] if ; inline
 
@@ -175,3 +206,13 @@ M: number (^)
 : acosec ( x -- y ) recip asin ; inline
 
 : acot ( x -- y ) recip atan ; inline
+
+: truncate ( x -- y ) dup 1 mod - ; inline
+
+: round ( x -- y ) dup sgn 2 / + truncate ; inline
+
+: floor ( x -- y )
+    dup 1 mod dup zero?
+    [ drop ] [ dup 0 < [ - 1- ] [ - ] if ] if ; foldable
+
+: ceiling ( x -- y ) neg floor neg ; foldable

extra/math/polynomials/polynomials.factor

@@ -22,7 +22,7 @@ PRIVATE>
 : p= ( p p -- ? ) pextend = ;
 
 : ptrim ( p -- p )
-    dup length 1 = [ [ zero? ] rtrim ] unless ;
+    dup length 1 = [ [ zero? ] right-trim ] unless ;
 
 : 2ptrim ( p p -- p p ) [ ptrim ] 2apply ;
 : p+ ( p p -- p ) pextend v+ ;