json-write: more number checks.

Author: Amirouche

srfi-180.html

@@ -141,7 +141,8 @@ <h3 id="json-write-obj-port-unspecified"><code>(json-write obj [port]) → unspe
 <ul>
 <li>symbol <code>'null</code></li>
 <li>boolean</li>
-<li>real number</li>
+<li>number must be integers or inexact rational (that is they must not
+be complex, infinite, nan, or exact rational that are not integers)</li>
 <li>string</li>
 <li>vector</li>
 <li>association list</li>

srfi/json-checks.sld

@@ -320,7 +320,16 @@
           y_structure_string_empty.json
           y_structure_trailing_newline.json
           y_structure_true_in_array.json
-          y_structure_whitespace_array.json)
+          y_structure_whitespace_array.json
+          ;; scheme specific
+          n_+inf.0
+          n_-inf.0
+          n_complex
+          n_-nan.0
+          n_+nan.0
+          n_exact_not_integer
+
+          )
 
   (import (scheme base))
   (import (scheme file))
@@ -347,6 +356,12 @@
        (lambda (port)
          (json-read port))))
 
+    (define (json-string->obj string)
+      (call-with-input-string string json-read))
+
+    (define (obj->json-string obj)
+      (call-with-output-string (lambda (port) (json-write obj))))
+
     (define parse json->obj->json->obj)
 
     (define i_number_double_huge_neg_exp.json
@@ -1348,4 +1363,24 @@
     (define y_structure_whitespace_array.json
       (check #() (parse "./files/y_structure_whitespace_array.json")))
 
+    ;; Scheme specific tests
+
+    (define n_+inf.0
+      (check-raise json-error? (obj->json-string +inf.0)))
+
+    (define n_-inf.0
+      (check-raise json-error? (obj->json-string -inf.0)))
+
+    (define n_complex
+      (check-raise json-error? (obj->json-string 3+14i)))
+
+    (define n_-nan.0
+      (check-raise json-error? (obj->json-string +nan.0)))
+
+    (define n_+nan.0
+      (check-raise json-error? (obj->json-string -nan.0)))
+
+    (define n_exact_not_integer
+      (check-raise json-error? (obj->json-string 314/100)))
+
     ))

srfi/json.scm

@@ -489,9 +489,13 @@
      ((eq? obj 'null) (void))
      ((boolean? obj) (void))
      ((string? obj) (void))
-     ((number? obj)
-      (when (= (abs obj) +inf.0)
-        (raise (make-json-error "Infinity is not a valid JSON number"))))
+     ((and (number? obj)
+           (not (infinite? obj))
+           (not (nan? obj))
+           (real? obj)
+           (or (and (exact? obj) (= (denominator obj) 1))
+               (inexact? obj)))
+      (void))
      ((vector? obj)
       (vector-for-each (lambda (obj) (raise-unless-valid? obj)) obj))
      ;; XXX: pair? instead of list? because it is faster.

srfi/json.sld

@@ -7,6 +7,7 @@
           json-write)
 
   (import (scheme base)
+          (scheme inexact)
           (scheme case-lambda)
           (scheme char)
           (scheme text)