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

basis/colors/constants/factor-colors.txt

@@ -1,4 +1,5 @@
 ! Factor UI theme colors
+243 242 234		FactorLightLightTan
 227 226 219		FactorLightTan
 172 167 147		FactorDarkTan
  81  91 105		FactorLightSlateBlue

basis/db/db-docs.factor

@@ -254,7 +254,7 @@ ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
 { $code <"
 USING: db.sqlite db io.files ;
 : with-book-db ( quot -- )
-    "book.db" temp-file <sqlite-db> swap with-db ;"> }
+    "book.db" temp-file <sqlite-db> swap with-db ; inline"> }
 "Now let's create the table manually:"
 { $code <" "create table books
     (id integer primary key, title text, author text, date_published timestamp,

basis/help/help.factor

@@ -99,19 +99,26 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
 : $navigation-row ( content element label -- )
     [ prefix 1array ] dip prefix , ;
 
+: ($navigation-table) ( element -- )
+    help-path-style get table-style set [ $table ] with-scope ;
+
 : $navigation-table ( topic -- )
     [
-        [ help-path [ \ $links "Up:" $navigation-row ] unless-empty ]
         [ prev-article [ 1array \ $long-link "Prev:" $navigation-row ] when* ]
         [ next-article [ 1array \ $long-link "Next:" $navigation-row ] when* ]
-        tri
+        bi
-    ] { } make [ $table ] unless-empty ;
+    ] { } make [ ($navigation-table) ] unless-empty ;
+
+: ($navigation) ( topic -- )
+    help-path-style get [
+        [ help-path [ reverse $breadcrumbs ] unless-empty ]
+        [ $navigation-table ] bi
+    ] with-style ;
 
 : $title ( topic -- )
     title-style get [
         title-style get [
-            [ ($title) ]
+            [ ($title) ] [ ($navigation) ] bi
-            [ help-path-style get [ $navigation-table ] with-style ] bi
         ] with-nesting
     ] with-style nl ;
 

basis/help/html/stylesheet.css

@@ -1,4 +1,4 @@
-a:link { text-decoration: none; color: #00004c; }
+a:link { text-decoration: none; color: #104e8b; }
-a:visited { text-decoration: none; color: #00004c; }
+a:visited { text-decoration: none; color: #104e8b; }
-a:active { text-decoration: none; color: #00004c; }
+a:active { text-decoration: none; color: #104e8b; }
-a:hover { text-decoration: underline; color: #00004c; }
+a:hover { text-decoration: underline; color: #104e8b; }

basis/help/markup/markup.factor

@@ -205,8 +205,11 @@ ALIAS: $slot $snippet
         "Vocabulary" $heading nl dup ($vocab-link)
     ] when* ;
 
+: (textual-list) ( seq quot sep -- )
+    '[ _ print-element ] swap interleave ; inline
+
 : textual-list ( seq quot -- )
-    [ ", " print-element ] swap interleave ; inline
+    ", " (textual-list) ; inline
 
 : $links ( topics -- )
     [ [ ($link) ] textual-list ] ($span) ;
@@ -214,6 +217,9 @@ ALIAS: $slot $snippet
 : $vocab-links ( vocabs -- )
     [ vocab ] map $links ;
 
+: $breadcrumbs ( topics -- )
+    [ [ ($link) ] " > " (textual-list) ] ($span) ;
+
 : $see-also ( topics -- )
     "See also" $heading $links ;
 

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: io.styles namespaces colors colors.constants ;
+USING: colors colors.constants io.styles literals namespaces ;
 IN: help.stylesheet
 
 SYMBOL: default-span-style
@@ -30,22 +30,27 @@ H{ { font-style bold } } strong-style set-global
 SYMBOL: title-style
 H{
     { font-name "sans-serif" }
-    { font-size 18 }
+    { font-size 20 }
     { font-style bold }
     { wrap-margin 500 }
-    { foreground COLOR: FactorDarkSlateBlue }
+    { foreground COLOR: gray20 }
-    { page-color COLOR: FactorLightTan }
+    { page-color COLOR: FactorLightLightTan }
-    { border-width 5 }
+    { inset { 5 5 } }
 } title-style set-global
 
 SYMBOL: help-path-style
-H{ { font-size 10 } } help-path-style set-global
+H{
+    { font-size 10 }
+    { table-gap { 5 5 } }
+    { table-border $ transparent }
+} help-path-style set-global
 
 SYMBOL: heading-style
 H{
     { font-name "sans-serif" }
     { font-size 16 }
     { font-style bold }
+    { foreground COLOR: FactorDarkSlateBlue }
 } heading-style set-global
 
 SYMBOL: subsection-style
@@ -70,8 +75,8 @@ H{
 
 SYMBOL: code-style
 H{
-    { page-color COLOR: FactorLightTan }
+    { page-color COLOR: FactorLightLightTan }
-    { border-width 5 }
+    { inset { 5 5 } }
     { wrap-margin f }
 } code-style set-global
 
@@ -88,7 +93,7 @@ SYMBOL: warning-style
 H{
     { page-color COLOR: gray90 }
     { border-color COLOR: red }
-    { border-width 5 }
+    { inset { 5 5 } }
     { wrap-margin 500 }
 } warning-style set-global
 
@@ -96,7 +101,7 @@ SYMBOL: deprecated-style
 H{
     { page-color COLOR: gray90 }
     { border-color COLOR: red }
-    { border-width 5 }
+    { inset { 5 5 } }
     { wrap-margin 500 }
 } deprecated-style set-global
 

basis/help/tips/tips.factor

@@ -30,7 +30,7 @@ SYMBOL: tip-of-the-day-style
 
 H{
     { page-color COLOR: lavender }
-    { border-width 5 }
+    { inset { 5 5 } }
     { wrap-margin 500 }
 } tip-of-the-day-style set-global
 

basis/html/streams/streams.factor

@@ -99,7 +99,8 @@ M: html-span-stream dispose
 : border-css, ( border -- )
     "border: 1px solid #" % hex-color, "; " % ;
 
-: padding-css, ( padding -- ) "padding: " % # "px; " % ;
+: padding-css, ( padding -- )
+    first2 "padding: " % # "px " % # "px; " % ;
 
 CONSTANT: pre-css "white-space: pre; font-family: monospace;"
 
@@ -108,7 +109,7 @@ CONSTANT: pre-css "white-space: pre; font-family: monospace;"
         {
             { page-color bg-css, }
             { border-color border-css, }
-            { border-width padding-css, }
+            { inset padding-css, }
         } make-css
     ] [
         wrap-margin swap at

basis/io/styles/styles-docs.factor

@@ -133,7 +133,7 @@ ARTICLE: "paragraph-styles" "Paragraph styles"
 "Paragraph styles for " { $link with-nesting } ":"
 { $subsection page-color }
 { $subsection border-color }
-{ $subsection border-width }
+{ $subsection inset }
 { $subsection wrap-margin }
 { $subsection presented } ;
 
@@ -243,10 +243,10 @@ HELP: border-color
     { $code "H{ { border-color T{ rgba f 1 0 0 1 } } }\n[ \"A border\" write ] with-nesting nl" }
 } ;
 
-HELP: border-width
+HELP: inset
-{ $description "Paragraph style. Pixels between edge of text and border, an integer." } 
+{ $description "Paragraph style. A pair of integers representing the number of pixels that the content should be inset from the border. The first number is the horizontal inset, and the second is the vertical inset." } 
 { $examples
-    { $code "H{ { border-width 10 } }\n[ \"Some inset text\" write ] with-nesting nl" }
+    { $code "H{ { inset { 10 10 } } }\n[ \"Some inset text\" write ] with-nesting nl" }
 } ;
 
 HELP: wrap-margin

basis/io/styles/styles.factor

@@ -132,7 +132,7 @@ SYMBOL: image
 ! Paragraph styles
 SYMBOL: page-color
 SYMBOL: border-color
-SYMBOL: border-width
+SYMBOL: inset
 SYMBOL: wrap-margin
 
 ! Table styles

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

@@ -31,14 +31,14 @@ CONSTANT: ppc-exception-flag>bit
         { +fp-inexact+           HEX: 0200,0000 }
     }
 
-CONSTANT: ppc-fp-traps-bits HEX: f800
+CONSTANT: ppc-fp-traps-bits HEX: f8
 CONSTANT: ppc-fp-traps>bit
     H{
-        { +fp-invalid-operation+ HEX: 8000 }
+        { +fp-invalid-operation+ HEX: 80 }
-        { +fp-overflow+          HEX: 4000 }
+        { +fp-overflow+          HEX: 40 }
-        { +fp-underflow+         HEX: 2000 }
+        { +fp-underflow+         HEX: 20 }
-        { +fp-zero-divide+       HEX: 1000 }
+        { +fp-zero-divide+       HEX: 10 }
-        { +fp-inexact+           HEX: 0800 }
+        { +fp-inexact+           HEX: 08 }
     }
 
 CONSTANT: ppc-rounding-mode-bits HEX: 3
@@ -58,9 +58,9 @@ M: ppc-fpu-env (set-exception-flags) ( register exceptions -- register' )
     [ ppc-exception-flag>bit >mask ppc-exception-flag-bits remask ] curry change-fpscr ; inline
 
 M: ppc-fpu-env (get-fp-traps) ( register -- exceptions )
-    fpscr>> bitnot ppc-fp-traps>bit mask> ; inline
+    fpscr>> ppc-fp-traps>bit mask> ; inline
 M: ppc-fpu-env (set-fp-traps) ( register exceptions -- register' )
-    [ ppc-fp-traps>bit >mask bitnot ppc-fp-traps-bits remask ] curry change-fpscr ; inline
+    [ ppc-fp-traps>bit >mask ppc-fp-traps-bits remask ] curry change-fpscr ; inline
 
 M: ppc-fpu-env (get-rounding-mode) ( register -- mode )
     fpscr>> ppc-rounding-mode-bits mask ppc-rounding-mode>bit value-at ; inline

basis/math/functions/functions-docs.factor

@@ -20,10 +20,6 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
 "Computing additive and multiplicative inverses:"
 { $subsection neg }
 { $subsection recip }
-"Minimum, maximum, clamping:"
-{ $subsection min }
-{ $subsection max }
-{ $subsection clamp }
 "Complex conjugation:"
 { $subsection conjugate }
 "Tests:"
@@ -41,7 +37,8 @@ ARTICLE: "arithmetic-functions" "Arithmetic functions"
 { $subsection truncate }
 { $subsection round }
 "Inexact comparison:"
-{ $subsection ~ } ;
+{ $subsection ~ }
+"Numbers implement the " { $link "math.order" } ", therefore operations such as " { $link min } " and " { $link max } " can be used with numbers." ;
 
 ARTICLE: "power-functions" "Powers and logarithms"
 "Squares:"

basis/prettyprint/backend/backend.factor

@@ -47,6 +47,11 @@ M: method-body pprint*
 
 M: real pprint* number>string text ;
 
+M: float pprint*
+    dup fp-nan? [
+        \ NAN: [ fp-nan-payload >hex text ] pprint-prefix
+    ] [ call-next-method ] if ;
+
 M: f pprint* drop \ f pprint-word ;
 
 : pprint-effect ( effect -- )

basis/prettyprint/stylesheet/stylesheet-docs.factor

@@ -0,0 +1,44 @@
+! Copyright (C) 2009 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel words ;
+IN: prettyprint.stylesheet
+
+HELP: effect-style
+{ $values
+    { "effect" "an effect" }
+    { "style" "a style assoc" }
+}
+{ $description "The styling hook for stack effects" } ;
+
+HELP: string-style
+{ $values
+    { "str" "a string" }
+    { "style" "a style assoc" }
+}
+{ $description "The styling hook for string literals" } ;
+
+HELP: vocab-style
+{ $values
+    { "vocab" "a vocabulary specifier" }
+    { "style" "a style assoc" }
+}
+{ $description "The styling hook for vocab names" } ;
+
+HELP: word-style
+{ $values
+    { "word" "a word" }
+    { "style" "a style assoc" }
+}
+{ $description "The styling hook for word names" } ;
+
+ARTICLE: "prettyprint.stylesheet" "Prettyprinter Formatted Output"
+{ $vocab-link "prettyprint.stylesheet" }
+$nl
+"Control the way that the prettyprinter formats output based on object type. These hooks form a basic \"syntax\" highlighting system."
+{ $subsection word-style }
+{ $subsection string-style } 
+{ $subsection vocab-style }
+{ $subsection effect-style }
+;
+
+ABOUT: "prettyprint.stylesheet"

basis/prettyprint/stylesheet/stylesheet.factor

@@ -1,34 +1,46 @@
-! Copyright (C) 2009 Your name.
+! Copyright (C) 2009 Keith Lazuka.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: colors.constants hashtables io.styles kernel namespaces
+USING: assocs colors.constants combinators
-words words.symbol ;
+combinators.short-circuit hashtables io.styles kernel literals
+namespaces sequences words words.symbol ;
 IN: prettyprint.stylesheet
 
-: word-style ( word -- style )
+<PRIVATE
-    dup "word-style" word-prop >hashtable [
-        [
-            [ presented set ] [
-                [ parsing-word? ] [ delimiter? ] [ symbol? ] tri
-                or or [ COLOR: DarkSlateGray ] [ COLOR: black ] if
-                foreground set
-            ] bi
-        ] bind
-    ] keep ;
 
-: string-style ( obj -- style )
+CONSTANT: dim-color COLOR: gray35
-    [
+
-        presented set
+{ POSTPONE: USING: POSTPONE: USE: POSTPONE: IN: }
-        COLOR: LightSalmon4 foreground set
+[
-    ] H{ } make-assoc ;
+    { { foreground $ dim-color } }
+    "word-style" set-word-prop
+] each
+
+PREDICATE: highlighted-word < word [ parsing-word? ] [ delimiter? ] bi or ;
+
+PRIVATE>
+
+GENERIC: word-style ( word -- style )
+
+M: word word-style
+    [ presented associate ]
+    [ "word-style" word-prop >hashtable ] bi assoc-union ;
+
+M: highlighted-word word-style
+    call-next-method COLOR: DarkSlateGray foreground associate
+    swap assoc-union ;
+
+<PRIVATE
+
+: colored-presentation-style ( obj color -- style )
+    [ presented associate ] [ foreground associate ] bi* assoc-union ;
+
+PRIVATE>
+
+: string-style ( str -- style )
+    COLOR: LightSalmon4 colored-presentation-style ;
 
 : vocab-style ( vocab -- style )
-    [
+    dim-color colored-presentation-style ;
-        presented set
-        COLOR: cornsilk4 foreground set
-    ] H{ } make-assoc ;
 
 : effect-style ( effect -- style )
-    [
+    COLOR: DarkGreen colored-presentation-style ;
-        presented set
-        COLOR: DarkGreen foreground set
-    ] H{ } make-assoc ;

basis/prettyprint/stylesheet/summary.txt

@@ -0,0 +1 @@
+prettyprinter syntax highlighting and formatted output

basis/tools/deploy/test/test.factor

@@ -12,7 +12,11 @@ IN: tools.deploy.test
 
 : small-enough? ( n -- ? )
     [ "test.image" temp-file file-info size>> ]
-    [ cell 4 / * cpu ppc? [ 100000 + ] when ] bi*
+    [
+        cell 4 / *
+        cpu ppc? [ 100000 + ] when
+        os windows? [ 150000 + ] when
+    ] bi*
     <= ;
 
 : run-temp-image ( -- )

basis/ui/gadgets/panes/panes.factor

@@ -242,11 +242,11 @@ MEMO: specified-font ( assoc -- font )
 : apply-page-color-style ( style gadget -- style gadget )
     page-color [ <solid> >>interior ] apply-style ;
 
-: apply-border-width-style ( style gadget -- style gadget )
+: apply-inset-style ( style gadget -- style gadget )
-    border-width [ dup 2array <border> ] apply-style ;
+    inset [ <border> ] apply-style ;
 
 : style-pane ( style pane -- pane )
-    apply-border-width-style
+    apply-inset-style
     apply-border-color-style
     apply-page-color-style
     apply-presentation-style

basis/vocabs/prettyprint/prettyprint.factor

@@ -4,6 +4,7 @@ USING: accessors arrays assocs colors colors.constants fry io
 io.styles kernel make math.order namespaces parser
 prettyprint.backend prettyprint.sections prettyprint.stylesheet
 sequences sets sorting vocabs vocabs.parser ;
+FROM: io.styles => inset ;
 IN: vocabs.prettyprint
 
 : pprint-vocab ( vocab -- )
@@ -86,7 +87,10 @@ PRIVATE>
         "To avoid doing this in the future, add the following forms" print
         "at the top of the source file:" print nl
     ] with-style
-    { { page-color COLOR: FactorLightTan } }
+    {
-    [ manifest get pprint-manifest ] with-nesting
+        { page-color COLOR: FactorLightLightTan }
+        { border-color COLOR: FactorDarkTan }
+        { inset { 5 5 } }
+    } [ manifest get pprint-manifest ] with-nesting
     nl nl
 ] print-use-hook set-global

basis/windows/dinput/constants/constants.factor

@@ -49,7 +49,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
     } cleave
     DIOBJECTDATAFORMAT <struct-boa> ;
 
-:: malloc-DIOBJECTDATAFORMAT-array ( struct array -- alien )
+:: make-DIOBJECTDATAFORMAT-array ( struct array -- alien )
     [let | alien [ array length malloc-DIOBJECTDATAFORMAT-array ] |
         array [| args i |
             struct args <DIOBJECTDATAFORMAT>
@@ -60,7 +60,7 @@ MEMO: heap-size* ( c-type -- n ) heap-size ;
 
 : <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
     [ DIDATAFORMAT heap-size DIOBJECTDATAFORMAT heap-size ] 4 ndip
-    [ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
+    [ nip length ] [ make-DIOBJECTDATAFORMAT-array ] 2bi
     DIDATAFORMAT <struct-boa> ;
 
 : initialize ( symbol quot -- )

core/bootstrap/syntax.factor

@@ -33,6 +33,7 @@ IN: bootstrap.syntax
     "MAIN:"
     "MATH:"
     "MIXIN:"
+    "NAN:"
     "OCT:"
     "P\""
     "POSTPONE:"

core/math/floats/floats-tests.factor

@@ -67,3 +67,11 @@ unit-test
 [ t ] [ 0/0. 1.0 unordered? ] unit-test
 [ f ] [ 1.0 1.0 unordered? ] unit-test
 
+[ t ] [ -0.0 fp-sign ] unit-test
+[ t ] [ -1.0 fp-sign ] unit-test
+[ f ] [ 0.0 fp-sign ] unit-test
+[ f ] [ 1.0 fp-sign ] unit-test
+
+[ t ] [ -0.0 abs 0.0 fp-bitwise= ] unit-test
+[ 1.5 ] [ -1.5 abs ] unit-test
+[ 1.5 ] [ 1.5 abs ] unit-test

core/math/floats/floats.factor

@@ -50,7 +50,7 @@ M: float fp-snan?
 M: float fp-infinity?
     dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
 
-M: float next-float ( m -- n )
+M: float next-float
     double>bits
     dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
         dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
@@ -60,10 +60,14 @@ M: float next-float ( m -- n )
 
 M: float unordered? [ fp-nan? ] bi@ or ; inline
 
-M: float prev-float ( m -- n )
+M: float prev-float
     double>bits
     dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
         dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
             1 - bits>double ! positive non-zero
         ] if
     ] if ; inline
+
+M: float fp-sign double>bits 63 bit? ; inline
+
+M: float abs double>bits 63 2^ bitnot bitand bits>double ; inline

core/math/math-docs.factor

@@ -277,7 +277,32 @@ HELP: fp-bitwise=
     { "x" float } { "y" float }
     { "?" boolean }
 }
-{ $description "Compares two floating point numbers for bit equality." } ;
+{ $description "Compares two floating point numbers for bit equality." }
+{ $notes "Unlike " { $link = } " or " { $link number= } ", this word will consider NaNs with equal payloads to be equal, and positive zero and negative zero to be not equal." }
+{ $examples
+    "Not-a-number equality:"
+    { $example
+        "USING: math prettyprint ;"
+        "0.0 0.0 / dup number= ."
+        "f"
+    }
+    { $example
+        "USING: math prettyprint ;"
+        "0.0 0.0 / dup fp-bitwise= ."
+        "t"
+    }
+    "Signed zero equality:"
+    { $example
+        "USING: math prettyprint ;"
+        "-0.0 0.0 fp-bitwise= ."
+        "f"
+    }
+    { $example
+        "USING: math prettyprint ;"
+        "-0.0 0.0 = ."
+        "t"
+    }
+} ;
 
 HELP: fp-special?
 { $values { "x" real } { "?" "a boolean" } }

core/math/math.factor

@@ -99,13 +99,13 @@ GENERIC: fp-qnan? ( x -- ? )
 GENERIC: fp-snan? ( x -- ? )
 GENERIC: fp-infinity? ( x -- ? )
 GENERIC: fp-nan-payload ( x -- bits )
+GENERIC: fp-sign ( x -- ? )
 
 M: object fp-special? drop f ; inline
 M: object fp-nan? drop f ; inline
 M: object fp-qnan? drop f ; inline
 M: object fp-snan? drop f ; inline
 M: object fp-infinity? drop f ; inline
-M: object fp-nan-payload drop f ; inline
 
 : <fp-nan> ( payload -- nan )
     HEX: 7ff0000000000000 bitor bits>double ; inline

core/math/order/order-docs.factor

@@ -44,39 +44,41 @@ HELP: compare
 } ;
 
 HELP: max
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" object } { "y" object } { "z" object } }
-{ $description "Outputs the greatest of two real numbers." } ;
+{ $description "Outputs the greatest of two ordered values." }
+{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
 
 HELP: min
-{ $values { "x" real } { "y" real } { "z" real } }
+{ $values { "x" object } { "y" object } { "z" object } }
-{ $description "Outputs the smallest of two real numbers." } ;
+{ $description "Outputs the smallest of two ordered values." }
+{ $notes "If one value is a floating point positive zero and the other is a negative zero, the result is undefined." } ;
 
 HELP: clamp
-{ $values { "x" real } { "min" real } { "max" real } { "y" real } }
+{ $values { "x" object } { "min" object } { "max" object } { "y" object } }
 { $description "Outputs " { $snippet "x" } " if contained in the interval " { $snippet "[min,max]" } " or outputs one of the endpoints." } ;
 
 HELP: between?
-{ $values { "x" real } { "y" real } { "z" real } { "?" "a boolean" } }
+{ $values { "x" object } { "y" object } { "z" real } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "x" } " is in the interval " { $snippet "[y,z]" } "." }
 { $notes "As per the closed interval notation, the end-points are included in the interval." } ;
 
 HELP: before?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "obj1" } " comes before " { $snippet "obj2" } " using an intrinsic total order." }
 { $notes "Implemented using " { $link <=> } "." } ;
 
 HELP: after?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "obj1" } " comes after " { $snippet "obj2" } " using an intrinsic total order." }
 { $notes "Implemented using " { $link <=> } "." } ;
 
 HELP: before=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "obj1" } " comes before or equals " { $snippet "obj2" } " using an intrinsic total order." }
 { $notes "Implemented using " { $link <=> } "." } ;
 
 HELP: after=?
-{ $values { "obj1" "an object" } { "obj2" "an object" } { "?" "a boolean" } }
+{ $values { "obj1" object } { "obj2" object } { "?" "a boolean" } }
 { $description "Tests if " { $snippet "obj1" } " comes after or equals " { $snippet "obj2" } " using an intrinsic total order." }
 { $notes "Implemented using " { $link <=> } "." } ;
 
@@ -100,7 +102,7 @@ ARTICLE: "math.order.example" "Linear order example"
 } ;
 
 ARTICLE: "math.order" "Linear order protocol"
-"Some classes have an intrinsic order amongst instances:"
+"Some classes define an intrinsic order amongst instances. This includes numbers, sequences (in particular, strings), and words."
 { $subsection <=> }
 { $subsection >=< }
 { $subsection compare }
@@ -112,6 +114,10 @@ ARTICLE: "math.order" "Linear order protocol"
 { $subsection before? }
 { $subsection after=? }
 { $subsection before=? }
+"Minimum, maximum, clamping:"
+{ $subsection min }
+{ $subsection max }
+{ $subsection clamp }
 "Out of the above generic words, it suffices to implement " { $link <=> } " alone. The others may be provided as an optimization."
 { $subsection "math.order.example" }
 { $see-also "sequences-sorting" } ;

core/parser/parser.factor

@@ -99,8 +99,11 @@ M: f parse-quotation \ ] parse-until >quotation ;
 
 ERROR: bad-number ;
 
+: scan-base ( base -- n )
+    scan swap base> [ bad-number ] unless* ;
+
 : parse-base ( parsed base -- parsed )
-    scan swap base> [ bad-number ] unless* parsed ;
+    scan-base parsed ;
 
 SYMBOL: bootstrap-syntax
 

core/syntax/syntax-docs.factor

@@ -72,6 +72,8 @@ ARTICLE: "syntax-floats" "Float syntax"
 { "Negative infinity" { $snippet "-1/0." } }
 { "Not-a-number" { $snippet "0/0." } }
 }
+"A Not-a-number with an arbitrary payload can be parsed in:"
+{ $subsection POSTPONE: NAN: }
 "More information on floats can be found in " { $link "floats" } "." ;
 
 ARTICLE: "syntax-complex-numbers" "Complex number syntax"
@@ -603,6 +605,18 @@ HELP: BIN:
 { $description "Adds an integer read from an binary literal to the parse tree." }
 { $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
 
+HELP: NAN:
+{ $syntax "NAN: payload" }
+{ $values { "payload" "64-bit hexadecimal integer" } }
+{ $description "Adds a floating point Not-a-Number literal to the parse tree." }
+{ $examples
+    { $example
+        "USE: prettyprint"
+        "NAN: deadbeef ."
+        "NAN: deadbeef"
+    }
+} ;
+
 HELP: GENERIC:
 { $syntax "GENERIC: word ( stack -- effect )" }
 { $values { "word" "a new word to define" } }

core/syntax/syntax.factor

@@ -73,6 +73,8 @@ IN: bootstrap.syntax
     "OCT:" [ 8 parse-base ] define-core-syntax
     "BIN:" [ 2 parse-base ] define-core-syntax
 
+    "NAN:" [ 16 scan-base <fp-nan> parsed ] define-core-syntax
+
     "f" [ f parsed ] define-core-syntax
     "t" "syntax" lookup define-singleton-class
 

extra/benchmark/euler186/euler186.factor

@@ -1,7 +0,0 @@
-IN: benchmark.euler186
-USING: kernel project-euler.186 ;
-
-: euler186-benchmark ( -- )
-    euler186 2325629 assert= ;
-
-MAIN: euler186-benchmark

vm/cpu-x86.S

@@ -56,6 +56,11 @@ DEF(F_FASTCALL void,c_to_factor,(CELL quot)):
 	ret
 
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to)):
+	/* clear x87 stack, but preserve rounding mode and exception flags */
+	sub $2,STACK_REG
+	fnstcw (STACK_REG)
+	fninit
+	fldcw (STACK_REG)
 	/* rewind_to */
 	mov ARG1,STACK_REG                    
 	jmp *QUOT_XT_OFFSET(ARG0)

vm/errors.cpp

@@ -130,9 +130,9 @@ void divide_by_zero_error()
 	general_error(ERROR_DIVIDE_BY_ZERO,F,F,NULL);
 }
 
-void fp_trap_error()
+void fp_trap_error(stack_frame *signal_callstack_top)
 {
-	general_error(ERROR_FP_TRAP,F,F,NULL);
+	general_error(ERROR_FP_TRAP,F,F,signal_callstack_top);
 }
 
 PRIMITIVE(call_clear)
@@ -158,7 +158,7 @@ void misc_signal_handler_impl()
 
 void fp_signal_handler_impl()
 {
-    fp_trap_error();
+	fp_trap_error(signal_callstack_top);
 }
 
 }

vm/mach_signal.cpp

@@ -55,12 +55,12 @@ static void call_fault_handler(
 		MACH_PROGRAM_COUNTER(thread_state) = (cell)memory_signal_handler_impl;
 	}
 	else if(exception == EXC_ARITHMETIC && code != MACH_EXC_INTEGER_DIV)
-    {
+	{
 		MACH_PROGRAM_COUNTER(thread_state) = (cell)fp_signal_handler_impl;
-    }
+	}
-    else
+	else
-    {
+	{
-        signal_number = exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT;
+		signal_number = (exception == EXC_ARITHMETIC ? SIGFPE : SIGABRT);
 		MACH_PROGRAM_COUNTER(thread_state) = (cell)misc_signal_handler_impl;
 	}
 }