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

basis/colors/constants/constants.factor

@@ -11,23 +11,23 @@ IN: colors.constants
     [ [ string>number 255 /f ] tri@ 1.0 <rgba> ] dip
     [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap ;
 
-: parse-rgb.txt ( lines -- assoc )
+: parse-colors ( lines -- assoc )
     [ "!" head? not ] filter
     [ 11 cut [ " \t" split harvest ] dip suffix ] map
     [ parse-color ] H{ } map>assoc ;
 
-MEMO: rgb.txt ( -- assoc )
+MEMO: colors ( -- assoc )
     "resource:basis/colors/constants/rgb.txt"
     "resource:basis/colors/constants/factor-colors.txt"
-    [ utf8 file-lines parse-rgb.txt ] bi@ assoc-union ;
+    [ utf8 file-lines parse-colors ] bi@ assoc-union ;
 
 PRIVATE>
 
-: named-colors ( -- keys ) rgb.txt keys ;
+: named-colors ( -- keys ) colors keys ;
 
 ERROR: no-such-color name ;
 
 : named-color ( name -- color )
-    dup rgb.txt at [ ] [ no-such-color ] ?if ;
+    dup colors at [ ] [ no-such-color ] ?if ;
 
 SYNTAX: COLOR: scan named-color parsed ;

basis/colors/constants/factor-colors.txt

@@ -1,6 +1,6 @@
 ! Factor UI theme colors
-243 242 234		FactorLightLightTan
+243 242 234		FactorLightTan
-227 226 219		FactorLightTan
+227 226 219		FactorTan
 172 167 147		FactorDarkTan
  81  91 105		FactorLightSlateBlue
  55  62  72		FactorDarkSlateBlue

basis/compiler/cfg/builder/builder-tests.factor

@@ -192,14 +192,16 @@ IN: compiler.cfg.builder.tests
     [ [ ##unbox-alien? ] contains-insn? ] bi
 ] unit-test
 
-[ f t ] [
+\ alien-float "intrinsic" word-prop [
-    [ { byte-array fixnum } declare alien-cell 4 alien-float ]
+    [ f t ] [
-    [ [ ##box-alien? ] contains-insn? ]
+        [ { byte-array fixnum } declare alien-cell 4 alien-float ]
-    [ [ ##box-float? ] contains-insn? ] bi
+        [ [ ##box-alien? ] contains-insn? ]
-] unit-test
+        [ [ ##box-float? ] contains-insn? ] bi
+    ] unit-test
 
-[ f t ] [
+    [ f t ] [
-    [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
+        [ { byte-array fixnum } declare alien-cell { simple-alien } declare 4 alien-float ]
-    [ [ ##box-alien? ] contains-insn? ]
+        [ [ ##box-alien? ] contains-insn? ]
-    [ [ ##box-float? ] contains-insn? ] bi
+        [ [ ##box-float? ] contains-insn? ] bi
-] unit-test
+    ] unit-test
+] when

basis/compiler/cfg/intrinsics/float/float.factor

@@ -7,7 +7,10 @@ IN: compiler.cfg.intrinsics.float
 : emit-float-op ( insn -- )
     [ 2inputs ] dip call ds-push ; inline
 
-: emit-float-comparison ( cc -- )
+: emit-float-ordered-comparison ( cc -- )
+    [ 2inputs ] dip ^^compare-float-ordered ds-push ; inline
+
+: emit-float-unordered-comparison ( cc -- )
     [ 2inputs ] dip ^^compare-float-unordered ds-push ; inline
 
 : emit-float>fixnum ( -- )

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -86,13 +86,18 @@ IN: compiler.cfg.intrinsics
         { math.private:float- [ drop [ ^^sub-float ] emit-float-op ] }
         { math.private:float* [ drop [ ^^mul-float ] emit-float-op ] }
         { math.private:float/f [ drop [ ^^div-float ] emit-float-op ] }
-        { math.private:float< [ drop cc< emit-float-comparison ] }
+        { math.private:float< [ drop cc< emit-float-ordered-comparison ] }
-        { math.private:float<= [ drop cc<= emit-float-comparison ] }
+        { math.private:float<= [ drop cc<= emit-float-ordered-comparison ] }
-        { math.private:float>= [ drop cc>= emit-float-comparison ] }
+        { math.private:float>= [ drop cc>= emit-float-ordered-comparison ] }
-        { math.private:float> [ drop cc> emit-float-comparison ] }
+        { math.private:float> [ drop cc> emit-float-ordered-comparison ] }
-        { math.private:float= [ drop cc= emit-float-comparison ] }
+        { math.private:float-u< [ drop cc< emit-float-unordered-comparison ] }
+        { math.private:float-u<= [ drop cc<= emit-float-unordered-comparison ] }
+        { math.private:float-u>= [ drop cc>= emit-float-unordered-comparison ] }
+        { math.private:float-u> [ drop cc> emit-float-unordered-comparison ] }
+        { math.private:float= [ drop cc= emit-float-unordered-comparison ] }
         { math.private:float>fixnum [ drop emit-float>fixnum ] }
         { math.private:fixnum>float [ drop emit-fixnum>float ] }
+        { math.floats.private:float-unordered? [ drop cc/<>= emit-float-unordered-comparison ] }
         { alien.accessors:alien-float [ float-rep emit-alien-float-getter ] }
         { alien.accessors:set-alien-float [ float-rep emit-alien-float-setter ] }
         { alien.accessors:alien-double [ double-rep emit-alien-float-getter ] }
@@ -124,6 +129,7 @@ IN: compiler.cfg.intrinsics
         { math.libm:ftanh [ drop "tanh" emit-unary-float-function ] }
         { math.libm:fexp [ drop "exp" emit-unary-float-function ] }
         { math.libm:flog [ drop "log" emit-unary-float-function ] }
+        { math.libm:flog10 [ drop "log10" emit-unary-float-function ] }
         { math.libm:fpow [ drop "pow" emit-binary-float-function ] }
         { math.libm:facosh [ drop "acosh" emit-unary-float-function ] }
         { math.libm:fasinh [ drop "asinh" emit-unary-float-function ] }

basis/compiler/tests/float.factor

@@ -88,3 +88,15 @@ IN: compiler.tests.float
 [ 17.5 ] [ 17.5 -11.3 [ float-max ] compile-call ] unit-test
 [ -11.3 ] [ -11.3 17.5 [ float-min ] compile-call ] unit-test
 [ -11.3 ] [ 17.5 -11.3 [ float-min ] compile-call ] unit-test
+
+[ t ] [ 0/0. 0/0. [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 0/0. 1.0 [ float-unordered? ] compile-call ] unit-test
+[ t ] [ 1.0 0/0. [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 3.0 1.0 [ float-unordered? ] compile-call ] unit-test
+[ f ] [ 1.0 3.0 [ float-unordered? ] compile-call ] unit-test
+
+[ 1 ] [ 0/0. 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 0/0. 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 1 ] [ 1.0 0/0. [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 3.0 1.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test
+[ 2 ] [ 1.0 3.0 [ float-unordered? [ 1 ] [ 2 ] if ] compile-call ] unit-test

basis/compiler/tree/comparisons/comparisons.factor

@@ -1,28 +1,36 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.order math.intervals assocs combinators ;
 IN: compiler.tree.comparisons
 
 ! Some utilities for working with comparison operations.
 
-CONSTANT: comparison-ops { < > <= >= }
+CONSTANT: comparison-ops { < > <= >= u< u> u<= u>= }
 
 CONSTANT: generic-comparison-ops { before? after? before=? after=? }
 
 : assumption ( i1 i2 op -- i3 )
     {
-        { \ <  [ assume< ] }
+        { \ <   [ assume< ] }
-        { \ >  [ assume> ] }
+        { \ >   [ assume> ] }
-        { \ <= [ assume<= ] }
+        { \ <=  [ assume<= ] }
-        { \ >= [ assume>= ] }
+        { \ >=  [ assume>= ] }
+        { \ u<  [ assume< ] }
+        { \ u>  [ assume> ] }
+        { \ u<= [ assume<= ] }
+        { \ u>= [ assume>= ] }
     } case ;
 
 : interval-comparison ( i1 i2 op -- result )
     {
-        { \ <  [ interval< ] }
+        { \ <   [ interval< ] }
-        { \ >  [ interval> ] }
+        { \ >   [ interval> ] }
-        { \ <= [ interval<= ] }
+        { \ <=  [ interval<= ] }
-        { \ >= [ interval>= ] }
+        { \ >=  [ interval>= ] }
+        { \ u<  [ interval< ] }
+        { \ u>  [ interval> ] }
+        { \ u<= [ interval<= ] }
+        { \ u>= [ interval>= ] }
     } case ;
 
 : swap-comparison ( op -- op' )
@@ -31,6 +39,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
         { > < }
         { <= >= }
         { >= <= }
+        { u< u> }
+        { u> u< }
+        { u<= u>= }
+        { u>= u<= }
     } at ;
 
 : negate-comparison ( op -- op' )
@@ -39,6 +51,10 @@ CONSTANT: generic-comparison-ops { before? after? before=? after=? }
         { > <= }
         { <= > }
         { >= < }
+        { u< u>= }
+        { u> u<= }
+        { u<= u> }
+        { u>= u< }
     } at ;
 
 : specific-comparison ( op -- op' )

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

@@ -23,7 +23,7 @@ IN: compiler.tree.propagation.known-words
 { + - * / }
 [ { number number } "input-classes" set-word-prop ] each
 
-{ /f < > <= >= }
+{ /f < > <= >= u< u> u<= u>= }
 [ { real real } "input-classes" set-word-prop ] each
 
 { /i mod /mod }
@@ -34,21 +34,6 @@ IN: compiler.tree.propagation.known-words
 
 \ bitnot { integer } "input-classes" set-word-prop
 
-: real-op ( info quot -- quot' )
-    [
-        dup class>> real classes-intersect?
-        [ clone ] [ drop real <class-info> ] if
-    ] dip
-    change-interval ; inline
-
-{ bitnot fixnum-bitnot bignum-bitnot } [
-    [ [ interval-bitnot ] real-op ] "outputs" set-word-prop
-] each
-
-\ abs [ [ interval-abs ] real-op ] "outputs" set-word-prop
-
-\ absq [ [ interval-absq ] real-op ] "outputs" set-word-prop
-
 : math-closure ( class -- newclass )
     { fixnum bignum integer rational float real number object }
     [ class<= ] with find nip ;
@@ -56,15 +41,6 @@ IN: compiler.tree.propagation.known-words
 : fits-in-fixnum? ( interval -- ? )
     fixnum-interval interval-subset? ;
 
-: binary-op-class ( info1 info2 -- newclass )
-    [ class>> ] bi@
-    2dup [ null-class? ] either? [ 2drop null ] [
-        [ math-closure ] bi@ math-class-max
-    ] if ;
-
-: binary-op-interval ( info1 info2 quot -- newinterval )
-    [ [ interval>> ] bi@ ] dip call ; inline
-
 : won't-overflow? ( class interval -- ? )
     [ fixnum class<= ] [ fits-in-fixnum? ] bi* and ;
 
@@ -101,6 +77,36 @@ IN: compiler.tree.propagation.known-words
         [ drop float ] dip
     ] unless ;
 
+: unary-op-class ( info -- newclass )
+    class>> dup null-class? [ drop null ] [ math-closure ] if ;
+
+: unary-op-interval ( info quot -- newinterval )
+    [ interval>> ] dip call ; inline
+
+: unary-op ( word interval-quot post-proc-quot -- )
+    '[
+        [ unary-op-class ] [ _ unary-op-interval ] bi
+        @
+        <class/interval-info>
+    ] "outputs" set-word-prop ;
+
+{ bitnot fixnum-bitnot bignum-bitnot } [
+    [ interval-bitnot ] [ integer-valued ] unary-op
+] each
+
+\ abs [ interval-abs ] [ may-overflow real-valued ] unary-op
+
+\ absq [ interval-absq ] [ may-overflow real-valued ] unary-op
+
+: binary-op-class ( info1 info2 -- newclass )
+    [ class>> ] bi@
+    2dup [ null-class? ] either? [ 2drop null ] [
+        [ math-closure ] bi@ math-class-max
+    ] if ;
+
+: binary-op-interval ( info1 info2 quot -- newinterval )
+    [ [ interval>> ] bi@ ] dip call ; inline
+
 : binary-op ( word interval-quot post-proc-quot -- )
     '[
         [ binary-op-class ] [ _ binary-op-interval ] 2bi

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

@@ -31,6 +31,8 @@ IN: compiler.tree.propagation.tests
 
 [ V{ 69 } ] [ [ [ 69 ] [ 69 ] if ] final-literals ] unit-test
 
+[ V{ integer } ] [ [ bitnot ] final-classes ] unit-test
+
 [ V{ fixnum } ] [ [ { fixnum } declare bitnot ] final-classes ] unit-test
 
 ! Test type propagation for math ops
@@ -164,6 +166,18 @@ IN: compiler.tree.propagation.tests
 
 [ t ] [ [ absq ] final-info first interval>> [0,inf] = ] unit-test
 
+[ t ] [ [ { fixnum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { fixnum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare abs ] final-classes ] unit-test
+
+[ V{ integer } ] [ [ { fixnum } declare absq ] final-classes ] unit-test
+
+[ t ] [ [ { bignum } declare abs ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
+[ t ] [ [ { bignum } declare absq ] final-info first interval>> [0,inf] interval-subset? ] unit-test
+
 [ t ] [ [ { float } declare abs ] final-info first interval>> [0,inf] = ] unit-test
 
 [ t ] [ [ { float } declare absq ] final-info first interval>> [0,inf] = ] unit-test
@@ -247,6 +261,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 u<= [ dup 1.5 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
 [ V{ 1.5 } ] [
     [
         /f
@@ -254,6 +275,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ 1.5 } ] [
+    [
+        /f
+        dup 1.5 u<= [ dup 10 u>= [ ] [ drop 1.5 ] if ] [ drop 1.5 ] if
+    ] final-literals
+] unit-test
+
 [ V{ f } ] [
     [
         /f
@@ -261,6 +289,13 @@ IN: compiler.tree.propagation.tests
     ] final-literals
 ] unit-test
 
+[ V{ f } ] [
+    [
+        /f
+        dup 0.0 u<= [ dup 0.0 u>= [ drop 0.0 ] unless ] [ drop 0.0 ] if
+    ] final-literals
+] unit-test
+
 [ V{ fixnum } ] [
     [ 0 dup 10 > [ 100 * ] when ] final-classes
 ] unit-test
@@ -269,6 +304,14 @@ IN: compiler.tree.propagation.tests
     [ 0 dup 10 > [ drop "foo" ] when ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ 0 dup 10 u> [ 100 * ] when ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ 0 dup 10 u> [ drop "foo" ] when ] final-classes
+] unit-test
+
 [ V{ fixnum } ] [
     [ { fixnum } declare 3 3 - + ] final-classes
 ] unit-test
@@ -277,6 +320,10 @@ IN: compiler.tree.propagation.tests
     [ dup 10 < [ 3 * 30 < ] [ drop t ] if ] final-literals
 ] unit-test
 
+[ V{ t } ] [
+    [ dup 10 u< [ 3 * 30 u< ] [ drop t ] if ] final-literals
+] unit-test
+
 [ V{ "d" } ] [
     [
         3 {
@@ -300,10 +347,18 @@ IN: compiler.tree.propagation.tests
     [ >fixnum dup 100 < [ 1 + ] [ "Oops" throw ] if ] final-classes
 ] unit-test
 
+[ V{ fixnum } ] [
+    [ >fixnum dup 100 u< [ 1 + ] [ "Oops" throw ] if ] final-classes
+] unit-test
+
 [ V{ -1 } ] [
     [ 0 dup 100 < not [ 1 + ] [ 1 - ] if ] final-literals
 ] unit-test
 
+[ V{ -1 } ] [
+    [ 0 dup 100 u< not [ 1 + ] [ 1 - ] if ] final-literals
+] unit-test
+
 [ V{ 2 } ] [
     [ [ 1 ] [ 1 ] if 1 + ] final-literals
 ] unit-test
@@ -312,12 +367,22 @@ IN: compiler.tree.propagation.tests
     [ 0 * 10 < ] final-classes
 ] unit-test
 
+[ V{ object } ] [
+    [ 0 * 10 u< ] final-classes
+] unit-test
+
 [ V{ 27 } ] [
     [
         123 bitand dup 10 < over 8 > and [ 3 * ] [ "B" throw ] if
     ] final-literals
 ] unit-test
 
+[ V{ 27 } ] [
+    [
+        123 bitand dup 10 u< over 8 u> and [ 3 * ] [ "B" throw ] if
+    ] final-literals
+] unit-test
+
 [ V{ 27 } ] [
     [
         dup number? over sequence? and [

basis/core-foundation/core-foundation.factor

@@ -8,11 +8,16 @@ TYPEDEF: void* CFTypeRef
 TYPEDEF: void* CFAllocatorRef
 CONSTANT: kCFAllocatorDefault f
 
-TYPEDEF: bool Boolean
+TYPEDEF: bool      Boolean
-TYPEDEF: long CFIndex
+TYPEDEF: long      CFIndex
-TYPEDEF: char UInt8
+TYPEDEF: uchar     UInt8
-TYPEDEF: int SInt32
+TYPEDEF: ushort    UInt16
-TYPEDEF: uint UInt32
+TYPEDEF: uint      UInt32
+TYPEDEF: ulonglong UInt64
+TYPEDEF: char      SInt8
+TYPEDEF: short     SInt16
+TYPEDEF: int       SInt32
+TYPEDEF: longlong  SInt64
 TYPEDEF: ulong CFTypeID
 TYPEDEF: UInt32 CFOptionFlags
 TYPEDEF: void* CFUUIDRef
@@ -32,3 +37,4 @@ FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
 FUNCTION: void CFRelease ( CFTypeRef cf ) ;
 
 DESTRUCTOR: CFRelease
+

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

@@ -54,11 +54,7 @@ FUNCTION: void CFRunLoopRemoveTimer (
     CFStringRef mode
 ) ;
 
-: CFRunLoopDefaultMode ( -- alien )
+CFSTRING: CFRunLoopDefaultMode "kCFRunLoopDefaultMode"
-    #! Ugly, but we don't have static NSStrings
-    \ CFRunLoopDefaultMode [
-        "kCFRunLoopDefaultMode" <CFString>
-    ] initialize-alien ;
 
 TUPLE: run-loop fds sources timers ;
 

basis/core-foundation/strings/strings.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.syntax alien.strings io.encodings.string kernel
 sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors ;
+core-foundation.arrays destructors parser fry alien words ;
 IN: core-foundation.strings
 
 TYPEDEF: void* CFStringRef
@@ -83,3 +83,8 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
 
 : <CFStringArray> ( seq -- alien )
     [ [ <CFString> &CFRelease ] map <CFArray> ] with-destructors ;
+
+SYNTAX: CFSTRING: 
+    CREATE scan-object 
+    [ drop ] [ '[ _ [ _ <CFString> ] initialize-alien ] ] 2bi
+    (( -- alien )) define-declared ;

basis/help/stylesheet/stylesheet.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors colors.constants io.styles literals namespaces ;
+USING: colors colors.constants io.styles namespaces ;
 IN: help.stylesheet
 
 SYMBOL: default-span-style
@@ -34,7 +34,7 @@ H{
     { font-style bold }
     { wrap-margin 500 }
     { foreground COLOR: gray20 }
-    { page-color COLOR: FactorLightLightTan }
+    { page-color COLOR: FactorLightTan }
     { inset { 5 5 } }
 } title-style set-global
 
@@ -42,7 +42,7 @@ SYMBOL: help-path-style
 H{
     { font-size 10 }
     { table-gap { 5 5 } }
-    { table-border $ transparent }
+    { table-border COLOR: FactorLightTan }
 } help-path-style set-global
 
 SYMBOL: heading-style
@@ -75,7 +75,7 @@ H{
 
 SYMBOL: code-style
 H{
-    { page-color COLOR: FactorLightLightTan }
+    { page-color COLOR: FactorLightTan }
     { inset { 5 5 } }
     { wrap-margin f }
 } code-style set-global
@@ -113,7 +113,7 @@ H{
 SYMBOL: table-style
 H{
     { table-gap { 5 5 } }
-    { table-border COLOR: FactorLightTan }
+    { table-border COLOR: FactorTan }
 } table-style set-global
 
 SYMBOL: list-style

basis/help/vocabs/vocabs.factor

@@ -227,6 +227,18 @@ C: <vocab-author> vocab-author
         ] bi
     ] unless-empty ;
 
+: vocab-is-not-loaded ( vocab -- )
+    "Not loaded" $heading
+    "You must first load this vocabulary to browse its documentation and words."
+    print-element vocab-name "USE: " prepend 1array $code ;
+
+: describe-words ( vocab -- )
+    {
+        { [ dup vocab ] [ words $words ] }
+        { [ dup find-vocab-root ] [ vocab-is-not-loaded ] }
+        [ drop ]
+    } cond ;
+
 : words. ( vocab -- )
     last-element off
     [ require ] [ words $words ] bi nl ;
@@ -243,7 +255,7 @@ C: <vocab-author> vocab-author
     first {
         [ describe-help ]
         [ describe-metadata ]
-        [ words $words ]
+        [ describe-words ]
         [ describe-files ]
         [ describe-children ]
     } cleave ;

basis/io/files/info/unix/openbsd/openbsd.factor

@@ -6,7 +6,7 @@ sequences system unix unix.getfsstat.openbsd grouping
 unix.statfs.openbsd unix.statvfs.openbsd unix.types
 arrays io.files.info.unix classes.struct
 specialized-arrays io.encodings.utf8 ;
-SPECIALIZED-ARRAY: statvfs
+SPECIALIZED-ARRAY: statfs
 IN: io.files.unix.openbsd
 
 TUPLE: openbsd-file-system-info < unix-file-system-info

basis/math/floats/env/env-docs.factor

@@ -1,5 +1,5 @@
 ! (c)Joe Groff bsd license
-USING: help help.markup help.syntax quotations ;
+USING: help help.markup help.syntax kernel quotations ;
 IN: math.floats.env
 
 HELP: fp-exception
@@ -97,13 +97,21 @@ HELP: fp-traps
 
 HELP: with-fp-traps
 { $values { "exceptions" "a sequence of " { $link fp-exception } " symbols" } { "quot" quotation } }
-{ $description "Replaces the floating-point exception mask to enable processor traps to be raised for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
+{ $description "Clears the floating-point exception flags and replaces the exception mask, enabling processor traps for the set of exception conditions specified in " { $snippet "exceptions" } " for the dynamic extent of " { $snippet "quot" } ". The original exception mask is restored on " { $snippet "quot" } "'s completion." } ;
 
 HELP: without-fp-traps
 { $values { "quot" quotation } }
 { $description "Disables all floating-pointer processor traps for the dynamic extent of " { $snippet "quot" } ", restoring the original exception mask on " { $snippet "quot" } "'s completion." } ;
 
-{ fp-traps with-fp-traps without-fp-traps } related-words
+{ fp-traps with-fp-traps without-fp-traps vm-error>exception-flags vm-error-exception-flag? } related-words
+
+HELP: vm-error>exception-flags
+{ $values { "error" "a floating-point error object from the Factor VM" } { "exceptions" "a sequence of " { $link fp-exception } " symbols" } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word extracts the exception flag information from " { $snippet "error" } " and converts it into a sequence of " { $link fp-exception } "s." } ;
+
+HELP: vm-error-exception-flag?
+{ $values { "error" "a floating-point error object from the Factor VM" } { "flag" fp-exception } { "?" boolean } }
+{ $description "When a floating-point trap is raised, the Factor VM reports the trap by throwing a Factor exception containing the exception flags at the time the trap was raised. This word returns a boolean indicating whether the exception " { $snippet "flag" } " was raised at the time " { $snippet "error" } " was thrown." } ;
 
 ARTICLE: "math.floats.env" "Controlling the floating-point environment"
 "The " { $vocab-link "math.floats.env" } " vocabulary contains words for querying and controlling the floating-point environment."
@@ -117,11 +125,13 @@ $nl
 { $subsection fp-traps }
 { $subsection with-fp-traps }
 { $subsection without-fp-traps }
+"Getting the floating-point exception state from errors raised by enabled traps:"
+{ $subsection vm-error>exception-flags }
+{ $subsection vm-error-exception-flag? }
 "Querying and controlling the rounding mode and treatment of denormals:"
 { $subsection rounding-mode }
 { $subsection with-rounding-mode }
 { $subsection denormal-mode }
-{ $subsection with-denormal-mode }
+{ $subsection with-denormal-mode } ;
-{ $notes "On PowerPC, the above words only modify the scalar FPU's state (in FPSCR); the AltiVec unit is currently unaffected." } ;
 
 ABOUT: "math.floats.env"

basis/math/floats/env/env-tests.factor

@@ -1,5 +1,7 @@
 USING: kernel math math.floats.env math.floats.env.private
-math.functions math.libm sequences tools.test ;
+math.functions math.libm sequences tools.test locals
+compiler.units kernel.private fry compiler math.private words
+system ;
 IN: math.floats.env.tests
 
 : set-default-fp-env ( -- )
@@ -8,45 +10,35 @@ IN: math.floats.env.tests
 ! In case the tests screw up the FP env because of bugs in math.floats.env
 set-default-fp-env
 
-[ t ] [
+: test-fp-exception ( exception inputs quot -- quot' )
-    [ 1.0 0.0 / drop ] collect-fp-exceptions
+    '[ _ [ @ @ ] collect-fp-exceptions nip member? ] ;
-    +fp-zero-divide+ swap member?
-] unit-test
 
-[ t ] [
+: test-fp-exception-compiled ( exception inputs quot -- quot' )
-    [ 1.0 3.0 / drop ] collect-fp-exceptions
+    '[ _ @ [ _ collect-fp-exceptions ] compile-call nip member? ] ;
-    +fp-inexact+ swap member?
-] unit-test
 
-[ t ] [
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception unit-test
-    [ 1.0e250 1.0e100 * drop ] collect-fp-exceptions
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception unit-test
-    +fp-overflow+ swap member?
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception unit-test
-] unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception unit-test
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception unit-test
 
-[ t ] [
+[ t ] +fp-zero-divide+ [ 1.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
-    [ 1.0e-250 1.0e-100 * drop ] collect-fp-exceptions
+[ t ] +fp-inexact+ [ 1.0 3.0 ] [ /f ] test-fp-exception-compiled unit-test
-    +fp-underflow+ swap member?
+[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
-] unit-test
+[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
+[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
 
-[ t ] [
+! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
-    [ 2.0 100,000.0 ^ drop ] collect-fp-exceptions
+! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113
-    +fp-overflow+ swap member?
+os linux? cpu x86.64? and [
-] unit-test
+    [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception unit-test
+    [ t ] +fp-underflow+ [ 2.0 -100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
+] unless
 
-[ t ] [
+[ t ] +fp-invalid-operation+ [ 0.0 0.0 ] [ /f ] test-fp-exception-compiled unit-test
-    [ 2.0 -100,000.0 ^ drop ] collect-fp-exceptions
+[ t ] +fp-invalid-operation+ [ -1.0 ] [ fsqrt ] test-fp-exception-compiled unit-test
-    +fp-underflow+ swap member?
-] unit-test
-
-[ t ] [
-    [ 0.0 0.0 /f drop ] collect-fp-exceptions
-    +fp-invalid-operation+ swap member?
-] unit-test
-
-[ t ] [
-    [ -1.0 fsqrt drop ] collect-fp-exceptions
-    +fp-invalid-operation+ swap member?
-] unit-test
 
 [
     HEX: 3fd5,5555,5555,5555
@@ -117,11 +109,72 @@ set-default-fp-env
     -1.0 3.0 /f double>bits
 ] unit-test
 
-[ { +fp-zero-divide+ }       [ 1.0 0.0 /f ] with-fp-traps ] must-fail
+: test-traps ( traps inputs quot -- quot' )
-[ { +fp-inexact+ }           [ 1.0 3.0 /f ] with-fp-traps ] must-fail
+    append '[ _ _ with-fp-traps ] ;
-[ { +fp-invalid-operation+ } [ -1.0 fsqrt ] with-fp-traps ] must-fail
+
-[ { +fp-overflow+ }          [ 2.0  100,000.0 ^ ] with-fp-traps ] must-fail
+: test-traps-compiled ( traps inputs quot -- quot' )
-[ { +fp-underflow+ }         [ 2.0 -100,000.0 ^ ] with-fp-traps ] must-fail
+    swapd '[ @ [ _ _ with-fp-traps ] compile-call ] ;
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps must-fail
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps must-fail
+
+{ +fp-zero-divide+ } [ 1.0 0.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-inexact+ } [ 1.0 3.0 ] [ /f ] test-traps-compiled must-fail
+{ +fp-invalid-operation+ } [ -1.0 ] [ fsqrt ] test-traps-compiled must-fail
+{ +fp-overflow+ } [ 2.0 ] [ 100,000.0 ^ ] test-traps-compiled must-fail
+{ +fp-underflow+ +fp-inexact+ } [ 2.0 ] [ -100,000.0 ^ ] test-traps-compiled must-fail
+
+! Ensure ordered comparisons raise traps
+:: test-comparison-quot ( word -- quot )
+    [
+        { float float } declare
+        { +fp-invalid-operation+ } [ word execute ] with-fp-traps
+    ] ;
+
+: test-comparison ( inputs word -- quot )
+    test-comparison-quot append ;
+
+: test-comparison-compiled ( inputs word -- quot )
+    test-comparison-quot '[ @ _ compile-call ] ;
+
+\ float< "intrinsic" word-prop [
+    [ 0/0. -15.0 ] \ < test-comparison must-fail
+    [ 0/0. -15.0 ] \ < test-comparison-compiled must-fail
+    [ -15.0 0/0. ] \ < test-comparison must-fail
+    [ -15.0 0/0. ] \ < test-comparison-compiled must-fail
+    [ 0/0. -15.0 ] \ <= test-comparison must-fail
+    [ 0/0. -15.0 ] \ <= test-comparison-compiled must-fail
+    [ -15.0 0/0. ] \ <= test-comparison must-fail
+    [ -15.0 0/0. ] \ <= test-comparison-compiled must-fail
+    [ 0/0. -15.0 ] \ > test-comparison must-fail
+    [ 0/0. -15.0 ] \ > test-comparison-compiled must-fail
+    [ -15.0 0/0. ] \ > test-comparison must-fail
+    [ -15.0 0/0. ] \ > test-comparison-compiled must-fail
+    [ 0/0. -15.0 ] \ >= test-comparison must-fail
+    [ 0/0. -15.0 ] \ >= test-comparison-compiled must-fail
+    [ -15.0 0/0. ] \ >= test-comparison must-fail
+    [ -15.0 0/0. ] \ >= test-comparison-compiled must-fail
+
+    [ f ] [ 0/0. -15.0 ] \ u< test-comparison unit-test
+    [ f ] [ 0/0. -15.0 ] \ u< test-comparison-compiled unit-test
+    [ f ] [ -15.0 0/0. ] \ u< test-comparison unit-test
+    [ f ] [ -15.0 0/0. ] \ u< test-comparison-compiled unit-test
+    [ f ] [ 0/0. -15.0 ] \ u<= test-comparison unit-test
+    [ f ] [ 0/0. -15.0 ] \ u<= test-comparison-compiled unit-test
+    [ f ] [ -15.0 0/0. ] \ u<= test-comparison unit-test
+    [ f ] [ -15.0 0/0. ] \ u<= test-comparison-compiled unit-test
+    [ f ] [ 0/0. -15.0 ] \ u> test-comparison unit-test
+    [ f ] [ 0/0. -15.0 ] \ u> test-comparison-compiled unit-test
+    [ f ] [ -15.0 0/0. ] \ u> test-comparison unit-test
+    [ f ] [ -15.0 0/0. ] \ u> test-comparison-compiled unit-test
+    [ f ] [ 0/0. -15.0 ] \ u>= test-comparison unit-test
+    [ f ] [ 0/0. -15.0 ] \ u>= test-comparison-compiled unit-test
+    [ f ] [ -15.0 0/0. ] \ u>= test-comparison unit-test
+    [ f ] [ -15.0 0/0. ] \ u>= test-comparison-compiled unit-test
+] when
 
 ! Ensure traps get cleared
 [ 1/0. ] [ 1.0 0.0 /f ] unit-test

basis/math/floats/env/env.factor

@@ -1,7 +1,8 @@
 ! (c)Joe Groff bsd license
-USING: alien.syntax arrays assocs biassocs combinators continuations
+USING: alien.syntax arrays assocs biassocs combinators
-generalizations kernel literals locals math math.bitwise
+combinators.short-circuit continuations generalizations kernel
-sequences sets system vocabs.loader ;
+literals locals math math.bitwise sequences sets system
+vocabs.loader ;
 IN: math.floats.env
 
 SINGLETONS:
@@ -18,6 +19,15 @@ UNION: fp-exception
     +fp-zero-divide+
     +fp-inexact+ ;
 
+CONSTANT: all-fp-exceptions
+    {
+        +fp-invalid-operation+
+        +fp-overflow+
+        +fp-underflow+
+        +fp-zero-divide+
+        +fp-inexact+
+    }
+
 SINGLETONS:
     +round-nearest+
     +round-down+
@@ -93,6 +103,15 @@ GENERIC# (set-denormal-mode) 1 ( fp-env mode -- fp-env )
         } spread
     ] 4 ncurry change-fp-env-registers ;
 
+CONSTANT: vm-error-exception-flag>bit
+    H{
+        { +fp-invalid-operation+ HEX: 01 }
+        { +fp-overflow+          HEX: 02 }
+        { +fp-underflow+         HEX: 04 }
+        { +fp-zero-divide+       HEX: 08 }
+        { +fp-inexact+           HEX: 10 }
+    }
+
 PRIVATE>
 
 : fp-exception-flags ( -- exceptions )
@@ -102,7 +121,12 @@ PRIVATE>
 : clear-fp-exception-flags ( -- ) { } set-fp-exception-flags ; inline
 
 : collect-fp-exceptions ( quot -- exceptions )
-    clear-fp-exception-flags call fp-exception-flags ; inline
+    [ clear-fp-exception-flags ] dip call fp-exception-flags ; inline
+
+: vm-error>exception-flags ( error -- exceptions )
+    third vm-error-exception-flag>bit mask> ;
+: vm-error-exception-flag? ( error flag -- ? )
+    vm-error>exception-flags member? ;
 
 : denormal-mode ( -- mode ) fp-env-register (get-denormal-mode) ;
 
@@ -122,6 +146,7 @@ PRIVATE>
     (fp-env-registers) [ (get-fp-traps) ] [ union ] map-reduce >array ; inline
 
 :: with-fp-traps ( exceptions quot -- )
+    clear-fp-exception-flags
     fp-traps :> orig
     exceptions set-fp-traps
     quot [ orig set-fp-traps ] [ ] cleanup ; inline

basis/math/floats/env/ppc/ppc.factor

@@ -7,21 +7,34 @@ STRUCT: ppc-fpu-env
     { padding uint }
     { fpscr uint } ;
 
+STRUCT: ppc-vmx-env
+    { vscr uint } ;
+
 ! defined in the vm, cpu-ppc*.S
 FUNCTION: void get_ppc_fpu_env ( ppc-fpu-env* env ) ;
 FUNCTION: void set_ppc_fpu_env ( ppc-fpu-env* env ) ;
 
+FUNCTION: void get_ppc_vmx_env ( ppc-vmx-env* env ) ;
+FUNCTION: void set_ppc_vmx_env ( ppc-vmx-env* env ) ;
+
 : <ppc-fpu-env> ( -- ppc-fpu-env )
     ppc-fpu-env (struct)
     [ get_ppc_fpu_env ] keep ;
 
+: <ppc-vmx-env> ( -- ppc-fpu-env )
+    ppc-vmx-env (struct)
+    [ get_ppc_vmx_env ] keep ;
+
 M: ppc-fpu-env (set-fp-env-register)
     set_ppc_fpu_env ;
 
-M: ppc (fp-env-registers)
+M: ppc-vmx-env (set-fp-env-register)
-    <ppc-fpu-env> 1array ;
+    set_ppc_vmx_env ;
 
-CONSTANT: ppc-exception-flag-bits HEX: 3e00,0000
+M: ppc (fp-env-registers)
+    <ppc-fpu-env> <ppc-vmx-env> 2array ;
+
+CONSTANT: ppc-exception-flag-bits HEX: fff8,0700
 CONSTANT: ppc-exception-flag>bit
     H{
         { +fp-invalid-operation+ HEX: 2000,0000 }
@@ -77,3 +90,30 @@ M: ppc-fpu-env (set-denormal-mode) ( register mode -- register' )
         } case
     ] curry change-fpscr ; inline
 
+CONSTANT: vmx-denormal-mode-bits HEX: 10000
+
+M: ppc-vmx-env (get-exception-flags) ( register -- exceptions )
+    drop { } ; inline
+M: ppc-vmx-env (set-exception-flags) ( register exceptions -- register' )
+    drop ;
+
+M: ppc-vmx-env (get-fp-traps) ( register -- exceptions )
+    drop { } ; inline
+M: ppc-vmx-env (set-fp-traps) ( register exceptions -- register' )
+    drop ;
+
+M: ppc-vmx-env (get-rounding-mode) ( register -- mode )
+    drop +round-nearest+ ;
+M: ppc-vmx-env (set-rounding-mode) ( register mode -- register' )
+    drop ;
+
+M: ppc-vmx-env (get-denormal-mode) ( register -- mode )
+    vscr>> vmx-denormal-mode-bits mask zero? +denormal-keep+ +denormal-flush+ ? ; inline
+M: ppc-vmx-env (set-denormal-mode) ( register mode -- register )
+    [
+        {
+            { +denormal-keep+  [ vmx-denormal-mode-bits unmask ] }
+            { +denormal-flush+ [ vmx-denormal-mode-bits bitor  ] }
+        } case
+    ] curry change-vscr ; inline
+

basis/math/functions/functions-tests.factor

@@ -33,9 +33,15 @@ IN: math.functions.tests
 [ 0.0 ] [ 1.0 log ] unit-test
 [ 1.0 ] [ e log ] unit-test
 
-[ t ] [ 1 exp e = ] unit-test
+[ 0.0 ] [ 1.0 log10 ] unit-test
-[ t ] [ 1.0 exp e = ] unit-test
+[ 1.0 ] [ 10.0 log10 ] unit-test
-[ 1.0 ] [ -1 exp e * ] unit-test
+[ 2.0 ] [ 100.0 log10 ] unit-test
+[ 3.0 ] [ 1000.0 log10 ] unit-test
+[ 4.0 ] [ 10000.0 log10 ] unit-test
+
+[ t ] [ 1 exp e 1.e-10 ~ ] unit-test
+[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
+[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
 
 [ 1.0 ] [ 0 cosh ] unit-test
 [ 1.0 ] [ 0.0 cosh ] unit-test

basis/math/functions/functions.factor

@@ -173,7 +173,11 @@ M: float log1+ dup -1.0 >= [ flog1+ ] [ 1.0 + 0.0 rect> log ] if ; inline
 
 : 10^ ( x -- y ) 10 swap ^ ; inline
 
-: log10 ( x -- y ) log 10 log / ; inline
+GENERIC: log10 ( x -- y ) foldable
+
+M: real log10 >float flog10 ; inline
+
+M: complex log10 log 10 log / ; inline
 
 GENERIC: cos ( x -- y ) foldable
 

basis/math/libm/libm.factor

@@ -39,6 +39,9 @@ IN: math.libm
 : flog ( x -- y )
     "double" "libm" "log" { "double" } alien-invoke ;
 
+: flog10 ( x -- y )
+    "double" "libm" "log10" { "double" } alien-invoke ;
+
 : fpow ( x y -- z )
     "double" "libm" "pow" { "double" "double" } alien-invoke ;
 

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

@@ -197,6 +197,12 @@ SYMBOL: fast-math-ops
         \ <=      define-math-ops
         \ >       define-math-ops
         \ >=      define-math-ops
+
+        \ u<      define-math-ops
+        \ u<=     define-math-ops
+        \ u>      define-math-ops
+        \ u>=     define-math-ops
+
         \ number= define-math-ops
 
         { { shift bignum bignum } bignum-shift } ,

basis/prettyprint/backend/backend.factor

@@ -45,12 +45,23 @@ M: method-body pprint*
         ] "" make
     ] [ word-style ] bi styled-text ;
 
-M: real pprint* number>string text ;
+M: real pprint*
+    number-base get {
+        { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
+        {  8 [ \ OCT: [  8 >base text ] pprint-prefix ] }
+        {  2 [ \ BIN: [  2 >base text ] pprint-prefix ] }
+        [ drop number>string text ]
+    } case ;
 
 M: float pprint*
     dup fp-nan? [
         \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
-    ] [ call-next-method ] if ;
+    ] [
+        number-base get {
+            { 16 [ \ HEX: [ 16 >base text ] pprint-prefix ] }
+            [ drop number>string text ]
+        } case
+    ] if ;
 
 M: f pprint* drop \ f pprint-word ;
 

basis/prettyprint/config/config.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays generic assocs io kernel math
-namespaces sequences strings io.styles vectors words
+namespaces sequences strings vectors words
 continuations ;
 IN: prettyprint.config
 
@@ -11,9 +11,11 @@ SYMBOL: margin
 SYMBOL: nesting-limit
 SYMBOL: length-limit
 SYMBOL: line-limit
+SYMBOL: number-base
 SYMBOL: string-limit?
 SYMBOL: boa-tuples?
 SYMBOL: c-object-pointers?
 
 4 tab-size set-global
 64 margin set-global
+10 number-base set-global

basis/prettyprint/prettyprint-tests.factor

@@ -8,7 +8,15 @@ listener ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
+[ "4096" ] [ 4096 unparse ] unit-test
+[ "BIN: 1000000000000" ] [ 2 number-base [ 4096 unparse ] with-variable ] unit-test
+[ "OCT: 10000" ] [ 8 number-base [ 4096 unparse ] with-variable ] unit-test
+[ "HEX: 1000" ] [ 16 number-base [ 4096 unparse ] with-variable ] unit-test
 [ "1.0" ] [ 1.0 unparse ] unit-test
+[ "8.0" ] [ 8.0 unparse ] unit-test
+[ "8.0" ] [ 2 number-base [ 8.0 unparse ] with-variable ] unit-test
+[ "8.0" ] [ 8 number-base [ 8.0 unparse ] with-variable ] unit-test
+[ "HEX: 1.0p3" ] [ 16 number-base [ 8.0 unparse ] with-variable ] unit-test
 [ "1267650600228229401496703205376" ] [ 1 100 shift unparse ] unit-test
 
 [ "+" ] [ \ + unparse ] unit-test

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -100,12 +100,12 @@ SPECIALIZED-ARRAY: test-struct
 ] unit-test
 
 ! Regression
-STRUCT: fixed-string { text char[100] } ;
+STRUCT: fixed-string { text char[64] } ;
 
 SPECIALIZED-ARRAY: fixed-string
 
-[ { ALIEN: 123 ALIEN: 223 ALIEN: 323 ALIEN: 423 } ] [
+[ { ALIEN: 100 ALIEN: 140 ALIEN: 180 ALIEN: 1c0 } ] [
-    ALIEN: 123 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
+    ALIEN: 100 4 <direct-fixed-string-array> [ (underlying)>> ] { } map-as
 ] unit-test
 
 ! Ensure that byte-length works with direct arrays

basis/stack-checker/known-words/known-words.factor

@@ -455,12 +455,12 @@ M: bad-executable summary
 \ float/f { float float } { float } define-primitive
 \ float/f make-foldable
 
-\ float< { float float } { object } define-primitive
-\ float< make-foldable
-
 \ float-mod { float float } { float } define-primitive
 \ float-mod make-foldable
 
+\ float< { float float } { object } define-primitive
+\ float< make-foldable
+
 \ float<= { float float } { object } define-primitive
 \ float<= make-foldable
 
@@ -470,6 +470,18 @@ M: bad-executable summary
 \ float>= { float float } { object } define-primitive
 \ float>= make-foldable
 
+\ float-u< { float float } { object } define-primitive
+\ float-u< make-foldable
+
+\ float-u<= { float float } { object } define-primitive
+\ float-u<= make-foldable
+
+\ float-u> { float float } { object } define-primitive
+\ float-u> make-foldable
+
+\ float-u>= { float float } { object } define-primitive
+\ float-u>= make-foldable
+
 \ <word> { object object } { word } define-primitive
 \ <word> make-flushable
 

basis/vocabs/prettyprint/prettyprint.factor

@@ -88,7 +88,7 @@ PRIVATE>
         "at the top of the source file:" print nl
     ] with-style
     {
-        { page-color COLOR: FactorLightLightTan }
+        { page-color COLOR: FactorLightTan }
         { border-color COLOR: FactorDarkTan }
         { inset { 5 5 } }
     } [ manifest get pprint-manifest ] with-nesting

basis/xml-rpc/xml-rpc.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel xml arrays math generic http.client
+USING: accessors arrays assocs base64 calendar calendar.format
-combinators hashtables namespaces io base64 sequences strings
+combinators debugger generic hashtables http http.client
-calendar xml.data xml.writer xml.traversal assocs math.parser
+http.client.private io io.encodings.string io.encodings.utf8
-debugger calendar.format math.order xml.syntax ;
+kernel math math.order math.parser namespaces sequences strings
+xml xml.data xml.syntax xml.traversal xml.writer ;
 IN: xml-rpc
 
 ! * Sending RPC requests
@@ -174,9 +175,20 @@ TAG: array xml>item
         ] [ "Bad main tag name" server-error ] if
     ] if ;
 
+<PRIVATE
+
+: xml-post-data ( xml -- post-data )
+    xml>string utf8 encode "text/xml" <post-data> swap >>data ;
+
+: rpc-post-request ( xml url -- request )
+    [ send-rpc xml-post-data ] [ "POST" <client-request> ] bi*
+    swap >>post-data ;
+
+PRIVATE>
+
 : post-rpc ( rpc url -- rpc )
     ! This needs to do something in the event of an error
-    [ send-rpc ] dip http-post nip string>xml receive-rpc ;
+    rpc-post-request http-request nip string>xml receive-rpc ;
 
 : invoke-method ( params method url -- response )
     [ swap <rpc-method> ] dip post-rpc ;

core/bootstrap/primitives.factor

@@ -409,6 +409,10 @@ tuple
     { "float<=" "math.private" (( x y -- ? )) }
     { "float>" "math.private" (( x y -- ? )) }
     { "float>=" "math.private" (( x y -- ? )) }
+    { "float-u<" "math.private" (( x y -- ? )) }
+    { "float-u<=" "math.private" (( x y -- ? )) }
+    { "float-u>" "math.private" (( x y -- ? )) }
+    { "float-u>=" "math.private" (( x y -- ? )) }
     { "<word>" "words" (( name vocab -- word )) }
     { "word-xt" "words" (( word -- start end )) }
     { "getenv" "kernel.private" (( n -- obj )) }

core/math/floats/floats-docs.factor

@@ -69,20 +69,54 @@ HELP: float> ( x y -- ? )
 
 HELP: float>= ( x y -- ? )
 { $values { "x" float } { "y" float } { "?" "a boolean" } }
-{ $description "Primitive version of " { $link >= } "." }
+{ $description "Primitive version of " { $link u>= } "." }
-{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link >= } " instead." } ;
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
 
-ARTICLE: "floats" "Floats"
+HELP: float-u< ( x y -- ? )
-{ $subsection float }
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
-"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+{ $description "Primitive version of " { $link u< } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u< } " instead." } ;
+
+HELP: float-u<= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u<= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u<= } " instead." } ;
+
+HELP: float-u> ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u> } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u> } " instead." } ;
+
+HELP: float-u>= ( x y -- ? )
+{ $values { "x" float } { "y" float } { "?" "a boolean" } }
+{ $description "Primitive version of " { $link u>= } "." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link u>= } " instead." } ;
+
+ARTICLE: "math.floats.compare" "Floating point comparison operations"
+"In mathematics, real numbers are linearly ordered; for any two numbers " { $snippet "a" } " and " { $snippet "b" } ", exactly one of the following is true:"
+{ $code
+    "a < b"
+    "a = b"
+    "a > b"
+}
+"With floating point values, there is a fourth possibility; " { $snippet "a" } " and " { $snippet "b" } " may be " { $emphasis "unordered" } ". This happens if one or both values are Not-a-Number values."
 $nl
-"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+"All comparison operators, including " { $link number= } ", return " { $link f } " in the unordered case (and in particular, this means that a NaN is not equal to itself)."
-{ $example "5/4 1/2 + ." "1+3/4" }
+$nl
-{ $example "5/4 0.5 + ." "1.75" }
+"The " { $emphasis "ordered" } " comparison operators set floating point exception flags if the result of the comparison is unordered. The standard comparison operators (" { $link < } ", " { $link <= } ", " { $link > } ", " { $link >= } ") perform ordered comparisons."
-"Integers and rationals can be converted to floats:"
+$nl
-{ $subsection >float }
+"The " { $link number= } " operation performs an unordered comparison. The following set of operators also perform unordered comparisons:"
-"Two real numbers can be divided yielding a float result:"
+{ $subsection u< }
-{ $subsection /f }
+{ $subsection u<= }
+{ $subsection u> }
+{ $subsection u>= }
+"A word to check if two values are unordered with respect to each other:"
+{ $subsection unordered? }
+"To test for floating point exceptions, use the " { $vocab-link "math.floats.env" } " vocabulary."
+$nl
+"If neither input to a comparison operator is a floating point value, then " { $link u< } ", " { $link u<= } ", " { $link u> } " and " { $link u>= } " are equivalent to the ordered operators." ;
+
+ARTICLE: "math.floats.bitwise" "Bitwise operations on floats"
 "Floating point numbers are represented internally in IEEE 754 double-precision format. This internal representation can be accessed for advanced operations and input/output purposes."
 { $subsection float>bits }
 { $subsection double>bits }
@@ -100,8 +134,25 @@ $nl
 { $subsection fp-snan? }
 { $subsection fp-infinity? }
 { $subsection fp-nan-payload }
-"Comparing two floating point numbers:"
+"Comparing two floating point numbers for bitwise equality:"
 { $subsection fp-bitwise= }
-{ $see-also "syntax-floats" } ;
+{ $see-also POSTPONE: NAN: } ;
+
+ARTICLE: "floats" "Floats"
+{ $subsection float }
+"Rational numbers represent " { $emphasis "exact" } " quantities. On the other hand, a floating point number is an " { $emphasis "approximate" } " value. While rationals can grow to any required precision, floating point numbers have limited precision, and manipulating them is usually faster than manipulating ratios or bignums."
+$nl
+"Introducing a floating point number in a computation forces the result to be expressed in floating point."
+{ $example "5/4 1/2 + ." "1+3/4" }
+{ $example "5/4 0.5 + ." "1.75" }
+"Floating point literal syntax is documented in " { $link "syntax-floats" } "."
+$nl
+"Integers and rationals can be converted to floats:"
+{ $subsection >float }
+"Two real numbers can be divided yielding a float result:"
+{ $subsection /f }
+{ $subsection "math.floats.bitwise" }
+{ $subsection "math.floats.compare" }
+"The " { $vocab-link "math.floats.env" } " vocabulary provides functionality for controlling floating point exceptions, rounding modes, and denormal behavior." ;
 
 ABOUT: "floats"

core/math/floats/floats.factor

@@ -3,6 +3,7 @@
 USING: kernel math math.private ;
 IN: math.floats.private
 
+: float-unordered? ( x y -- ? ) [ fp-nan? ] bi@ or ;
 : float-min ( x y -- z ) [ float< ] most ; foldable
 : float-max ( x y -- z ) [ float> ] most ; foldable
 
@@ -17,11 +18,17 @@ M: float hashcode* nip float>bits ; inline
 M: float equal? over float? [ float= ] [ 2drop f ] if ; inline
 M: float number= float= ; inline
 
-M: float < float< ; inline
+M: float <  float< ; inline
 M: float <= float<= ; inline
-M: float > float> ; inline
+M: float >  float> ; inline
 M: float >= float>= ; inline
 
+M: float unordered? float-unordered? ; inline
+M: float u<  float-u< ; inline
+M: float u<= float-u<= ; inline
+M: float u>  float-u> ; inline
+M: float u>= float-u>= ; inline
+
 M: float + float+ ; inline
 M: float - float- ; inline
 M: float * float* ; inline
@@ -58,8 +65,6 @@ M: float next-float
         ] if
     ] if ; inline
 
-M: float unordered? [ fp-nan? ] bi@ or ; inline
-
 M: float prev-float
     double>bits
     dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative

core/math/integers/integers.factor

@@ -24,6 +24,11 @@ M: fixnum <= fixnum<= ; inline
 M: fixnum > fixnum> ; inline
 M: fixnum >= fixnum>= ; inline
 
+M: fixnum u< fixnum< ; inline
+M: fixnum u<= fixnum<= ; inline
+M: fixnum u> fixnum> ; inline
+M: fixnum u>= fixnum>= ; inline
+
 M: fixnum + fixnum+ ; inline
 M: fixnum - fixnum- ; inline
 M: fixnum * fixnum* ; inline
@@ -65,6 +70,11 @@ M: bignum <= bignum<= ; inline
 M: bignum > bignum> ; inline
 M: bignum >= bignum>= ; inline
 
+M: bignum u< bignum< ; inline
+M: bignum u<= bignum<= ; inline
+M: bignum u> bignum> ; inline
+M: bignum u>= bignum>= ; inline
+
 M: bignum + bignum+ ; inline
 M: bignum - bignum- ; inline
 M: bignum * bignum* ; inline

core/math/math-docs.factor

@@ -5,7 +5,9 @@ IN: math
 HELP: number=
 { $values { "x" number } { "y" number } { "?" "a boolean" } }
 { $description "Tests if two numbers have the same numeric value." }
-{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers." }
+{ $notes "This word differs from " { $link = } " in that it disregards differences in type when comparing numbers."
+$nl
+"This word performs an unordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." }
 { $examples
     { $example "USING: math prettyprint ;" "3.0 3 number= ." "t" }
     { $example "USING: kernel math prettyprint ;" "3.0 3 = ." "f" }
@@ -13,20 +15,47 @@ HELP: number=
 
 HELP: <
 { $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
 
 HELP: <=
 { $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
 
 HELP: >
 { $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
 
 HELP: >=
 { $values { "x" real } { "y" real } { "?" boolean } }
-{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." } ;
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an ordered comparison on floating point numbers. See " { $link "math.floats.compare" } " for an explanation." } ;
 
+HELP: unordered?
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is unordered with respect to " { $snippet "y" } ". This can only occur if one or both values is a floating-point Not-a-Number value." } ;
+
+HELP: u<
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link < } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u<=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is less than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link <= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link > } ". See " { $link "math.floats.compare" } " for an explanation." } ;
+
+HELP: u>=
+{ $values { "x" real } { "y" real } { "?" boolean } }
+{ $description "Tests if " { $snippet "x" } " is greater than or equal to " { $snippet "y" } "." }
+{ $notes "This word performs an unordered comparison on floating point numbers. On rational numbers it is equivalent to " { $link >= } ". See " { $link "math.floats.compare" } " for an explanation." } ;
 
 HELP: +
 { $values { "x" number } { "y" number } { "z" number } }
@@ -328,6 +357,10 @@ HELP: fp-infinity?
     { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
 } ;
 
+HELP: fp-sign
+{ $values { "x" float } { "?" "a boolean" } }
+{ $description "Outputs the sign bit of " { $snippet "x" } ". For ordered non-zero values, this is equivalent to calling " { $snippet "0 <" } ". For zero values, this outputs the zero's sign bit." } ;
+
 HELP: fp-nan-payload
 { $values { "x" real } { "bits" integer } }
 { $description "If " { $snippet "x" } " is an IEEE Not-a-Number value, returns the payload encoded in the value. Returns " { $link f } " if " { $snippet "x" } " is not a " { $link float } "." } ;

core/math/math.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math.private ;
 IN: math
@@ -22,7 +22,12 @@ MATH: <  ( x y -- ? ) foldable
 MATH: <= ( x y -- ? ) foldable
 MATH: >  ( x y -- ? ) foldable
 MATH: >= ( x y -- ? ) foldable
+
 MATH: unordered? ( x y -- ? ) foldable
+MATH: u<  ( x y -- ? ) foldable
+MATH: u<= ( x y -- ? ) foldable
+MATH: u>  ( x y -- ? ) foldable
+MATH: u>= ( x y -- ? ) foldable
 
 M: object unordered? 2drop f ;
 

core/math/parser/parser.factor

@@ -109,9 +109,8 @@ SYMBOL: negative?
 
 : base>float ( str base -- n/f )
     {
-        { 10 [ dec>float ] }
         { 16 [ hex>float ] }
-        [ "Floats can only be converted from strings in base 10 or 16" throw ]
+        [ drop dec>float ]
     } case ;
 
 : number-char? ( char -- ? )
@@ -232,9 +231,8 @@ M: ratio >base
 
 : float>base ( n base -- str )
     {
-        { 10 [ float>decimal ] }
         { 16 [ float>hex ] }
-        [ "Floats can only be converted to strings in base 10 or 16" throw ]
+        [ drop float>decimal ]
     } case ;
 
 PRIVATE>

extra/benchmark/gc1/gc1.factor

@@ -3,6 +3,6 @@
 USING: math sequences kernel ;
 IN: benchmark.gc1
 
-: gc1 ( -- ) 6000000 [ >bignum 1 + ] map drop ;
+: gc1 ( -- ) 10 [ 600000 [ >bignum 1 + ] map drop ] times ;
 
 MAIN: gc1

extra/benchmark/simd-1/simd-1.factor

@@ -25,6 +25,6 @@ IN: benchmark.simd-1
     >fixnum make-points [ normalize-points ] [ max-points ] bi print-point ;
 
 : main ( -- )
-    5000000 simd-benchmark ;
+    10 [ 500000 simd-benchmark ] times ;
 
 MAIN: main

extra/benchmark/struct-arrays/struct-arrays.factor

@@ -47,6 +47,6 @@ SPECIALIZED-ARRAY: point
 : struct-array-benchmark ( len -- )
     make-points [ normalize-points ] [ max-points ] bi print-point ;
 
-: main ( -- ) 5000000 struct-array-benchmark ;
+: main ( -- ) 10 [ 500000 struct-array-benchmark ] times ;
 
 MAIN: main

extra/project-euler/common/common-tests.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test project-euler.common ;
+IN: project-euler.common.tests
+
+[ 4 ] [ -1000 number-length ] unit-test
+[ 3 ] [ -999 number-length ] unit-test
+[ 3 ] [ -100 number-length ] unit-test
+[ 2 ] [ -99 number-length ] unit-test
+[ 1 ] [ -9 number-length ] unit-test
+[ 1 ] [ -1 number-length ] unit-test
+[ 1 ] [ 0 number-length ] unit-test
+[ 1 ] [ 9 number-length ] unit-test
+[ 2 ] [ 99 number-length ] unit-test
+[ 3 ] [ 100 number-length ] unit-test
+[ 3 ] [ 999 number-length ] unit-test
+[ 4 ] [ 1000 number-length ] unit-test

extra/project-euler/common/common.factor

@@ -76,7 +76,12 @@ PRIVATE>
     [ dup 0 = not ] [ 10 /mod ] produce reverse nip ;
 
 : number-length ( n -- m )
-    log10 floor 1 + >integer ;
+    abs [
+        1
+    ] [
+        1 0 [ 2over >= ]
+        [ [ 10 * ] [ 1 + ] bi* ] while 2nip
+    ] if-zero ;
 
 : nth-prime ( n -- n )
     1 - lprimes lnth ;

extra/qtkit/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/qtkit/qtkit.factor

@@ -0,0 +1,76 @@
+USING: classes.struct cocoa core-foundation.strings ;
+IN: qtkit
+
+STRUCT: QTTime
+    { timeValue longlong }
+    { timeScale long }
+    { flags     long } ;
+
+STRUCT: QTTimeRange
+    { time      QTTime }
+    { duration  QTTime } ;
+
+STRUCT: SMPTETime
+    { mSubframes       SInt16 }
+    { mSubframeDivisor SInt16 }
+    { mCounter         UInt32 }
+    { mType            UInt32 }
+    { mFlags           UInt32 }
+    { mHours           SInt16 }
+    { mMinutes         SInt16 }
+    { mSeconds         SInt16 }
+    { mFrames          SInt16 } ;
+
+CFSTRING: QTKitErrorDomain "QTKitErrorDomain"
+CFSTRING: QTErrorCaptureInputKey "QTErrorCaptureInputKey"
+CFSTRING: QTErrorCaptureOutputKey "QTErrorCaptureOutputKey"
+CFSTRING: QTErrorDeviceKey "QTErrorDeviceKey"
+CFSTRING: QTErrorExcludingDeviceKey "QTErrorExcludingDeviceKey"
+CFSTRING: QTErrorTimeKey "QTErrorTimeKey"
+CFSTRING: QTErrorFileSizeKey "QTErrorFileSizeKey"
+CFSTRING: QTErrorRecordingSuccesfullyFinishedKey "QTErrorRecordingSuccesfullyFinishedKey"
+
+CONSTANT: QTErrorUnknown                                      -1
+CONSTANT: QTErrorIncompatibleInput                          1002
+CONSTANT: QTErrorIncompatibleOutput                         1003
+CONSTANT: QTErrorInvalidInputsOrOutputs                     1100
+CONSTANT: QTErrorDeviceAlreadyUsedbyAnotherSession          1101
+CONSTANT: QTErrorNoDataCaptured                             1200
+CONSTANT: QTErrorSessionConfigurationChanged                1201
+CONSTANT: QTErrorDiskFull                                   1202
+CONSTANT: QTErrorDeviceWasDisconnected                      1203
+CONSTANT: QTErrorMediaChanged                               1204
+CONSTANT: QTErrorMaximumDurationReached                     1205
+CONSTANT: QTErrorMaximumFileSizeReached                     1206
+CONSTANT: QTErrorMediaDiscontinuity                         1207
+CONSTANT: QTErrorMaximumNumberOfSamplesForFileFormatReached 1208
+CONSTANT: QTErrorDeviceNotConnected                         1300
+CONSTANT: QTErrorDeviceInUseByAnotherApplication            1301
+CONSTANT: QTErrorDeviceExcludedByAnotherDevice              1302
+
+FRAMEWORK: /System/Library/Frameworks/QTKit.framework
+
+IMPORT: QTCaptureAudioPreviewOutput
+IMPORT: QTCaptureConnection
+IMPORT: QTCaptureDecompressedAudioOutput
+IMPORT: QTCaptureDecompressedVideoOutput
+IMPORT: QTCaptureDevice
+IMPORT: QTCaptureDeviceInput
+IMPORT: QTCaptureFileOutput
+IMPORT: QTCaptureInput
+IMPORT: QTCaptureLayer
+IMPORT: QTCaptureMovieFileOutput
+IMPORT: QTCaptureOutput
+IMPORT: QTCaptureSession
+IMPORT: QTCaptureVideoPreviewOutput
+IMPORT: QTCaptureView
+IMPORT: QTCompressionOptions
+IMPORT: QTDataReference
+IMPORT: QTFormatDescription
+IMPORT: QTMedia
+IMPORT: QTMovie
+IMPORT: QTMovieLayer
+IMPORT: QTMovieView
+IMPORT: QTSampleBuffer
+IMPORT: QTTrack
+

extra/qtkit/tags.txt

@@ -0,0 +1 @@
+unportable

extra/tc-lisp-talk/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/tc-lisp-talk/tc-lisp-talk.factor

@@ -0,0 +1,534 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators constructors eval help.markup kernel
+multiline namespaces parser sequences sequences.private slides
+vocabs.refresh words fry ;
+IN: tc-lisp-talk
+
+CONSTANT: tc-lisp-slides
+{
+    { $slide "Factor!"
+        { $url "http://factorcode.org" }
+        "Development started in 2003"
+        "Open source (BSD license)"
+        "Influenced by Forth, Lisp, and Smalltalk"
+        "Blurs the line between language and library"
+        "Interactive development"
+    }
+    { $slide "First, some examples"
+        { $code "3 weeks ago noon monday ." }
+        { $code "USE: roman 2009 >roman ." }
+        { $code <" : average ( seq -- x )
+    [ sum ] [ length ] bi / ;"> }
+        { $code "1 miles [ km ] undo >float ." }
+        { $code "[ readln eval>string print t ] loop" }
+    }
+    { $slide "XML Literals"
+        { $code
+        <" USING: splitting xml.writer xml.syntax ;
+{ "one" "two" "three" } 
+[ [XML <item><-></item> XML] ] map
+<XML <doc><-></doc> XML> pprint-xml">
+        }
+    }
+    { $slide "Differences between Factor and Lisp"
+        "Single-implementation language"
+        "Less nesting, shorter word length"
+        { "Dynamic reloading of code from files with " { $link refresh-all } }
+        "More generic protocols -- sequences, assocs, streams"
+        "More cross-platform"
+        "No standard for the language"
+        "Evaluates left to right"
+    }
+    { $slide "Terminology"
+        { "Words - functions" }
+        { "Vocabularies - collections of code in the same namespace" }
+        { "Quotations - blocks of code" { $code "[ dup reverse append ]" } }
+        { "Combinators - higher order functions" }
+        { "Static stack effect - known stack effect at compile-time" }
+    }
+    { $slide "Defining a word"
+        "Defined at parse time"
+        "Parts: name, stack effect, definition"
+        "Composed of tokens separated by whitespace"
+        { $code ": palindrome? ( string -- ? ) dup reverse = ;" }
+    }
+    { $slide "Non-static stack effect"
+        "Not a good practice, nor useful"
+        "Not compiled by the optimizing compiler"
+        { $code "100 iota [ ] each" }
+    }
+    { $slide "Module system"
+        "Code divided up into vocabulary roots"
+        "core/ -- just enough code to bootstrap Factor"
+        "basis/ -- optimizing compiler, the UI, tools, libraries"
+        "extra/ -- demos, unpolished code, experiments"
+        "work/ -- your works in progress"
+    }
+    { $slide "Module system (part 2)"
+        "Each vocabulary corresponds to a directory on disk, with documentation and test files"
+        { "Code for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math.factor" } }
+        { "Documentation for the " { $snippet "math" } " vocabulary: " { $snippet "~/factor/core/math/math-docs.factor" } }
+        { "Unit tests for the " { $snippet "math" } " vocabulary: " { $snippet " ~/factor/core/math/math-tests.factor" } }
+    }
+    { $slide "Using a library"
+        "Each file starts with a USING: list"
+        "To use a library, simply include it in this list"
+        "Refreshing code loads dependencies correctly"
+    }
+    { $slide "Object system"
+        "Based on CLOS"
+        { "We define generic words that operate on the top of the stack with " { $link POSTPONE: GENERIC:  } " or on an implicit parameter with " { $link POSTPONE: HOOK: } }
+    }
+    { $slide "Object system example: shape protocol"
+        "In ~/factor/work/shapes/shapes.factor"
+        { $code <" IN: shapes
+
+GENERIC: area ( shape -- x )
+GENERIC: perimeter ( shape -- x )">
+        }
+    }
+    { $slide "Implementing the shape protocol: circles"
+        "In ~/factor/work/shapes/circle/circle.factor"
+        { $code <" USING: shapes constructors math
+math.constants ;
+IN: shapes.circle
+
+TUPLE: circle radius ;
+CONSTRUCTOR: circle ( radius -- obj ) ;
+M: circle area radius>> sq pi * ;
+M: circle perimeter radius>> pi * 2 * ;">
+        }
+    }
+    { $slide "Dynamic variables"
+        "Implemented as a stack of hashtables"
+        { "Useful words are " { $link get } ", " { $link set } }
+        "Input, output, error streams are stored in dynamic variables"
+        { $code <" "Today is the first day of the rest of your life."
+[
+    readln print
+] with-string-reader">
+        }
+    }
+    { $slide "The global namespace"
+        "The global namespace is just the namespace at the bottom of the namespace stack"
+        { "Useful words are " { $link get-global } ", " { $link set-global } }
+        "Factor idiom for changing a particular namespace"
+        { $code <" SYMBOL: king
+global [ "Henry VIII" king set ] bind">
+        }
+        { $code "with-scope" }
+        { $code "namestack" }
+    }
+    { $slide "Hooks"
+        "Dispatch on a dynamic variable"
+        { $code <" HOOK: computer-name os ( -- string )
+M: macosx computer-name uname first ;
+macosx \ os set-global
+computer-name">
+        }
+    }
+    { $slide "Interpolate"
+        "Replaces variables in a string"
+        { $code
+<" "Dawg" "name" set
+"rims" "noun" set
+"bling" "verb1" set
+"roll" "verb2" set
+[
+    "Sup ${name}, we heard you liked ${noun}, so we put ${noun} on your car so you can ${verb1} while you ${verb2}."
+    interpolate
+] with-string-writer print ">
+        }
+    }
+    { $slide "Sequence protocol"
+        "All sequences obey a protocol of generics"
+        { "Is an object a " { $link sequence? } }
+        { "Getting the " { $link length } }
+        { "Accessing the " { $link nth  } " element" }
+        { "Setting an element - " { $link set-nth } }
+    }
+    { $slide "Examples of sequences in Factor"
+        "Arrays are mutable"
+        "Vectors are mutable and growable"
+        { "Arrays " { $code "{ \"abc\" \"def\" 50 }" } }
+        { "Vectors " { $code "V{ \"abc\" \"def\" 50 }" } }
+        { "Byte-arrays " { $code "B{ 1 2 3 }" } }
+        { "Byte-vectors " { $code "BV{ 11 22 33 }" } }
+    }
+    { $slide "Specialized arrays and vectors"
+        { "Specialized int arrays " { $code "int-array{ -20 -30 40 }" } }
+        { "Specialized uint arrays " { $code "uint-array{ 20 30 40 }" } }
+        { "Specialized float vectors " { $code "float-vector{ 20 30 40 }" } }
+        "35 others C-type arrays"
+    }
+    { $slide "Specialized arrays code"
+        "One line per array/vector"
+        { "In ~/factor/basis/specialized-arrays/float/float.factor"
+            { $code <" << "float" define-array >>"> }
+        }
+        { "In ~/factor/basis/specialized-vectors/float/float.factor"
+            { $code <" << "float" define-vector >>"> }
+        }
+    }
+
+    { $slide "Speciailzied arrays are implemented using functors"
+        "Like C++ templates"
+        "Eliminate boilerplate in ways other abstractions don't"
+        "Contains a definition section and a functor body"
+        "Uses the interpolate vocabulary"
+    }
+    { $slide "Functor for sorting"
+        { $code
+            <" FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT compare ;
+: NAME>=< ( obj1 obj2 -- >=< )
+    NAME<=> invert-comparison ;
+
+;FUNCTOR">
+        }
+    }
+    { $slide "Example of sorting functor"
+        { $code <" USING: sorting.functor ;
+<< "length" [ length ] define-sorting >>">
+        }
+        { $code
+            <" { { 1 2 3 } { 1 2 } { 1 } }
+[ length<=> ] sort">
+        }
+    }
+    { $slide "Combinators"
+        "Used to implement higher order functions (dataflow and control flow)"
+        "Compiler optimizes away quotations completely"
+        "Optimized code is just tight loops in registers"
+        "Most loops can be expressed with combinators or tail-recursion"
+    }
+    { $slide "Combinators that act on one value"
+        { $link bi }
+        { $code "10 [ 1 - ] [ 1 + ] bi" }
+        { $link tri }
+        { $code "10 [ 1 - ] [ 1 + ] [ 2 * ] tri" }
+    }
+    { $slide "Combinators that act on two values"
+        { $link 2bi }
+        { $code "10 1 [ - ] [ + ] 2bi" }
+        { $link bi* }
+        { $code "10 20 [ 1 - ] [ 1 + ] bi*" }
+        { $link bi@ }
+        { $code "5 9 [ sq ] bi@" }
+    }
+    { $slide "Sequence combinators"
+        
+        { $link each }
+        { $code "{ 1 2 3 4 5 } [ sq . ] each" }
+        { $link map }
+        { $code "{ 1 2 3 4 5 } [ sq ] map" }
+        { $link filter }
+        { $code "{ 1 2 3 4 5 } [ even? ] filter" }
+    }
+    { $slide "Multiple sequence combinators"
+        
+        { $link 2each }
+        { $code "{ 1 2 3 } { 10 20 30 } [ + . ] 2each" }
+        { $link 2map }
+        { $code "{ 1 2 3 } { 10 20 30 } [ + ] 2map" }
+    }
+    { $slide "Control flow: if"
+        { $link if }
+        { $code <" 10 random dup even? [ 2 / ] [ 1 - ] if"> }
+        { $link when }
+        { $code <" 10 random dup even? [ 2 / ] when"> }
+        { $link unless }
+        { $code <" 10 random dup even? [ 1 - ] unless"> }
+    }
+    { $slide "Control flow: case"
+        { $link case }
+        { $code <" ERROR: not-possible obj ;
+10 random 5 <=> {
+    { +lt+ [ "Less" ] }
+    { +gt+ [ "More" ] }
+    { +eq+ [ "Equal" ] }
+    [ not-possible ]
+} case">
+        }
+    }
+    { $slide "Fry"
+        "Used to construct quotations"
+        { "'Holes', represented by " { $snippet "_" } " are filled left to right" }
+        { $code "10 4 '[ _ + ] call" }
+        { $code "3 4 '[ _ sq _ + ] call" }
+    }
+    { $slide "Locals"
+        "When data flow combinators and shuffle words are not enough"
+        "Name your input parameters"
+        "Used in about 1% of all words"
+    }
+    { $slide "Locals example"
+        "Area of a triangle using Heron's formula"
+        { $code
+            <" :: area ( a b c -- x )
+    a b c + + 2 / :> p
+    p
+    p a - *
+    p b - *
+    p c - * sqrt ;">
+        }
+    }
+    { $slide "Previous example without locals"
+        "A bit unwieldy..."
+        { $code
+            <" : area ( a b c -- x )
+    [ ] [ + + 2 / ] 3bi
+    [ '[ _ - ] tri@ ] [ neg ] bi
+    * * * sqrt ;"> }
+    }
+    { $slide "More idiomatic version"
+        "But there's a trick: put the lengths in an array"
+        { $code <" : v-n ( v n -- w ) '[ _ - ] map ;
+
+: area ( seq -- x )
+    [ 0 suffix ] [ sum 2 / ] bi
+    v-n product sqrt ;"> }
+    }
+    { $slide "Implementing an abstraction"
+        { "Suppose we want to get the price of the customer's first order, but any one of the steps along the way could be a nil value (" { $link f } " in Factor):" }
+        { $code
+            "dup [ orders>> ] when"
+            "dup [ first ] when"
+            "dup [ price>> ] when"
+        }
+    }
+    { $slide "This is hard with mainstream syntax!"
+        { $code
+            <" var customer = ...;
+var orders = (customer == null ? null : customer.orders);
+var order = (orders == null ? null : orders[0]);
+var price = (order == null ? null : order.price);"> }
+    }
+    { $slide "An ad-hoc solution"
+        "Something like..."
+        { $code "var price = customer.?orders.?[0].?price;" }
+    }
+    { $slide "Macros in Factor"
+        "Expand at compile-time"
+        "Return a quotation to be compiled"
+        "Can express non-static stack effects"
+        "Not as widely used as combinators, 60 macros so far"
+        { $code "{ 1 2 3 4 5 } 5 firstn" }
+    }
+    { $slide "A macro solution"
+        "Returns a quotation to the compiler"
+        "Constructed using map, fry, and concat"
+        { $code <" MACRO: plox ( seq -- quot )
+    [
+        '[ dup _ when ]
+    ] map [ ] concat-as ;">
+        }
+    }
+    { $slide "Macro example"
+        "Return the caaar of a sequence"
+        { "Return " { $snippet f } " on failure" }
+        { $code <" : caaar ( seq/f -- x/f )
+    {
+        [ first ]
+        [ first ]
+        [ first ]
+    } plox ;">
+        }
+        { $code <" { { f } } caaar"> }
+        { $code <" { { { 1 2 3 } } } caaar"> }
+    }
+    { $slide "Smart combinators"
+        "Use stack checker to infer inputs and outputs"
+        "Even fewer uses than macros"
+        { $code "{ 1 10 20 34 } sum" }
+        { $code "[ 1 10 20 34 ] sum-outputs" }
+        { $code "[ 2 2 [ even? ] both? ] [ + ] [ - ] smart-if" }
+    }
+    { $slide "Fibonacci"
+        "Not tail recursive"
+        "Call tree is huge"
+        { $code <" : fib ( n -- x )
+    dup 1 <= [
+        [ 1 - fib ] [ 2 - fib ] bi +
+    ] unless ;">
+        }
+        { $code "36 iota [ fib ] map ." }
+    }
+    { $slide "Memoized Fibonacci"
+        "Change one word and it's efficient"
+        { $code <" MEMO: fib ( n -- x )
+    dup 1 <= [
+        [ 1 - fib ] [ 2 - fib ] bi +
+    ] unless ;">
+        }
+        { $code "36 iota [ fib ] map ." }
+    }
+    { $slide "Destructors"
+        "Deterministic resource disposal"
+        "Any step can fail and we don't want to leak resources"
+        "We want to conditionally clean up sometimes -- if everything succeeds, we might wish to retain the buffer"
+    }
+
+    { $slide "Example in C"
+        { $code
+<" void do_stuff()
+{
+    void *obj1, *obj2;
+    if(!(*obj1 = malloc(256))) goto end;
+    if(!(*obj2 = malloc(256))) goto cleanup1;
+    ... work goes here...
+cleanup2: free(*obj2);
+cleanup1: free(*obj1);
+end: return;
+}">
+    }
+    }
+    { $slide "Example: allocating and disposing two buffers"
+        { $code <" : do-stuff ( -- )
+    [
+        256 malloc &free
+        256 malloc &free
+        ... work goes here ...
+    ] with-destructors ;">
+        }
+    }
+    { $slide "Example: allocating two buffers for later"
+        { $code <" : do-stuff ( -- )
+    [
+        256 malloc |free
+        256 malloc |free
+        ... work goes here ...
+    ] with-destructors ;">
+        }
+    }
+    { $slide "Example: disposing of an output port"
+        { $code <" M: output-port dispose*
+    [
+        {
+            [ handle>> &dispose drop ]
+            [ buffer>> &dispose drop ]
+            [ port-flush ]
+            [ handle>> shutdown ]
+        } cleave
+    ] with-destructors ;">
+        }
+    }
+    { $slide "Rapid application development"
+        "We lost the dice to Settlers of Catan: Cities and Knights"
+        "Two regular dice, one special die"
+        { $vocab-link "dice" }
+    }
+    { $slide "The essence of Factor"
+        "Nicely named words abstract away the stack, leaving readable code"
+        { $code <" : surround ( seq left right -- seq' )
+    swapd 3append ;">
+        }
+        { $code <" : glue ( left right middle -- seq' )
+    swap 3append ;">
+        }
+        { $code HEREDOC: xyz
+"a" "b" "c" 3append
+"a" "<" ">" surround
+"a" "b" ", " glue
+xyz
+        }
+    }
+    { $slide "C FFI demo"
+        "Easy to call C functions from Factor"
+        "Handles C structures, C types, callbacks"
+        "Used extensively in the Windows and Unix backends"
+        { $code
+            <" FUNCTION: double pow ( double x, double y ) ;
+2 5.0 pow .">
+        }
+    }
+    { $slide "Windows win32 example"
+        { $code
+<" M: windows gmt-offset
+    ( -- hours minutes seconds )
+    "TIME_ZONE_INFORMATION" <c-object>
+    dup GetTimeZoneInformation {
+        { TIME_ZONE_ID_INVALID [
+            win32-error-string throw
+        ] }
+        { TIME_ZONE_ID_STANDARD [
+            TIME_ZONE_INFORMATION-Bias
+        ] }
+    } case neg 60 /mod 0 ;">
+        }
+    }
+    { $slide "Struct and function"
+        { $code <" C-STRUCT: TIME_ZONE_INFORMATION
+    { "LONG" "Bias" }
+    { { "WCHAR" 32 } "StandardName" }
+    { "SYSTEMTIME" "StandardDate" }
+    { "LONG" "StandardBias" }
+    { { "WCHAR" 32 } "DaylightName" }
+    { "SYSTEMTIME" "DaylightDate" }
+    { "LONG" "DaylightBias" } ;">
+        }
+        { $code <" FUNCTION: DWORD GetTimeZoneInformation (
+    LPTIME_ZONE_INFORMATION
+        lpTimeZoneInformation
+) ;">
+        }
+
+    }
+    { $slide "Cocoa FFI"
+        { $code <" IMPORT: NSAlert [
+    NSAlert -> new
+    [ -> retain ] [
+        "Raptor" <CFString> &CFRelease
+        -> setMessageText:
+    ] [
+        "Look out!" <CFString> &CFRelease
+        -> setInformativeText:
+    ] tri -> runModal drop
+] with-destructors">
+        }
+    }
+    { $slide "Deployment demo"
+        "Vocabularies can be deployed"
+        "Standalone .app on Mac"
+        "An executable and dll on Windows"
+        { $vocab-link "webkit-demo" }
+    }
+    { $slide "Interesting programs"
+        { $vocab-link "terrain" }
+        { $vocab-link "gpu.demos.raytrace" }
+        { $vocab-link "gpu.demos.bunny" }
+    }
+    { $slide "Factor's source tree"
+        "Lines of code in core/: 9,500"
+        "Lines of code in basis/: 120,000"
+        "Lines of code in extra/: 51,000"
+        "Lines of tests: 44,000"
+        "Lines of documentation: 44,500"
+    }
+    { $slide "VM trivia"
+        "Lines of C++ code: 12860"
+        "Generational garbage collection"
+        "Non-optimizing compiler"
+        "Loads an image file and runs it"
+    }
+    { $slide "Why should I use Factor?"
+        "More abstractions over time"
+        "We fix reported bugs quickly"
+        "Stackable, fluent language"
+        "Supports extreme programming"
+        "Beer-friendly programming"
+    }
+    { $slide "Questions?"
+    }
+}
+
+: tc-lisp-talk ( -- ) tc-lisp-slides slides-window ;
+
+MAIN: tc-lisp-talk

misc/vim/README

@@ -24,6 +24,8 @@ navigating Factor source:
     :FactorVocab factor.vocab.name
         Opens the source file implementing the "factor.vocab.name"
         vocabulary.
+    :NewFactorVocab factor.vocab.name
+        Creates a new factor vocabulary under the working vocabulary root.
     :FactorVocabImpl
         Opens the main implementation file for the current vocabulary
         (name.factor).  The keyboard shortcut "\fi" is bound to this
@@ -46,6 +48,10 @@ variables in your vimrc file:
         This variable should be set to a list of Factor vocabulary roots.
         The paths may be either relative to g:FactorRoot or absolute paths.
         The default value is ["core", "basis", "extra", "work"].
+    g:FactorNewVocabRoot
+        This variable should be set to the vocabulary root in which
+        vocabularies created with NewFactorVocab should be created. The
+        default value is "work".
 
 Note: The syntax-highlighting file is automatically generated to include the
 names of all the vocabularies Factor knows about. To regenerate it manually,

misc/vim/plugin/factor.vim

@@ -10,7 +10,12 @@ if !exists("g:FactorVocabRoots")
     let g:FactorVocabRoots = ["core", "basis", "extra", "work"]
 endif
 
+if !exists("g:FactorNewVocabRoot")
+    let g:FactorNewVocabRoot = "work"
+endif
+
 command! -nargs=1 -complete=customlist,FactorCompleteVocab FactorVocab :call GoToFactorVocab("<args>")
+command! -nargs=1 -complete=customlist,FactorCompleteVocab NewFactorVocab :call MakeFactorVocab("<args>")
 command! FactorVocabImpl  :call GoToFactorVocabImpl()
 command! FactorVocabDocs  :call GoToFactorVocabDocs()
 command! FactorVocabTests :call GoToFactorVocabTests()
@@ -49,11 +54,11 @@ function! FactorCompleteVocab(arglead, cmdline, cursorpos)
     return vocabs
 endfunction
 
-function! FactorVocabFile(root, vocab)
+function! FactorVocabFile(root, vocab, mustexist)
     let vocabpath = substitute(a:vocab, "\\.", "/", "g")
     let vocabfile = FactorVocabRoot(a:root) . vocabpath . "/" . fnamemodify(vocabpath, ":t") . ".factor"
     
-    if getftype(vocabfile) != ""
+    if !a:mustexist || getftype(vocabfile) != ""
         return vocabfile
     else
         return ""
@@ -62,7 +67,7 @@ endfunction
 
 function! GoToFactorVocab(vocab)
     for root in g:FactorVocabRoots
-        let vocabfile = FactorVocabFile(root, a:vocab)
+        let vocabfile = FactorVocabFile(root, a:vocab, 1)
         if vocabfile != ""
             exe "edit " fnameescape(vocabfile)
             return
@@ -71,6 +76,15 @@ function! GoToFactorVocab(vocab)
     echo "Vocabulary " vocab " not found"
 endfunction
 
+function! MakeFactorVocab(vocab)
+    let vocabfile = FactorVocabFile(g:FactorNewVocabRoot, a:vocab, 0)
+    echo vocabfile
+    let vocabdir = fnamemodify(vocabfile, ":h")
+    echo vocabdir
+    exe "!mkdir -p " shellescape(vocabdir)
+    exe "edit " fnameescape(vocabfile)
+endfunction
+
 function! FactorFileBase()
     let filename = expand("%:r")
     let filename = substitute(filename, "-docs", "", "")

vm/Config.macosx.ppc

@@ -1,3 +1,3 @@
 include vm/Config.macosx
 include vm/Config.ppc
-CFLAGS += -arch ppc
+CFLAGS += -arch ppc -force_cpusubtype_ALL

vm/Config.netbsd

@@ -1,5 +1,5 @@
 include vm/Config.unix
 PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
 CFLAGS += -export-dynamic
-LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
+LIBPATH = -L/usr/X11R7/lib -Wl,-rpath,/usr/X11R7/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
 LIBS = -lm -lssl -lcrypto $(X11_UI_LIBS)

vm/cpu-ppc.S

@@ -63,7 +63,9 @@ multiply_overflow:
 
 #define SAVED_FP_REGS_SIZE 144
 
-#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + 8)
+#define SAVED_V_REGS_SIZE 208
+
+#define FRAME (RESERVED_SIZE + PARAM_SIZE + SAVED_INT_REGS_SIZE + SAVED_FP_REGS_SIZE + SAVED_V_REGS_SIZE + 8)
    
 #if defined( __APPLE__)
 	#define LR_SAVE 8
@@ -85,6 +87,14 @@ multiply_overflow:
 #define SAVE_FP(register,offset) stfd register,SAVE_AT(offset)(r1)
 #define RESTORE_FP(register,offset) lfd register,SAVE_AT(offset)(r1)
 
+#define SAVE_V(register,offset) \
+	li r2,SAVE_AT(offset) XX \
+	stvxl register,r2,r1
+
+#define RESTORE_V(register,offset) \
+	li r2,SAVE_AT(offset) XX \
+	lvxl register,r2,r1
+
 #define PROLOGUE \
 	mflr r0 XX	   /* get caller's return address */ \
 	stwu r1,-FRAME(r1) XX /* create a stack frame to hold non-volatile registers */ \
@@ -137,6 +147,31 @@ DEF(void,c_to_factor,(CELL quot)):
 	SAVE_FP(f30,52)
 	SAVE_FP(f31,54)
 
+        SAVE_V(v20,56)
+        SAVE_V(v21,60)
+        SAVE_V(v22,64)
+        SAVE_V(v23,68)
+        SAVE_V(v24,72)
+        SAVE_V(v25,76)
+        SAVE_V(v26,80)
+        SAVE_V(v27,84)
+        SAVE_V(v28,88)
+        SAVE_V(v29,92)
+        SAVE_V(v30,96)
+        SAVE_V(v31,100)
+
+        mfvscr v0
+        li r2,SAVE_AT(104)
+        stvxl v0,r2,r1
+        addi r2,r2,0xc
+        lwzx r4,r2,r1
+        lis r5,0x1
+        andc r4,r4,r5
+        stwx r4,r2,r1
+        subi r2,r2,0xc
+        lvxl v0,r2,r1
+        mtvscr v0
+
 	SAVE_INT(r3,19)	   /* save quotation since we're about to mangle it */
 
 	mr r3,r1	   /* pass call stack pointer as an argument */
@@ -145,6 +180,22 @@ DEF(void,c_to_factor,(CELL quot)):
 	RESTORE_INT(r3,19)	 /* restore quotation */
 	CALL_QUOT
 
+        RESTORE_V(v0,104)
+        mtvscr v0
+
+        RESTORE_V(v31,100)
+        RESTORE_V(v30,96)
+        RESTORE_V(v29,92)
+        RESTORE_V(v28,88)
+        RESTORE_V(v27,84)
+        RESTORE_V(v26,80)
+        RESTORE_V(v25,76)
+        RESTORE_V(v24,72)
+        RESTORE_V(v23,68)
+        RESTORE_V(v22,64)
+        RESTORE_V(v21,60)
+        RESTORE_V(v20,56)
+
 	RESTORE_FP(f31,54)
 	RESTORE_FP(f30,52)
 	RESTORE_FP(f29,50)
@@ -236,21 +287,44 @@ DEF(void,flush_icache,(void *start, int len)):
 	blr
 
 DEF(void,primitive_inline_cache_miss,(void)):
-    mflr r6
+	mflr r6
 DEF(void,primitive_inline_cache_miss_tail,(void)):
-    PROLOGUE
+	PROLOGUE
-    mr r3,r6
+	mr r3,r6
-    bl MANGLE(inline_cache_miss)
+	bl MANGLE(inline_cache_miss)
-    EPILOGUE
+	EPILOGUE
-    mtctr r3
+	mtctr r3
-    bctr
+	bctr
 
 DEF(void,get_ppc_fpu_env,(void*)):
-    mffs f0
+	mffs f0
-    stfd f0,0(r3)
+	stfd f0,0(r3)
-    blr
+	blr
 
 DEF(void,set_ppc_fpu_env,(const void*)):
-    lfd f0,0(r3)
+	lfd f0,0(r3)
-    mtfsf 0xff,f0
+	mtfsf 0xff,f0
-    blr
+	blr
+
+DEF(void,get_ppc_vmx_env,(void*)):
+	mfvscr v0
+	subi r4,r1,16
+	li r5,0xf
+	andc r4,r4,r5
+	stvxl v0,0,r4
+	li r5,0xc
+	lwzx r6,r5,r4
+	stw r6,0(r3)
+	blr
+
+DEF(void,set_ppc_vmx_env,(const void*)):
+	subi r4,r1,16
+	li r5,0xf
+	andc r4,r4,r5
+	li r5,0xc
+	lwz r6,0(r3)
+	stwx r6,r5,r4
+	lvxl v0,0,r4
+	mtvscr v0
+	blr
+

vm/cpu-ppc.hpp

@@ -62,6 +62,24 @@ inline static bool tail_call_site_p(cell return_address)
 	return (insn & 0x1) == 0;
 }
 
+inline static unsigned int fpu_status(unsigned int status)
+{
+        unsigned int r = 0;
+
+        if (status & 0x20000000)
+		r |= FP_TRAP_INVALID_OPERATION;
+        if (status & 0x10000000)
+		r |= FP_TRAP_OVERFLOW;
+        if (status & 0x08000000)
+		r |= FP_TRAP_UNDERFLOW;
+        if (status & 0x04000000)
+		r |= FP_TRAP_ZERO_DIVIDE;
+        if (status & 0x02000000)
+		r |= FP_TRAP_INEXACT;
+
+        return r;
+}
+
 /* Defined in assembly */
 VM_ASM_API void c_to_factor(cell quot);
 VM_ASM_API void throw_impl(cell quot, stack_frame *rewind);

vm/cpu-x86.32.S

@@ -58,26 +58,26 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
 	jmp *%eax
 
 DEF(void,get_sse_env,(void*)):
-    movl 4(%esp), %eax
+	movl 4(%esp), %eax
-    stmxcsr (%eax)
+	stmxcsr (%eax)
-    ret
+	ret
 
 DEF(void,set_sse_env,(const void*)):
-    movl 4(%esp), %eax
+	movl 4(%esp), %eax
-    ldmxcsr (%eax)
+	ldmxcsr (%eax)
-    ret
+	ret
 
 DEF(void,get_x87_env,(void*)):
-    movl 4(%esp), %eax
+	movl 4(%esp), %eax
-    fnstsw (%eax)
+	fnstsw (%eax)
-    fnstcw 2(%eax)
+	fnstcw 2(%eax)
-    ret
+	ret
 
 DEF(void,set_x87_env,(const void*)):
-    movl 4(%esp), %eax
+	movl 4(%esp), %eax
-    fnclex
+	fnclex
-    fldcw 2(%eax)
+	fldcw 2(%eax)
-    ret
+	ret
 
 #include "cpu-x86.S"
 

vm/cpu-x86.64.S

@@ -89,21 +89,21 @@ DEF(void,primitive_inline_cache_miss_tail,(void)):
 	jmp *%rax
 
 DEF(void,get_sse_env,(void*)):
-    stmxcsr (%rdi)
+	stmxcsr (%rdi)
-    ret
+	ret
 
 DEF(void,set_sse_env,(const void*)):
-    ldmxcsr (%rdi)
+	ldmxcsr (%rdi)
-    ret
+	ret
 
 DEF(void,get_x87_env,(void*)):
-    fnstsw (%rdi)
+	fnstsw (%rdi)
-    fnstcw 2(%rdi)
+	fnstcw 2(%rdi)
-    ret
+	ret
 
 DEF(void,set_x87_env,(const void*)):
-    fnclex
+	fnclex
-    fldcw 2(%rdi)
+	fldcw 2(%rdi)
-    ret
+	ret
 
 #include "cpu-x86.S"

vm/cpu-x86.S

@@ -1,38 +1,38 @@
 DEF(void,primitive_fixnum_add,(void)):
-    mov (DS_REG),ARG0
+	mov (DS_REG),ARG0
-    mov -CELL_SIZE(DS_REG),ARG1
+	mov -CELL_SIZE(DS_REG),ARG1
-    sub $CELL_SIZE,DS_REG
+	sub $CELL_SIZE,DS_REG
-    mov ARG1,ARITH_TEMP_1
+	mov ARG1,ARITH_TEMP_1
-    add ARG0,ARITH_TEMP_1
+	add ARG0,ARITH_TEMP_1
-    jo MANGLE(overflow_fixnum_add)
+	jo MANGLE(overflow_fixnum_add)
-    mov ARITH_TEMP_1,(DS_REG)
+	mov ARITH_TEMP_1,(DS_REG)
-    ret
+	ret
 
 DEF(void,primitive_fixnum_subtract,(void)):
-    mov (DS_REG),ARG1
+	mov (DS_REG),ARG1
-    mov -CELL_SIZE(DS_REG),ARG0
+	mov -CELL_SIZE(DS_REG),ARG0
-    sub $CELL_SIZE,DS_REG
+	sub $CELL_SIZE,DS_REG
-    mov ARG0,ARITH_TEMP_1
+	mov ARG0,ARITH_TEMP_1
-    sub ARG1,ARITH_TEMP_1
+	sub ARG1,ARITH_TEMP_1
-    jo MANGLE(overflow_fixnum_subtract)
+	jo MANGLE(overflow_fixnum_subtract)
-    mov ARITH_TEMP_1,(DS_REG)
+	mov ARITH_TEMP_1,(DS_REG)
-    ret
+	ret
 
 DEF(void,primitive_fixnum_multiply,(void)):
-    mov (DS_REG),ARITH_TEMP_1
+	mov (DS_REG),ARITH_TEMP_1
-    mov ARITH_TEMP_1,DIV_RESULT
+	mov ARITH_TEMP_1,DIV_RESULT
-    mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
+	mov -CELL_SIZE(DS_REG),ARITH_TEMP_2
-    sar $3,ARITH_TEMP_2
+	sar $3,ARITH_TEMP_2
-    sub $CELL_SIZE,DS_REG
+	sub $CELL_SIZE,DS_REG
-    imul ARITH_TEMP_2
+	imul ARITH_TEMP_2
-    jo multiply_overflow
+	jo multiply_overflow
-    mov DIV_RESULT,(DS_REG)
+	mov DIV_RESULT,(DS_REG)
-    ret
+	ret
 multiply_overflow:
-    sar $3,ARITH_TEMP_1
+	sar $3,ARITH_TEMP_1
-    mov ARITH_TEMP_1,ARG0
+	mov ARITH_TEMP_1,ARG0
-    mov ARITH_TEMP_2,ARG1
+	mov ARITH_TEMP_2,ARG1
-    jmp MANGLE(overflow_fixnum_multiply)
+	jmp MANGLE(overflow_fixnum_multiply)
 
 DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	PUSH_NONVOLATILE
@@ -77,38 +77,38 @@ DEF(F_FASTCALL void,lazy_jit_compile,(CELL quot)):
 DEF(bool,sse_version,(void)):
 	mov $0x1,RETURN_REG
 	cpuid
-    /* test $0x100000,%ecx
+	/* test $0x100000,%ecx
-    jnz sse_42
+	jnz sse_42
-    test $0x80000,%ecx
+	test $0x80000,%ecx
-    jnz sse_41
+	jnz sse_41
-    test $0x200,%ecx
+	test $0x200,%ecx
-    jnz ssse_3 */
+	jnz ssse_3 */
-    test $0x1,%ecx
+	test $0x1,%ecx
-    jnz sse_3
+	jnz sse_3
-    test $0x4000000,%edx
+	test $0x4000000,%edx
-    jnz sse_2
+	jnz sse_2
-    test $0x2000000,%edx
+	test $0x2000000,%edx
-    jnz sse_1
+	jnz sse_1
-    mov $0,%eax
+	mov $0,%eax
-    ret
+	ret
 sse_42:
-    mov $42,RETURN_REG
+	mov $42,RETURN_REG
-    ret
+	ret
 sse_41:
-    mov $41,RETURN_REG
+	mov $41,RETURN_REG
-    ret
+	ret
 ssse_3:
-    mov $33,RETURN_REG
+	mov $33,RETURN_REG
-    ret
+	ret
 sse_3:
-    mov $30,RETURN_REG
+	mov $30,RETURN_REG
-    ret
+	ret
 sse_2:
-    mov $20,RETURN_REG
+	mov $20,RETURN_REG
-    ret
+	ret
 sse_1:
-    mov $10,RETURN_REG
+	mov $10,RETURN_REG
-    ret
+	ret
 #ifdef WINDOWS
 	.section .drectve
 	.ascii " -export:sse_version"

vm/cpu-x86.hpp

@@ -50,6 +50,24 @@ inline static bool tail_call_site_p(cell return_address)
 	return call_site_opcode(return_address) == jmp_opcode;
 }
 
+inline static unsigned int fpu_status(unsigned int status)
+{
+        unsigned int r = 0;
+	
+        if (status & 0x01)
+		r |= FP_TRAP_INVALID_OPERATION;
+        if (status & 0x04)
+		r |= FP_TRAP_ZERO_DIVIDE;
+        if (status & 0x08)
+		r |= FP_TRAP_OVERFLOW;
+        if (status & 0x10)
+		r |= FP_TRAP_UNDERFLOW;
+        if (status & 0x20)
+		r |= FP_TRAP_INEXACT;
+
+        return r;
+}
+
 /* Defined in assembly */
 VM_ASM_API void c_to_factor(cell quot);
 VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to);

vm/errors.cpp

@@ -7,6 +7,7 @@ namespace factor
 user-space */
 cell signal_number;
 cell signal_fault_addr;
+unsigned int signal_fpu_status;
 stack_frame *signal_callstack_top;
 
 void out_of_memory()
@@ -130,9 +131,9 @@ void divide_by_zero_error()
 	general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
 }
 
-void fp_trap_error(stack_frame *signal_callstack_top)
+void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top)
 {
-	general_error(ERROR_FP_TRAP,F,F,signal_callstack_top);
+	general_error(ERROR_FP_TRAP,tag_fixnum(fpu_status),F,signal_callstack_top);
 }
 
 PRIMITIVE(call_clear)
@@ -158,7 +159,7 @@ void misc_signal_handler_impl()
 
 void fp_signal_handler_impl()
 {
-	fp_trap_error(signal_callstack_top);
+	fp_trap_error(signal_fpu_status,signal_callstack_top);
 }
 
 }

vm/errors.hpp

@@ -20,7 +20,7 @@ enum vm_error_type
 	ERROR_RS_UNDERFLOW,
 	ERROR_RS_OVERFLOW,
 	ERROR_MEMORY,
-    ERROR_FP_TRAP,
+	ERROR_FP_TRAP,
 };
 
 void out_of_memory();
@@ -36,7 +36,7 @@ void memory_protection_error(cell addr, stack_frame *native_stack);
 void signal_error(int signal, stack_frame *native_stack);
 void type_error(cell type, cell tagged);
 void not_implemented_error();
-void fp_trap_error();
+void fp_trap_error(unsigned int fpu_status, stack_frame *signal_callstack_top);
 
 PRIMITIVE(call_clear);
 PRIMITIVE(unimplemented);
@@ -45,6 +45,7 @@ PRIMITIVE(unimplemented);
 user-space */
 extern cell signal_number;
 extern cell signal_fault_addr;
+extern unsigned int signal_fpu_status;
 extern stack_frame *signal_callstack_top;
 
 void memory_signal_handler_impl();

vm/float_bits.hpp

@@ -5,8 +5,8 @@ namespace factor
 representations and vice versa */
 
 union double_bits_pun {
-    double x;
+	double x;
-    u64 y;
+	u64 y;
 };
 
 inline static u64 double_bits(double x)
@@ -24,8 +24,8 @@ inline static double bits_double(u64 y)
 }
 
 union float_bits_pun {
-    float x;
+	float x;
-    u32 y;
+	u32 y;
 };
 
 inline static u32 float_bits(float x)

vm/layouts.hpp

@@ -67,6 +67,16 @@ inline static cell align8(cell a)
 /* Not a real type, but code_block's type field can be set to this */
 #define PIC_TYPE 69
 
+/* Constants used when floating-point trap exceptions are thrown */
+enum
+{
+	FP_TRAP_INVALID_OPERATION = 1 << 0,
+	FP_TRAP_OVERFLOW          = 1 << 1,
+	FP_TRAP_UNDERFLOW         = 1 << 2,
+	FP_TRAP_ZERO_DIVIDE       = 1 << 3,
+	FP_TRAP_INEXACT           = 1 << 4,
+};
+
 inline static bool immediate_p(cell obj)
 {
 	return (obj == F || TAG(obj) == FIXNUM_TYPE);

vm/mach_signal.cpp

@@ -32,7 +32,8 @@ static void call_fault_handler(
     exception_type_t exception,
     exception_data_type_t code,
 	MACH_EXC_STATE_TYPE *exc_state,
-	MACH_THREAD_STATE_TYPE *thread_state)
+	MACH_THREAD_STATE_TYPE *thread_state,
+        MACH_FLOAT_STATE_TYPE *float_state)
 {
 	/* There is a race condition here, but in practice an exception
 	delivered during stack frame setup/teardown or while transitioning
@@ -56,6 +57,8 @@ static void call_fault_handler(
 	}
 	else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
 	{
+                signal_fpu_status = fpu_status(mach_fpu_status(float_state));
+                mach_clear_fpu_status(float_state);
 		MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
 	}
 	else
@@ -78,14 +81,15 @@ catch_exception_raise (mach_port_t exception_port,
 {
 	MACH_EXC_STATE_TYPE exc_state;
 	MACH_THREAD_STATE_TYPE thread_state;
-	mach_msg_type_number_t state_count;
+	MACH_FLOAT_STATE_TYPE float_state;
+	mach_msg_type_number_t exc_state_count, thread_state_count, float_state_count;
 
 	/* Get fault information and the faulting thread's register contents..
 	
 	See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_get_state.html.  */
-	state_count = MACH_EXC_STATE_COUNT;
+	exc_state_count = MACH_EXC_STATE_COUNT;
 	if (thread_get_state (thread, MACH_EXC_STATE_FLAVOR,
-			      (natural_t *)&exc_state, &state_count)
+			      (natural_t *)&exc_state, &exc_state_count)
 		!= KERN_SUCCESS)
 	{
 		/* The thread is supposed to be suspended while the exception
@@ -93,9 +97,19 @@ catch_exception_raise (mach_port_t exception_port,
 		return KERN_FAILURE;
 	}
 
-	state_count = MACH_THREAD_STATE_COUNT;
+	thread_state_count = MACH_THREAD_STATE_COUNT;
 	if (thread_get_state (thread, MACH_THREAD_STATE_FLAVOR,
-			      (natural_t *)&thread_state, &state_count)
+			      (natural_t *)&thread_state, &thread_state_count)
+		!= KERN_SUCCESS)
+	{
+		/* The thread is supposed to be suspended while the exception
+		handler is called. This shouldn't fail. */
+		return KERN_FAILURE;
+	}
+
+        float_state_count = MACH_FLOAT_STATE_COUNT;
+	if (thread_get_state (thread, MACH_FLOAT_STATE_FLAVOR,
+			      (natural_t *)&float_state, &float_state_count)
 		!= KERN_SUCCESS)
 	{
 		/* The thread is supposed to be suspended while the exception
@@ -105,13 +119,20 @@ catch_exception_raise (mach_port_t exception_port,
 
 	/* Modify registers so to have the thread resume executing the
 	fault handler */
-	call_fault_handler(exception,code[0],&exc_state,&thread_state);
+	call_fault_handler(exception,code[0],&exc_state,&thread_state,&float_state);
 
 	/* Set the faulting thread's register contents..
 	
 	See http://web.mit.edu/darwin/src/modules/xnu/osfmk/man/thread_set_state.html.  */
+	if (thread_set_state (thread, MACH_FLOAT_STATE_FLAVOR,
+			      (natural_t *)&float_state, float_state_count)
+		!= KERN_SUCCESS)
+	{
+		return KERN_FAILURE;
+	}
+
 	if (thread_set_state (thread, MACH_THREAD_STATE_FLAVOR,
-			      (natural_t *)&thread_state, state_count)
+			      (natural_t *)&thread_state, thread_state_count)
 		!= KERN_SUCCESS)
 	{
 		return KERN_FAILURE;

vm/os-freebsd-x86.32.hpp

@@ -1,4 +1,5 @@
 #include <ucontext.h>
+#include <machine/npx.h>
 
 namespace factor
 {
@@ -9,6 +10,39 @@ inline static void *ucontext_stack_pointer(void *uap)
         return (void *)ucontext->uc_mcontext.mc_esp;
 }
 
+inline static unsigned int uap_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+	{
+		struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
+		return x87->sv_env.en_sw;
+        }
+	else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+	{
+		struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
+		return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
+        }
+	else
+		return 0;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+	{
+		struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
+		x87->sv_env.en_sw = 0;
+        }
+	else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+	{
+		struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
+		xmm->sv_env.en_sw = 0;
+		xmm->sv_env.en_mxcsr &= 0xffffffc0;
+        }
+}
+
 #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_eip)
 
 }

vm/os-freebsd-x86.64.hpp

@@ -1,4 +1,5 @@
 #include <ucontext.h>
+#include <machine/fpu.h>
 
 namespace factor
 {
@@ -9,6 +10,29 @@ inline static void *ucontext_stack_pointer(void *uap)
         return (void *)ucontext->uc_mcontext.mc_rsp;
 }
 
+inline static unsigned int uap_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+	{
+		struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
+		return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
+        }
+	else
+		return 0;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+	{
+		struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
+		xmm->sv_env.en_sw = 0;
+		xmm->sv_env.en_mxcsr &= 0xffffffc0;
+        }
+}
+
 #define UAP_PROGRAM_COUNTER(ucontext) (((ucontext_t *)(ucontext))->uc_mcontext.mc_rip)
 
 }

vm/os-linux-x86.32.hpp

@@ -3,10 +3,55 @@
 namespace factor
 {
 
+// glibc lies about the contents of the fpstate the kernel provides, hiding the FXSR
+// environment
+struct _fpstate {
+	/* Regular FPU environment */
+	unsigned long   cw;
+	unsigned long   sw;
+	unsigned long   tag;
+	unsigned long   ipoff;
+	unsigned long   cssel;
+	unsigned long   dataoff;
+	unsigned long   datasel;
+	struct _fpreg   _st[8];
+	unsigned short  status;
+	unsigned short  magic;          /* 0xffff = regular FPU data only */
+	
+	/* FXSR FPU environment */
+	unsigned long   _fxsr_env[6];   /* FXSR FPU env is ignored */
+	unsigned long   mxcsr;
+	unsigned long   reserved;
+	struct _fpxreg  _fxsr_st[8];    /* FXSR FPU reg data is ignored */
+	struct _xmmreg  _xmm[8];
+	unsigned long   padding[56];
+};
+
+#define X86_FXSR_MAGIC          0x0000
+
 inline static void *ucontext_stack_pointer(void *uap)
 {
-        ucontext_t *ucontext = (ucontext_t *)uap;
+	ucontext_t *ucontext = (ucontext_t *)uap;
-        return (void *)ucontext->uc_mcontext.gregs[7];
+	return (void *)ucontext->uc_mcontext.gregs[7];
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+	ucontext_t *ucontext = (ucontext_t *)uap;
+	struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
+	if (fpregs->magic == X86_FXSR_MAGIC)
+	    return fpregs->sw | fpregs->mxcsr;
+	else
+	    return fpregs->sw;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+	ucontext_t *ucontext = (ucontext_t *)uap;
+	struct _fpstate *fpregs = (struct _fpstate *)ucontext->uc_mcontext.fpregs;
+	fpregs->sw = 0;
+	if (fpregs->magic == X86_FXSR_MAGIC)
+	    fpregs->mxcsr &= 0xffffffc0;
 }
 
 #define UAP_PROGRAM_COUNTER(ucontext) \

vm/os-linux-x86.64.hpp

@@ -9,6 +9,20 @@ inline static void *ucontext_stack_pointer(void *uap)
         return (void *)ucontext->uc_mcontext.gregs[15];
 }
 
+inline static unsigned int uap_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        return ucontext->uc_mcontext.fpregs->swd
+             | ucontext->uc_mcontext.fpregs->mxcsr;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        ucontext->uc_mcontext.fpregs->swd = 0;
+        ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
+}
+
 #define UAP_PROGRAM_COUNTER(ucontext) \
 	(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])
 

vm/os-macosx-ppc.hpp

@@ -18,28 +18,63 @@ Modified for Factor by Slava Pestov */
 #define MACH_EXC_STATE_TYPE ppc_exception_state_t
 #define MACH_EXC_STATE_FLAVOR PPC_EXCEPTION_STATE
 #define MACH_EXC_STATE_COUNT PPC_EXCEPTION_STATE_COUNT
+
 #define MACH_EXC_INTEGER_DIV EXC_PPC_ZERO_DIVIDE
+
 #define MACH_THREAD_STATE_TYPE ppc_thread_state_t
 #define MACH_THREAD_STATE_FLAVOR PPC_THREAD_STATE
 #define MACH_THREAD_STATE_COUNT PPC_THREAD_STATE_COUNT
 
+#define MACH_FLOAT_STATE_TYPE ppc_float_state_t
+#define MACH_FLOAT_STATE_FLAVOR PPC_FLOAT_STATE
+#define MACH_FLOAT_STATE_COUNT PPC_FLOAT_STATE_COUNT
+
 #if __DARWIN_UNIX03
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__dar
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->__r1
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__srr0
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+        #define FPSCR(float_state) (float_state)->__fpscr
 #else
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->dar
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->r1
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->srr0
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+        #define FPSCR(float_state) (float_state)->fpscr
 #endif
 
+#define UAP_PROGRAM_COUNTER(ucontext) \
+        MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(ppc_float_state_t *float_state)
+{
+	return FPSCR(float_state);
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+	return mach_fpu_status(UAP_FS(uap));
+}
+
 inline static cell fix_stack_pointer(cell sp)
 {
 	return sp;
 }
 
+inline static void mach_clear_fpu_status(ppc_float_state_t *float_state)
+{
+	FPSCR(float_state) &= 0x0007f8ff;
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+	mach_clear_fpu_status(UAP_FS(uap));
+}
+
 }

vm/os-macosx-x86.32.hpp

@@ -16,28 +16,68 @@ Modified for Factor by Slava Pestov */
 #define MACH_EXC_STATE_TYPE i386_exception_state_t
 #define MACH_EXC_STATE_FLAVOR i386_EXCEPTION_STATE
 #define MACH_EXC_STATE_COUNT i386_EXCEPTION_STATE_COUNT
+
 #define MACH_EXC_INTEGER_DIV EXC_I386_DIV
+
 #define MACH_THREAD_STATE_TYPE i386_thread_state_t
 #define MACH_THREAD_STATE_FLAVOR i386_THREAD_STATE
 #define MACH_THREAD_STATE_COUNT i386_THREAD_STATE_COUNT
 
+#define MACH_FLOAT_STATE_TYPE i386_float_state_t
+#define MACH_FLOAT_STATE_FLAVOR i386_FLOAT_STATE
+#define MACH_FLOAT_STATE_COUNT i386_FLOAT_STATE_COUNT
+
 #if __DARWIN_UNIX03
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->__esp
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__eip
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+        #define MXCSR(float_state) (float_state)->__fpu_mxcsr
+        #define X87SW(float_state) (float_state)->__fpu_fsw
 #else
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->esp
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->eip
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))	
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+        #define MXCSR(float_state) (float_state)->fpu_mxcsr
+        #define X87SW(float_state) (float_state)->fpu_fsw
 #endif
 
+#define UAP_PROGRAM_COUNTER(ucontext) \
+        MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(i386_float_state_t *float_state)
+{
+	unsigned short x87sw;
+	memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
+	return MXCSR(float_state) | x87sw;
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+	return mach_fpu_status(UAP_FS(uap));
+}
+
 inline static cell fix_stack_pointer(cell sp)
 {
 	return ((sp + 4) & ~15) - 4;
 }
 
+inline static void mach_clear_fpu_status(i386_float_state_t *float_state)
+{
+        MXCSR(float_state) &= 0xffffffc0;
+        memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+	mach_clear_fpu_status(UAP_FS(uap));
+}
+
 }

vm/os-macosx-x86.64.hpp

@@ -16,28 +16,66 @@ Modified for Factor by Slava Pestov and Daniel Ehrenberg */
 #define MACH_EXC_STATE_TYPE x86_exception_state64_t
 #define MACH_EXC_STATE_FLAVOR x86_EXCEPTION_STATE64
 #define MACH_EXC_STATE_COUNT x86_EXCEPTION_STATE64_COUNT
+
 #define MACH_EXC_INTEGER_DIV EXC_I386_DIV
+
 #define MACH_THREAD_STATE_TYPE x86_thread_state64_t
 #define MACH_THREAD_STATE_FLAVOR x86_THREAD_STATE64
 #define MACH_THREAD_STATE_COUNT MACHINE_THREAD_STATE_COUNT
 
+#define MACH_FLOAT_STATE_TYPE x86_float_state64_t
+#define MACH_FLOAT_STATE_FLAVOR x86_FLOAT_STATE64
+#define MACH_FLOAT_STATE_COUNT x86_FLOAT_STATE64_COUNT
+
 #if __DARWIN_UNIX03
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->__faultvaddr
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->__rsp
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->__rip
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__ss)
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->__ss))
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->__fs)
+
+        #define MXCSR(float_state) (float_state)->__fpu_mxcsr
+        #define X87SW(float_state) (float_state)->__fpu_fsw
 #else
 	#define MACH_EXC_STATE_FAULT(exc_state) (exc_state)->faultvaddr
 	#define MACH_STACK_POINTER(thr_state) (thr_state)->rsp
 	#define MACH_PROGRAM_COUNTER(thr_state) (thr_state)->rip
-	#define UAP_PROGRAM_COUNTER(ucontext) \
+        #define UAP_SS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->ss)
-		MACH_PROGRAM_COUNTER(&(((ucontext_t *)(ucontext))->uc_mcontext->ss))	
+        #define UAP_FS(ucontext) &(((ucontext_t *)(ucontext))->uc_mcontext->fs)
+
+        #define MXCSR(float_state) (float_state)->fpu_mxcsr
+        #define X87SW(float_state) (float_state)->fpu_fsw
 #endif
 
+#define UAP_PROGRAM_COUNTER(ucontext) \
+        MACH_PROGRAM_COUNTER(UAP_SS(ucontext))
+
+inline static unsigned int mach_fpu_status(x86_float_state64_t *float_state)
+{
+	unsigned short x87sw;
+	memcpy(&x87sw, &X87SW(float_state), sizeof(x87sw));
+	return MXCSR(float_state) | x87sw;
+}
+
+inline static unsigned int uap_fpu_status(void *uap)
+{
+	return mach_fpu_status(UAP_FS(uap));
+}
+
 inline static cell fix_stack_pointer(cell sp)
 {
 	return ((sp + 8) & ~15) - 8;
 }
 
+inline static void mach_clear_fpu_status(x86_float_state64_t *float_state)
+{
+	MXCSR(float_state) &= 0xffffffc0;
+	memset(&X87SW(float_state), 0, sizeof(X87SW(float_state)));
+}
+
+inline static void uap_clear_fpu_status(void *uap)
+{
+	mach_clear_fpu_status(UAP_FS(uap));
+}
+
 }

vm/os-netbsd-x86.32.hpp

@@ -5,4 +5,7 @@ namespace factor
 
 #define ucontext_stack_pointer(uap) ((void *)_UC_MACHINE_SP((ucontext_t *)uap))
 
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) {  }
+
 }

vm/os-netbsd-x86.64.hpp

@@ -6,4 +6,7 @@ namespace factor
 #define ucontext_stack_pointer(uap) \
 	((void *)(((ucontext_t *)(uap))->uc_mcontext.__gregs[_REG_URSP]))
 
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) {  }
+
 }

vm/os-netbsd.hpp

@@ -5,6 +5,4 @@ namespace factor
 
 #define UAP_PROGRAM_COUNTER(uap)    _UC_MACHINE_PC((ucontext_t *)uap)
 
-#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
-
 }

vm/os-openbsd-x86.32.hpp

@@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap)
 #define ucontext_stack_pointer openbsd_stack_pointer
 #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_eip)
 
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) {  }
+
 }

vm/os-openbsd-x86.64.hpp

@@ -12,4 +12,7 @@ inline static void *openbsd_stack_pointer(void *uap)
 #define ucontext_stack_pointer openbsd_stack_pointer
 #define UAP_PROGRAM_COUNTER(uap) (((struct sigcontext*)(uap))->sc_rip)
 
+static inline unsigned int uap_fpu_status(void *uap) { return 0; }
+static inline void uap_clear_fpu_status(void *uap) {  }
+
 }

vm/os-unix.cpp

@@ -136,6 +136,8 @@ void fpe_signal_handler(int signal, siginfo_t *siginfo, void *uap)
 {
 	signal_number = signal;
 	signal_callstack_top = uap_stack_pointer(uap);
+        signal_fpu_status = fpu_status(uap_fpu_status(uap));
+        uap_clear_fpu_status(uap);
 	UAP_PROGRAM_COUNTER(uap) =
             (siginfo->si_code == FPE_INTDIV || siginfo->si_code == FPE_INTOVF)
                 ? (cell)misc_signal_handler_impl

vm/os-windows-nt.32.hpp

@@ -4,4 +4,33 @@ namespace factor
 #define ESP Esp
 #define EIP Eip
 
+typedef struct DECLSPEC_ALIGN(16) _M128A {
+	ULONGLONG Low;
+	LONGLONG High;
+} M128A, *PM128A;
+
+/* The ExtendedRegisters field of the x86.32 CONTEXT structure uses this layout; however,
+ * this structure is only made available from winnt.h on x86.64 */
+typedef struct _XMM_SAVE_AREA32 {
+	WORD ControlWord;        /* 000 */
+	WORD StatusWord;         /* 002 */
+	BYTE TagWord;            /* 004 */
+	BYTE Reserved1;          /* 005 */
+	WORD ErrorOpcode;        /* 006 */
+	DWORD ErrorOffset;       /* 008 */
+	WORD ErrorSelector;      /* 00c */
+	WORD Reserved2;          /* 00e */
+	DWORD DataOffset;        /* 010 */
+	WORD DataSelector;       /* 014 */
+	WORD Reserved3;          /* 016 */
+	DWORD MxCsr;             /* 018 */
+	DWORD MxCsr_Mask;        /* 01c */
+	M128A FloatRegisters[8]; /* 020 */
+	M128A XmmRegisters[16];  /* 0a0 */
+	BYTE Reserved4[96];      /* 1a0 */
+} XMM_SAVE_AREA32, *PXMM_SAVE_AREA32;
+
+#define X87SW(ctx) (ctx)->FloatSave.StatusWord
+#define MXCSR(ctx) ((XMM_SAVE_AREA32*)((ctx)->ExtendedRegisters))->MxCsr
+
 }

vm/os-windows-nt.64.hpp

@@ -4,4 +4,7 @@ namespace factor
 #define ESP Rsp
 #define EIP Rip
 
+#define X87SW(ctx) (ctx)->FloatSave.StatusWord
+#define MXCSR(ctx) (ctx)->MxCsr
+
 }

vm/os-windows-nt.cpp

@@ -21,37 +21,41 @@ FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe)
 	else
 		signal_callstack_top = NULL;
 
-    switch (e->ExceptionCode) {
+	switch (e->ExceptionCode)
-    case EXCEPTION_ACCESS_VIOLATION:
+	{
+	case EXCEPTION_ACCESS_VIOLATION:
 		signal_fault_addr = e->ExceptionInformation[1];
 		c->EIP = (cell)memory_signal_handler_impl;
-        break;
+	break;
 
-    case EXCEPTION_FLT_DENORMAL_OPERAND:
+	case STATUS_FLOAT_DENORMAL_OPERAND:
-    case EXCEPTION_FLT_DIVIDE_BY_ZERO:
+	case STATUS_FLOAT_DIVIDE_BY_ZERO:
-    case EXCEPTION_FLT_INEXACT_RESULT:
+	case STATUS_FLOAT_INEXACT_RESULT:
-    case EXCEPTION_FLT_INVALID_OPERATION:
+	case STATUS_FLOAT_INVALID_OPERATION:
-    case EXCEPTION_FLT_OVERFLOW:
+	case STATUS_FLOAT_OVERFLOW:
-    case EXCEPTION_FLT_STACK_CHECK:
+	case STATUS_FLOAT_STACK_CHECK:
-    case EXCEPTION_FLT_UNDERFLOW:
+	case STATUS_FLOAT_UNDERFLOW:
-        c->EIP = (cell)fp_signal_handler_impl;
+	case STATUS_FLOAT_MULTIPLE_FAULTS:
-        break;
+	case STATUS_FLOAT_MULTIPLE_TRAPS:
-
+		signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
-	/* If the Widcomm bluetooth stack is installed, the BTTray.exe process
+		X87SW(c) = 0;
-	   injects code into running programs. For some reason this results in
+		MXCSR(c) &= 0xffffffc0;
-	   random SEH exceptions with this (undocumented) exception code being
+		c->EIP = (cell)fp_signal_handler_impl;
-	   raised. The workaround seems to be ignoring this altogether, since that
+		break;
-	   is what happens if SEH is not enabled. Don't really have any idea what
+	case 0x40010006:
-	   this exception means. */
+		/* If the Widcomm bluetooth stack is installed, the BTTray.exe
-    case 0x40010006:
+		process injects code into running programs. For some reason this
-        break;
+		results in random SEH exceptions with this (undocumented)
-
+		exception code being raised. The workaround seems to be ignoring
-    default:
+		this altogether, since that is what happens if SEH is not
+		enabled. Don't really have any idea what this exception means. */
+		break;
+	default:
 		signal_number = e->ExceptionCode;
 		c->EIP = (cell)misc_signal_handler_impl;
-        break;
+		break;
-    }
+	}
-    return EXCEPTION_CONTINUE_EXECUTION;
+	return EXCEPTION_CONTINUE_EXECUTION;
 }
 
 void c_to_factor_toplevel(cell quot)

vm/os-windows-nt.hpp

@@ -23,4 +23,9 @@ void c_to_factor_toplevel(cell quot);
 FACTOR_STDCALL LONG exception_handler(PEXCEPTION_POINTERS pe);
 void open_console();
 
+// SSE traps raise these exception codes, which are defined in internal NT headers
+// but not winbase.h
+#define STATUS_FLOAT_MULTIPLE_FAULTS 0xC00002B4
+#define STATUS_FLOAT_MULTIPLE_TRAPS  0xC00002B5
+
 }

vm/primitives.cpp

@@ -51,6 +51,12 @@ const primitive_type primitives[] = {
 	primitive_float_lesseq,
 	primitive_float_greater,
 	primitive_float_greatereq,
+	/* The unordered comparison primitives don't have a non-optimizing
+	compiler implementation */
+	primitive_float_less,
+	primitive_float_lesseq,
+	primitive_float_greater,
+	primitive_float_greatereq,
 	primitive_word,
 	primitive_word_xt,
 	primitive_getenv,