[ create a new paste ] login | about

Project: programmingpraxis
Link: http://programmingpraxis.codepad.org/iq1vyzGY    [ raw code | fork ]

programmingpraxis - Scheme, pasted on Jul 11:
; json: parsing input

(define json-null (string->symbol "the-json-null-object"))
(define (json-null? obj) (eqv? json-null obj))

(define (read-json . args)
  (let ((port (if (pair? args) (car args) (current-input-port))))

    (define (eat char)
      (let ((c (peek-char port)))
        (if (eof-object? c)
            (error 'read-json "eat unexpected end of file")
            (if (char=? c char) (read-char port)
              (error 'read-json "eat unexpected character")))))

    (define (skip-white-space)
      (let ((c (peek-char port)))
        (if (and (not (eof-object? c)) (char-whitespace? c))
            (begin (eat c) (skip-white-space)))))

    (define (read-member)
      (skip-white-space)
      (let ((key (read-string)))
        (skip-white-space)
        (eat #\:)
        (skip-white-space)
        (let ((val (read-value)))
          (skip-white-space)
          (cons key val))))

    (define (read-object)
      (eat #\{)
      (skip-white-space)
      (let ((c (peek-char port)))
        (if (eof-object? c)
            (error 'read-json "read-object unexpected end of file")
            (if (char=? (peek-char port) #\})
                (begin (eat #\}) (list))
                (let loop ((xs (list (read-member))))
                  (skip-white-space)
                  (let ((c (peek-char port)))
                    (cond ((char=? c #\}) (reverse xs))
                          ((char=? c #\,)
                            (eat #\,)
                            (skip-white-space)
                            (loop (cons (read-member) xs)))
                          (else (error 'read-json "read-object syntax error")))))))))

    (define (read-array)
      (eat #\[)
      (skip-white-space)
      (let ((c (peek-char port)))
        (if (eof-object? c) (error 'read-json "read-array unexpected end of file")
          (if (char=? c #\]) (begin (eat #\]) (vector))
          (let loop ((xs (list (read-value))))
            (skip-white-space)
            (let ((c (peek-char port)))
              (cond ((eof-object? c)
                      (error 'read-json "read-array unexpected end of file"))
                    ((char=? c #\]) (list->vector (reverse xs)))
                    ((char=? c #\,)
                      (eat #\,)
                      (skip-white-space)
                      (loop (cons (read-value) xs)))
                    (else (error 'read-json "read-array syntax error")))))))))

    (define (read-escape)
      (let ((c (peek-char port)))
        (cond ((eof-object? c)
                (error 'read-json "read-escape unexpected end of file"))
              ((char=? c #\\)
                (eat #\\)
                (let ((c (peek-char port)))
                  (cond
                    ((eof-object? c)
                      (error 'read-json "read-escape unexpected end of file"))
                    ((char=? c #\") (read-char port) #\")
                    ((char=? c #\\) (read-char port) #\\)
                    ((char=? c #\/) (read-char port) #\/)
                    ((char=? c #\b) (read-char port) #\backspace)
                    ((char=? c #\f) (read-char port) #\page)
                    ((char=? c #\n) (read-char port) #\newline)
                    ((char=? c #\r) (read-char port) #\return)
                    ((char=? c #\t) (read-char port) #\tab)
                    ((char=? c #\u) (error 'read-json "unicode not supported"))
                    (else (error 'read-json "unrecognized escape sequence")))))
              (else (read-char port)))))

    (define (read-string)
      (eat #\")
      (let loop ((c (peek-char port)) (cs '()))
        (cond ((eof-object? c)
                (error 'read-json "read-string unexpected end of file"))
              ((char=? c #\")
                (eat c) (skip-white-space) (list->string (reverse cs)))
              (else (let ((c (read-escape)))
                      (loop (peek-char port) (cons c cs)))))))

    (define (read-number)
      (define (char->digit c) (- (char->integer c) 48))
      (let* ((sign (let ((c (peek-char port)))
                     (cond ((eof-object? c)
                             (error 'read-json "read-number unexpected end of file"))
                           ((char=? c #\-) (eat #\-)
                             (let ((c (read-char port)))
                               (if (and (not (eof-object? c)) (char-numeric? c)) -1
                                 (error 'read-json "read-number syntax error"))))
                           ((char-numeric? c) 1)
                           (else (error 'read-json "read-number syntax error")))))
             (numb (let loop ((c (peek-char port)) (n 0))
                     (cond ((eof-object? c) n)
                           ((char-numeric? c) (eat c)
                             (loop (peek-char port)
                                   (+ (* n 10) (char->digit c))))
                           (else n))))
             (frac (let ((c (peek-char port)))
                     (if (or (eof-object? c) (not (char=? c #\.))) 0
                       (begin (eat #\.)
                         (let ((c (peek-char port)))
                           (if (or (eof-object? c) (not (char-numeric? c)))
                               (error 'read-json "read-number syntax error")
                               (let loop ((c c) (tens 10) (n 0))
                                 (cond ((eof-object? c) n)
                                       ((char-numeric? c) (eat c)
                                         (loop (peek-char port) (* tens 10)
                                           (+ n (/ (char->digit c) tens))))
                                       (else n)))))))))
             (expo (let ((c (peek-char port)))
                     (if (or (eof-object? c) (not (char-ci=? c #\E))) 0
                       (begin (eat c)
                         (let* ((sign (let ((c (peek-char port)))
                                        (cond ((char=? c #\+) (eat c) 1)
                                              ((char=? c #\-) (eat c) -1)
                                              ((char-numeric? c) 1)
                                              (else (error 'read-json
                                                "read-number syntax error")))))
                                (numb (let loop ((c (peek-char port)) (n 0))
                                        (cond ((eof-object? c) n)
                                              ((char-numeric? c) (eat c)
                                                (loop (peek-char port)
                                                  (+ (* n 10) (char->digit c))))
                                              (else n)))))
                           (* sign numb)))))))

        (if (and (zero? frac) (zero? expo)) (* sign numb)
          (exact->inexact (* sign (+ numb frac) (expt 10 expo))))))

    (define (read-constant)
      (let loop ((c (peek-char port)) (cs '()))
        (if (and (not (eof-object? c)) (char-alphabetic? c))
            (begin (eat c) (loop (peek-char port) (cons c cs)))
            (let ((str (list->string (reverse cs))))
              (cond ((string=? str "true") (skip-white-space) #t)
                    ((string=? str "false") (skip-white-space) #f)
                    ((string=? str "null") (skip-white-space) json-null)
                    (else (error 'read-json "unrecognized constant")))))))

    (define (read-value)
      (skip-white-space)
      (let ((c (peek-char port)))
      (cond ((eof-object? c)
              (error 'read-json "read-value unexpected end of file"))
            ((char=? c #\{) (read-object))
            ((char=? c #\[) (read-array))
            ((char=? c #\") (read-string))
            ((or (char-numeric? c) (char=? c #\-)) (read-number))
            ((char-alphabetic? c) (read-constant))
            (else (error 'read-json "read-value syntax error")))))

    (if (eof-object? (peek-char port)) (read-char port) (read-value))))


Output:
No errors or program output.


Create a new paste based on this one


Comments: