diff --git a/srfi/json.scm b/srfi/json.scm index 497df4d..ff43e02 100644 --- a/srfi/json.scm +++ b/srfi/json.scm @@ -6,6 +6,14 @@ json-error? (reason json-error-reason)) +(define (written obj) + (call-with-port (open-output-string) + (lambda (out) (write obj out) (get-output-string out)))) + +(define (invalid-object-value obj) + (raise (make-json-error + (string-append "Invalid object value: " (written obj) ".")))) + (define (json-whitespace? char) (assume (char? char)) (case char @@ -192,7 +200,11 @@ (define (%read-error? x) - (and (error-object? x) (memq (exception-kind x) '(user read read-incomplete)) #t)) + (and (error-object? x) + (cond-expand + (chibi (memq (exception-kind x) '(user read read-incomplete))) + (else #f)) + #t)) (assume (procedure? callback)) (assume (and (textual-port? port) (input-port? port))) @@ -326,7 +338,7 @@ ;; continue! (lambda (obj) (read-object-maybe-continue callback obj k))))) - (else (raise (make-json-error "Invalid object value."))))) + (else (invalid-object-value obj)))) (define (read-object-colon callback obj k) (if (eq? obj 'colon) @@ -413,6 +425,13 @@ (case type ((json-structure) (case obj + ((object-open) + (lambda (type obj) + (read-object-maybe-key '() + type + obj + (lambda (value) + (return (cons (cons key value) out)))))) ((array-open) (lambda (type obj) (read-array '() @@ -424,14 +443,14 @@ type obj return)))))) - (else (raise (make-json-error "Invalid object value."))))) + (else (invalid-object-value obj)))) ((json-value) (let ((value obj)) (lambda (type obj) (read-object-maybe-key (cons (cons key value) out) type obj return)))) - (else (raise (make-json-error "Invalid object value"))))) + (else (invalid-object-value obj)))) (define (read-object-maybe-key out type obj return) (case type diff --git a/srfi/json.sld b/srfi/json.sld index c65e8b1..975ea31 100644 --- a/srfi/json.sld +++ b/srfi/json.sld @@ -3,6 +3,7 @@ (export json-null? json-error? json-stream-read + json-error-reason json-read json-write) @@ -10,10 +11,17 @@ (scheme case-lambda) (scheme char) (scheme text) + (scheme write) (check) (srfi 145) - (srfi 151) - (chibi ast) (chibi regexp)) + (cond-expand ((library (srfi 60)) + (import (only (srfi 60) arithmetic-shift bitwise-ior))) + ((library (srfi 151)) + (import (only (srfi 151) arithmetic-shift bitwise-ior)))) + + (cond-expand (chibi (import (only (chibi ast) exception-kind))) + (else)) + (include "json.scm"))