From 47bc1498f785c27cdb305825882fdb544dcc87cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 12 Sep 2009 15:06:15 -0500
Subject: [PATCH] Add NAN: literal syntax for NANs with a payload

---
 basis/prettyprint/backend/backend.factor |  5 +++++
 core/bootstrap/syntax.factor             |  1 +
 core/math/math-docs.factor               | 27 +++++++++++++++++++++++-
 core/parser/parser.factor                |  5 ++++-
 core/syntax/syntax-docs.factor           | 14 ++++++++++++
 core/syntax/syntax.factor                |  2 ++
 6 files changed, 52 insertions(+), 2 deletions(-)

diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 90e2388934..f8bcb66b1e 100644
--- a/basis/prettyprint/backend/backend.factor
+++ b/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 -- )
diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor
index 906b73934e..57be2fb90f 100644
--- a/core/bootstrap/syntax.factor
+++ b/core/bootstrap/syntax.factor
@@ -33,6 +33,7 @@ IN: bootstrap.syntax
     "MAIN:"
     "MATH:"
     "MIXIN:"
+    "NAN:"
     "OCT:"
     "P\""
     "POSTPONE:"
diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor
index ab2a5ab8be..d98685fb48 100644
--- a/core/math/math-docs.factor
+++ b/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" } }
diff --git a/core/parser/parser.factor b/core/parser/parser.factor
index 94eb0a865c..276030d770 100644
--- a/core/parser/parser.factor
+++ b/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
 
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index fd5590fde1..19e644cb68 100644
--- a/core/syntax/syntax-docs.factor
+++ b/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" } }
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index f01f90c027..16645e3342 100644
--- a/core/syntax/syntax.factor
+++ b/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