-
Notifications
You must be signed in to change notification settings - Fork 4
/
meta-sexp.lisp
252 lines (209 loc) · 8.46 KB
/
meta-sexp.lisp
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
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
;;; Copyright (c) 2007, Volkan YAZICI <yazicivo@ttnet.net.tr>
;;; All rights reserved.
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;; - Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;; - Redistributions in binary form must reproduce the above
;;; copyright notice, this list of conditions and the following
;;; disclaimer in the documentation and/or other materials provided
;;; with the distribution.
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR
;;; TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF
;;; THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
;;; SUCH DAMAGE.
(in-package :meta-sexp)
;;; Parser Context Class & Routines
(defclass parser-context ()
((data
:initarg :data
:accessor parser-context-data
:documentation "Input data getting parsed.")
(size
:initarg :size
:initform nil
:documentation "Size of the input data.")
(cursor
:initarg :cursor
:initform 0
:accessor parser-context-cursor
:documentation "Current location on the input data.")
(checkpoints
:initform nil
:accessor parser-context-checkpoints
:documentation "Reversed list of declared checkpoints.")
(attachment
:initarg :attachment
:initform nil
:accessor parser-context-attachment
:documentation "Attachment to carry with to parser context object."))
(:documentation "Information about current state of the parsing process."))
(defgeneric parser-context-size (ctx))
(defmethod parser-context-size ((ctx parser-context))
(or (slot-value ctx 'size)
(setf (slot-value ctx 'size)
(length (parser-context-data ctx)))))
(defgeneric create-parser-context (input &rest args))
(defmethod create-parser-context ((input string) &key start end attachment)
(make-instance 'parser-context
:data input
:size end
:cursor (or start 0)
:attachment attachment))
(defmethod create-parser-context
((input string-stream) &key buffer-size start end attachment)
(assert (input-stream-p input))
(let* (size
(string
(with-output-to-string (output)
(loop with buffer-size = (or buffer-size 8192)
with buf = (make-string buffer-size)
for pos = (read-sequence buf input :end buffer-size)
sum pos into size-acc
until (zerop pos)
do (write-string buf output :end pos)
finally (setq size size-acc)))))
(create-parser-context
string :start start :end (or end size) :attachment attachment)))
(defgeneric peek-atom (ctx))
(defgeneric read-atom (ctx))
(defgeneric checkpoint (ctx))
(defgeneric rollback (ctx))
(defgeneric commit (ctx))
(define-condition parser-context-error ()
((operation :initarg :operation :accessor parser-context-error-operation)))
(defmethod peek-atom ((ctx parser-context))
(if (< (parser-context-cursor ctx) (parser-context-size ctx))
(elt (parser-context-data ctx) (parser-context-cursor ctx))))
(defmethod read-atom ((ctx parser-context))
(when (< (parser-context-cursor ctx) (parser-context-size ctx))
(incf (parser-context-cursor ctx))
(elt (parser-context-data ctx) (1- (parser-context-cursor ctx)))))
(defmethod checkpoint ((ctx parser-context))
(push (parser-context-cursor ctx) (parser-context-checkpoints ctx)))
(defmethod rollback ((ctx parser-context))
(let ((prev-pos (pop (parser-context-checkpoints ctx))))
(if prev-pos
(setf (parser-context-cursor ctx) prev-pos)
(error 'parser-context-error :operation 'rollback))))
(defmethod commit ((ctx parser-context))
(if (not (pop (parser-context-checkpoints ctx)))
(error 'parser-context-error :operation 'commit)))
;;; Atom, Rule & Type Matching
(defun match-atom (ctx atom &aux (c (peek-atom ctx)))
(if (and c (char= atom c))
(read-atom ctx)))
(defmacro match-type (ctx type)
`(if (typep (peek-atom ,ctx) ',type)
(read-atom ,ctx)))
(defmacro match-rule (ctx rule args)
`(,rule ,@(nconc (list ctx) args)))
;;; Accumulators
(defun make-char-accum (&key (size 512))
(make-array size :element-type 'character :adjustable t :fill-pointer 0))
(defun char-accum-push (char accum)
(if (typep char 'character)
(vector-push-extend char accum)))
(defun reset-char-accum (accum)
(setf (fill-pointer accum) 0))
(defun empty-char-accum-p (accum)
(zerop (fill-pointer accum)))
(defun make-list-accum ()
nil)
(defmacro list-accum-push (item accum)
`(push ,item ,accum))
(defmacro reset-list-accum (accum)
`(setf ,accum nil))
(defun empty-list-accum-p (accum)
(endp accum))
;;; Grammar Compiler
(defun compile-grammar (ctx form)
(labels ((compile-exprs (form &optional (in-meta t))
(mapcar #'(lambda (form) (compile-expr form in-meta)) form))
(compile-expr (form &optional (in-meta t))
(if in-meta
(cond
((and (consp form) (keywordp (car form)))
(ecase (car form)
(:checkpoint
(with-gensyms (ret)
`(progn
(checkpoint ,ctx)
(let ((,ret ,(compile-expr (cadr form))))
(if ,ret
(commit ,ctx)
(rollback ,ctx))
,ret))))
(:and `(and ,@(compile-exprs (cdr form))))
(:or `(or ,@(compile-exprs (cdr form))))
(:not (compile-expr `(:checkpoint (not ,(compile-expr (cadr form))))))
(:return `(return-from rule-block (values ,@(cdr form))))
(:render `(,(cadr form) ,@(nconc (list ctx) (cddr form))))
(:? `(prog1 t ,(compile-expr `(:and ,@(cdr form)))))
(:* `(not (do () ((not ,(compile-expr `(:and ,@(cdr form))))))))
(:+ (compile-expr `(:and ,@(cdr form) (:* ,@(cdr form)))))
(:type `(match-type ,ctx ,(cadr form)))
(:rule
(if (and (consp (cadr form))
(eql 'or (caadr form)))
(compile-expr
`(:or ,@(mapcar #'(lambda (form) `(:rule ,form)) (cdadr form))))
`(match-rule ,ctx ,(cadr form) ,(cddr form))))
(:assign `(setq ,(cadr form) ,(compile-expr (caddr form))))
(:list-push `(list-accum-push ,(cadr form) ,(caddr form)))
(:list-reset `(reset-list-accum ,(cadr form)))
(:char-push
(if (cddr form)
`(char-accum-push ,(cadr form) ,(caddr form))
`(char-accum-push (read-atom ,ctx) ,(cadr form))))
(:char-reset `(reset-char-accum ,(cadr form)))
(:read-atom `(read-atom ,ctx))
(:debug
`(prog1 t
,(if (cadr form)
`(format t "DEBUG: ~a: ~a~%" ',(cadr form) ,(cadr form))
`(format t "DEBUG: cursor: [~a] `~a'~%"
(parser-context-cursor ,ctx)
(elt (parser-context-data ,ctx)
(parser-context-cursor ,ctx))))))))
((characterp form) `(match-atom ,ctx ,form))
((stringp form) (compile-expr `(:checkpoint (:and ,@(coerce form 'list)))))
(t (compile-expr form nil)))
(cond
((and (consp form) (eql 'meta (car form)))
(format t "will get compiled: ~a~%" `(:and ,@(cdr form)))
(compile-expr `(:and ,@(cdr form))))
((consp form) (compile-exprs form nil))
(t form)))))
(compile-expr form)))
;;; Atom, Rule & Renderer Definition Macros
(defmacro defatom (name &body body)
`(progn
(defun ,name (c) (when c ,@body))
(deftype ,name () `(satisfies ,',name))))
(defmacro destructure-attachment ((ctx lambda-list) &body body)
(if lambda-list
`(destructuring-bind ,lambda-list (parser-context-attachment ,ctx)
,@body)
`(progn ,@body)))
(defmacro defrule (name (&rest args) (&rest attachment-lambda-list) &body body)
(with-gensyms (ctx)
`(defun ,name ,(nconc (list ctx) args)
(destructure-attachment (,ctx ,attachment-lambda-list)
(block rule-block
,(compile-grammar ctx `(:checkpoint (:and ,@body))))))))
(defmacro defrenderer (name (&rest args) (&rest attachment-lambda-list) &body body)
(with-gensyms (ctx)
`(defun ,name ,(nconc (list ctx) args)
(destructure-attachment (,ctx ,attachment-lambda-list) ,@body)
t)))