Add NAN: literal syntax for NANs with a payload

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 -- )

core/bootstrap/syntax.factor

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

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/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