blob: cc3e0c12a51738675208951272e18a38b9e0703f (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
(in-package #:json)
(defparameter number-literal
(let ((signed-digits
(comp ((sign (zero-or-one (unit (lambda (x) (or (char= x #\-)
(char= x #\+))))))
(natural (one-or-more (unit #'digit-char-p))))
(cons sign natural))))
(comp ((base (either signed-digits
(fail "Malformed number.")))
(dot (zero-or-one (unit (lambda (x) (char= x #\.)))))
(fraction (if dot
(either (one-or-more (unit #'digit-char-p))
(fail "Malformed fractional part."))
nothing))
(e (zero-or-one (unit (lambda (x) (or (char= x #\e)
(char= x #\E))))))
(exponent (if e
(either signed-digits
(fail "Malformed exponent part."))
nothing)))
(list 'number base fraction exponent))))
(defparameter string-literal
(comp ((_ (unit (lambda (x) (char= x #\"))))
(chars (zero-or-more (either (comp ((slash (unit (lambda (x) (char= x #\\))))
(escaped (unit))
(codepoints (if (and escaped (char= escaped #\u))
(comp ((cp0 (unit #'digit-char-p))
(cp1 (unit #'digit-char-p))
(cp2 (unit #'digit-char-p))
(cp3 (unit #'digit-char-p)))
(let ((str (make-string 4)))
(setf (char str 0) cp0)
(setf (char str 1) cp1)
(setf (char str 2) cp2)
(setf (char str 3) cp3)
str))
nothing)))
(case escaped
(#\n
#\Newline)
(#\t
#\Tab)
(#\u
codepoints)
(t escaped)))
(unit (lambda (x) (char/= x #\"))))))
(_ (unit (lambda (x) (char= x #\")))))
(list 'string chars)))
(defparameter whitespace
(comp ((_ (zero-or-more (unit (lambda (x) (or (char= x #\Space)
(char= x #\Newline)
(char= x #\Tab)))))))
nil))
(defparameter true-symbol
(comp ((_ (unit (lambda (x) (char= x #\t))))
(_ (unit (lambda (x) (char= x #\r))))
(_ (unit (lambda (x) (char= x #\u))))
(_ (unit (lambda (x) (char= x #\e)))))
'true))
(defparameter false-symbol
(comp ((_ (unit (lambda (x) (char= x #\f))))
(_ (unit (lambda (x) (char= x #\a))))
(_ (unit (lambda (x) (char= x #\l))))
(_ (unit (lambda (x) (char= x #\s))))
(_ (unit (lambda (x) (char= x #\e)))))
'false))
(defparameter null-symbol
(comp ((_ (unit (lambda (x) (char= x #\n))))
(_ (unit (lambda (x) (char= x #\u))))
(_ (unit (lambda (x) (char= x #\l))))
(_ (unit (lambda (x) (char= x #\l)))))
'null))
(defvar json-value)
(defparameter json-array
(comp ((_ (unit (lambda (x) (char= x #\[))))
(v0 (either json-value
whitespace))
(vn (if v0
(zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
(vi json-value))
vi))
nothing))
(_ (unit (lambda (x) (char= x #\])))))
(if vn
(list 'array (cons v0 vn))
(list 'array v0))))
(defparameter json-object
(let ((json-pair
(comp ((_ whitespace)
(k string-literal)
(_ whitespace)
(_ (unit (lambda (x) (char= x #\:))))
(v json-value))
(list 'pair k v))))
(comp ((_ (unit (lambda (x) (char= x #\{))))
(v0 (either json-pair
whitespace))
(vn (if v0
(zero-or-more (comp ((_ (unit (lambda (x) (char= #\,))))
(vi json-pair))
vi))
nothing))
(_ (unit (lambda (x) (char= x #\})))))
(if vn
(list 'object (cons v0 vn))
(list 'object v0)))))
(setf json-value
(comp ((_ whitespace)
(v (either number-literal
string-literal
json-array
json-object
true-symbol
false-symbol
null-symbol))
(_ whitespace))
v))
|
