Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

- Switched from SIGNAL to closures for control passing. (Approximetly

  x4 performance boost. This will probably be higher on more
  complicated parsing routines.)

- Fix code typo README.
  • Loading branch information...
commit 77e5194e0b19873b0c976b1d6c535175d3eed131 1 parent 1d9f454
authored December 20, 2007

Showing 2 changed files with 85 additions and 79 deletions. Show diff stats Hide diff stats

  1. 4  README
  2. 160  meta-sexp.lisp
4  README
@@ -64,12 +64,12 @@ Here is another example demonstrating the usage of META symbol.
64 64
     (:return t))
65 65
 
66 66
   (in-wonderland?
67  
-   (create-parser-context :data "META-SEXP in Wonderland!"))
  67
+   (create-parser-context "META-SEXP in Wonderland!"))
68 68
   META-SEXP in Wonderland!
69 69
   ==> T
70 70
 
71 71
   (in-wonderland?
72  
-   (create-parser-context :data "META-SEXP in Fooland!"))
  72
+   (create-parser-context "META-SEXP in Fooland!"))
73 73
   META-SEXP in Wonderland!
74 74
   ==> NIL
75 75
 
160  meta-sexp.lisp
@@ -106,159 +106,159 @@
106 106
 
107 107
 ;;; Grammar Compiler
108 108
 
109  
-(define-condition parser-return ()
110  
-  ((value :initarg :value :accessor parser-return-value)))
111  
-
112  
-(defgeneric transform-grammar (ctx in-meta directive &optional args)
  109
+(defgeneric transform-grammar (ret ctx in-meta directive &optional args)
113 110
   (:documentation "META grammar transformation methods."))
114 111
 
115 112
 (defmethod transform-grammar
116  
-    (ctx (in-meta (eql t)) (directive character) &optional args)
  113
+    (ret ctx (in-meta (eql t)) (directive character) &optional args)
117 114
   "Transforms a character form."
118  
-  (declare (ignore args))
  115
+  (declare (ignore ret args))
119 116
   `(match-atom ,ctx ,directive))
120 117
 
121 118
 (defmethod transform-grammar
122  
-    (ctx (in-meta (eql t)) (directive string) &optional args)
  119
+    (ret ctx (in-meta (eql t)) (directive string) &optional args)
123 120
   "Transforms a string form."
124 121
   (declare (ignore args))
125 122
   (transform-grammar
126  
-   ctx t :checkpoint
  123
+   ret ctx t :checkpoint
127 124
    `((and
128 125
       ,@(mapcar
129  
-         #'(lambda (form) `(match-atom ,ctx ,form))
  126
+         (lambda (form) `(match-atom ,ctx ,form))
130 127
          (coerce directive 'list))
131 128
       ,directive))))
132 129
 
133  
-(defmethod transform-grammar (ctx in-meta directive &optional args)
  130
+(defmethod transform-grammar (ret ctx in-meta directive &optional args)
134 131
   "The most unspecific transformation method."
135 132
   (declare (ignore args))
136 133
   (cond
137 134
     ((and in-meta (consp directive) (keywordp (car directive)))
138  
-     (transform-grammar ctx t (car directive) (cdr directive)))
  135
+     (transform-grammar ret ctx t (car directive) (cdr directive)))
139 136
     ((and (not in-meta) (consp directive) (eql 'meta (car directive)))
140  
-     (transform-grammar ctx t :and (cdr directive)))
  137
+     (transform-grammar ret ctx t :and (cdr directive)))
141 138
     ((consp directive)
142  
-     (mapcar #'(lambda (form) (transform-grammar ctx nil form)) directive))
  139
+     (mapcar (lambda (form) (transform-grammar ret ctx nil form)) directive))
143 140
     (t directive)))
144 141
 
145 142
 (defmethod transform-grammar
146  
-    (ctx (in-meta (eql t)) (directive (eql :icase)) &optional args)
  143
+    (ret ctx (in-meta (eql t)) (directive (eql :icase)) &optional args)
147 144
   "\(:ICASE FORM FORM ...)
148 145
 
149 146
 Make case-insensitive atom comparison in supplied FORMs."
150  
-  (with-unique-names (ret)
  147
+  (with-unique-names (wrapper-ret val)
151 148
     `(progn
152 149
        (push t (parser-context-icases ,ctx))
153  
-       (let ((,ret
154  
-              (handler-case ,(transform-grammar ctx t :and args)
155  
-                (parser-return (data)
156  
-                  (pop (parser-context-icases ,ctx))
157  
-                  (signal 'parser-return
158  
-                          :value (parser-return-value data))))))
159  
-         (pop (parser-context-icases ,ctx))
160  
-         ,ret))))
  150
+       (let ((,wrapper-ret
  151
+              (lambda (,val)
  152
+                (pop (parser-context-icases ,ctx))
  153
+                (funcall ,ret ,val))))
  154
+         (declare (ignorable ,wrapper-ret))
  155
+         (let ((,val ,(transform-grammar wrapper-ret ctx t :and args)))
  156
+           (pop (parser-context-icases ,ctx))
  157
+           ,val)))))
161 158
 
162 159
 (defmethod transform-grammar
163  
-    (ctx (in-meta (eql t)) (directive (eql :checkpoint)) &optional args)
  160
+    (ret ctx (in-meta (eql t)) (directive (eql :checkpoint)) &optional args)
164 161
   "\(:CHECKPOINT FORM FORM ...)
165 162
 
166 163
 Sequentially evaluates supplied forms and if any of them fails, moves cursor
167 164
 back to its start position :CHECKPOINT began."
168  
-  (with-unique-names (ret)
  165
+  (with-unique-names (wrapper-ret val)
169 166
     `(progn
170 167
        (checkpoint ,ctx)
171  
-       (let ((,ret
172  
-              (handler-case ,(transform-grammar ctx t :and args)
173  
-                (parser-return (data)
174  
-                  (let ((value (parser-return-value data)))
175  
-                    (if value
176  
-                        (commit ,ctx)
177  
-                        (rollback ,ctx))
178  
-                    (signal 'parser-return :value value))))))
179  
-         (if ,ret
180  
-             (commit ,ctx)
181  
-             (rollback ,ctx))
182  
-         ,ret))))
  168
+       (let ((,wrapper-ret
  169
+              (lambda (,val)
  170
+                (if ,val
  171
+                    (commit ,ctx)
  172
+                    (rollback ,ctx))
  173
+                (funcall ,ret ,val))))
  174
+         (declare (ignorable ,wrapper-ret))
  175
+         (let ((,val ,(transform-grammar wrapper-ret ctx t :and args)))
  176
+           (if ,val
  177
+               (commit ,ctx)
  178
+               (rollback ,ctx))
  179
+           ,val)))))
183 180
 
184 181
 (defmethod transform-grammar
185  
-    (ctx (in-meta (eql t)) (directive (eql :and)) &optional args)
  182
+    (ret ctx (in-meta (eql t)) (directive (eql :and)) &optional args)
186 183
   "\(:AND FORM FORM ...)
187 184
 
188 185
 Sequentially evaluates FORMs identical to AND."
189  
-  `(and ,@(mapcar #'(lambda (form) (transform-grammar ctx t form)) args)))
  186
+  `(and ,@(mapcar (lambda (form) (transform-grammar ret ctx t form)) args)))
190 187
 
191 188
 (defmethod transform-grammar
192  
-    (ctx (in-meta (eql t)) (directive (eql :or)) &optional args)
  189
+    (ret ctx (in-meta (eql t)) (directive (eql :or)) &optional args)
193 190
   "\(:OR FORM FORM ...)
194 191
 
195 192
 Sequentially evalutes FORMs identical to OR."
196  
-  `(or ,@(mapcar #'(lambda (form) (transform-grammar ctx t form)) args)))
  193
+  `(or ,@(mapcar (lambda (form) (transform-grammar ret ctx t form)) args)))
197 194
 
198 195
 (defmethod transform-grammar
199  
-    (ctx (in-meta (eql t)) (directive (eql :not)) &optional args)
  196
+    (ret ctx (in-meta (eql t)) (directive (eql :not)) &optional args)
200 197
   "\(:NOT FORM)
201 198
 
202 199
 Identical to \(NOT FORM). \(FORM is encapsulated within a :CHECKPOINT before
203 200
 getting evaluated.)"
204 201
   (transform-grammar
205  
-   ctx t :checkpoint
206  
-   `((not ,(transform-grammar ctx t (car args))))))
  202
+   ret ctx t :checkpoint
  203
+   `((not ,(transform-grammar ret ctx t (car args))))))
207 204
 
208 205
 (defmethod transform-grammar
209  
-    (ctx (in-meta (eql t)) (directive (eql :return)) &optional args)
  206
+    (ret ctx (in-meta (eql t)) (directive (eql :return)) &optional args)
210 207
   "\(:RETURN VALUE VALUE ...)
211 208
 
212 209
 Returns from the rule with supplied VALUEs."
213  
-  `(signal 'parser-return :value (list ,@args)))
  210
+  (declare (ignore ctx))
  211
+  `(funcall ,ret (list ,@args)))
214 212
 
215 213
 (defmethod transform-grammar
216  
-    (ctx (in-meta (eql t)) (directive (eql :render)) &optional args)
  214
+    (ret ctx (in-meta (eql t)) (directive (eql :render)) &optional args)
217 215
   "\(:RENDER RENDERER ARG ARG ...)
218 216
 
219 217
 Calls specified renderer \(which is defined with DEFRENDERER) with the supplied
220 218
 arguments."
  219
+  (declare (ignore ret))
221 220
   `(,(car args) ,@(nconc (list ctx) (cdr args))))
222 221
 
223 222
 (defmethod transform-grammar
224  
-    (ctx (in-meta (eql t)) (directive (eql :?)) &optional args)
  223
+    (ret ctx (in-meta (eql t)) (directive (eql :?)) &optional args)
225 224
   "\(:? FORM FORM ...)
226 225
 
227 226
 Sequentially evaluates supplied FORMs within an AND scope and regardless of the
228 227
 return value of ANDed FORMs, block returns T. \(Similar to `?' in regular
229 228
 expressions.)"
230 229
   `(prog1 t (and ,@(mapcar
231  
-                    #'(lambda (form) (transform-grammar ctx t form))
  230
+                    (lambda (form) (transform-grammar ret ctx t form))
232 231
                     args))))
233 232
 
234 233
 (defmethod transform-grammar
235  
-    (ctx (in-meta (eql t)) (directive (eql :*)) &optional args)
  234
+    (ret ctx (in-meta (eql t)) (directive (eql :*)) &optional args)
236 235
   "\(:* FORM FORM ...)
237 236
 
238 237
 Sequentially evaluates supplied FORMs within an AND scope until it returns
239 238
 NIL. Regardless of the return value of ANDed FORMs, block returns T. \(Similar
240 239
 to `*' in regular expressions.)"
241  
-  `(not (do () ((not ,(transform-grammar ctx t :and args))))))
  240
+  `(not (do () ((not ,(transform-grammar ret ctx t :and args))))))
242 241
 
243 242
 (defmethod transform-grammar
244  
-    (ctx (in-meta (eql t)) (directive (eql :+)) &optional args)
  243
+    (ret ctx (in-meta (eql t)) (directive (eql :+)) &optional args)
245 244
   "\(:+ FORM FORM ...)
246 245
 
247 246
 Sequentially evaluates supplied FORMs within an AND scope, and repeats this
248 247
 process till FORMs return NIL. Scope returns T if FORMs returned T once or more,
249 248
 otherwise returns NIL. \(Similar to `{1,}' in regular expressions.)"
250  
-  (transform-grammar ctx t :and `(,@args (:* ,@args))))
  249
+  (transform-grammar ret ctx t :and `(,@args (:* ,@args))))
251 250
 
252 251
 (defmethod transform-grammar
253  
-    (ctx (in-meta (eql t)) (directive (eql :type)) &optional args)
  252
+    (ret ctx (in-meta (eql t)) (directive (eql :type)) &optional args)
254 253
   "\(:TYPE TYPE-CHECKER)
255 254
 \(:TYPE \(OR TYPE-CHECKER TYPE-CHECKER ...))
256 255
 
257 256
 Checks type of the atom at the current position through supplied function(s)."
  257
+  (declare (ignore ret))
258 258
   `(match-type ,ctx ,(car args)))
259 259
 
260 260
 (defmethod transform-grammar
261  
-    (ctx (in-meta (eql t)) (directive (eql :rule)) &optional args)
  261
+    (ret ctx (in-meta (eql t)) (directive (eql :rule)) &optional args)
262 262
   "\(:RULE RULE ARG ARG ...)
263 263
 \(:RULE (OR RULE RULE ...) ARG ARG ...)
264 264
 
@@ -266,78 +266,84 @@ Tests input in the current cursor position using specified type/form. If any,
266 266
 supplied arguments will get passed to rule."
267 267
   (if (and (consp (car args)) (eql 'or (caar args)))
268 268
       (transform-grammar
269  
-       ctx t :or (mapcar #'(lambda (form) `(:rule ,form ,@(cdr args)))
270  
-                         (cdar args)))
  269
+       ret ctx t :or (mapcar (lambda (form) `(:rule ,form ,@(cdr args)))
  270
+                             (cdar args)))
271 271
       `(match-rule ,ctx ,(car args) ,(cdr args))))
272 272
 
273 273
 (defmethod transform-grammar
274  
-    (ctx (in-meta (eql t)) (directive (eql :assign)) &optional args)
  274
+    (ret ctx (in-meta (eql t)) (directive (eql :assign)) &optional args)
275 275
   "\(:ASSIGN VAR FORM)
276 276
 \(:ASSIGN \(VAR1 VAR2 ...) FORM)
277 277
 
278 278
 Assigns returned value of FORM to VAR, and returns assigned value. \(Latter form
279 279
 works similar to MULTIPLE-VALUE-SETQ.)"
280 280
   (if (consp (car args))
281  
-      `(multiple-value-setq ,(car args) ,(transform-grammar ctx t (cadr args)))
282  
-      `(setq ,(car args) ,(transform-grammar ctx t (cadr args)))))
  281
+      `(multiple-value-setq ,(car args)
  282
+         ,(transform-grammar ret ctx t (cadr args)))
  283
+      `(setq ,(car args) ,(transform-grammar ret ctx t (cadr args)))))
283 284
 
284 285
 (defmethod transform-grammar
285  
-    (ctx (in-meta (eql t)) (directive (eql :list-push)) &optional args)
  286
+    (ret ctx (in-meta (eql t)) (directive (eql :list-push)) &optional args)
286 287
   "\(:LIST-PUSH ITEM-VAR LIST-ACCUM)
287 288
 
288 289
 Pushes ITEM-VAR into the specified LIST-ACCUM. (See MAKE-LIST-ACCUM and
289 290
 EMPTY-LIST-ACCUM-P.)"
  291
+  (declare (ignore ret ctx))
290 292
   `(list-accum-push ,(car args) ,(cadr args)))
291 293
 
292 294
 (defmethod transform-grammar
293  
-    (ctx (in-meta (eql t)) (directive (eql :list-reset)) &optional args)
  295
+    (ret ctx (in-meta (eql t)) (directive (eql :list-reset)) &optional args)
294 296
   "\(:LIST-RESET LIST-ACCUM)
295 297
 
296 298
 Resets supplied LIST-ACCUM."
  299
+  (declare (ignore ret ctx))
297 300
   `(reset-list-accum ,(car args)))
298 301
 
299 302
 (defmethod transform-grammar
300  
-    (ctx (in-meta (eql t)) (directive (eql :char-push)) &optional args)
  303
+    (ret ctx (in-meta (eql t)) (directive (eql :char-push)) &optional args)
301 304
   "\(:CHAR-PUSH CHAR-VAR CHAR-ACCUM)
302 305
 \(:CHAR-PUSH CHAR-ACCUM)
303 306
 
304 307
 Pushes supplied CHAR-VAR into specified CHAR-ACCUM. If called with
305 308
 a single argument, current character gets read and pushed into supplied
306 309
 accumulator. (See MAKE-CHAR-ACCUM and EMPTY-CHAR-ACCUM-P.)"
  310
+  (declare (ignore ret))
307 311
   (if (cdr args)
308 312
       `(char-accum-push ,(car args) ,(cadr args))
309 313
       `(char-accum-push (read-atom ,ctx) ,(car args))))
310 314
 
311 315
 (defmethod transform-grammar
312  
-    (ctx (in-meta (eql t)) (directive (eql :char-reset)) &optional args)
  316
+    (ret ctx (in-meta (eql t)) (directive (eql :char-reset)) &optional args)
313 317
   "\(:CHAR-RESET CHAR-ACCUM)
314 318
 
315 319
 Resets supplied CHAR-ACCUM."
  320
+  (declare (ignore ret ctx))
316 321
   `(reset-char-accum ,(car args)))
317 322
 
318 323
 (defmethod transform-grammar
319  
-    (ctx (in-meta (eql t)) (directive (eql :eof)) &optional args)
  324
+    (ret ctx (in-meta (eql t)) (directive (eql :eof)) &optional args)
320 325
   "\(:EOF)
321 326
 
322 327
 Returns T when reached to the end of supplied input data."
323  
-  (declare (ignore args))
  328
+  (declare (ignore ret args))
324 329
   `(= (parser-context-cursor ,ctx) (parser-context-size ,ctx)))
325 330
 
326 331
 (defmethod transform-grammar
327  
-    (ctx (in-meta (eql t)) (directive (eql :read-atom)) &optional args)
  332
+    (ret ctx (in-meta (eql t)) (directive (eql :read-atom)) &optional args)
328 333
   "\(:READ-ATOM)
329 334
 
330 335
 Reads current atom at the cursor position and returns read atom."
331  
-  (declare (ignore args))
  336
+  (declare (ignore ret args))
332 337
   `(read-atom ,ctx))
333 338
 
334 339
 (defmethod transform-grammar
335  
-    (ctx (in-meta (eql t)) (directive (eql :debug)) &optional args)
  340
+    (ret ctx (in-meta (eql t)) (directive (eql :debug)) &optional args)
336 341
   "\(:DEBUG)
337 342
 \(:DEBUG VAR)
338 343
 
339 344
 Print current character and its position in the input data. If VAR is specified,
340 345
 print the value of the VAR."
  346
+  (declare (ignore ret))
341 347
   `(prog1 t
342 348
      ,(if (car args)
343 349
           `(format t "DEBUG: ~s: ~a~%" ',(car args) ,(car args))
@@ -356,15 +362,15 @@ print the value of the VAR."
356 362
      (deftype ,name () `(satisfies ,',name))))
357 363
 
358 364
 (defmacro defrule (name (&rest args) (&optional attachment) &body body)
359  
-  (with-unique-names (ctx)
  365
+  (with-unique-names (ctx ret val)
360 366
     `(defun ,name (,ctx ,@args)
361  
-       (handler-case
362  
-           ,(if attachment
363  
-                `(let ((,attachment (parser-context-attachment ,ctx)))
364  
-                   ,(transform-grammar ctx t :checkpoint body))
365  
-                (transform-grammar ctx t :checkpoint body))
366  
-         (parser-return (data)
367  
-           (return-from ,name (apply #'values (parser-return-value data))))))))
  367
+       (let ((,ret
  368
+              (lambda (,val)
  369
+                (return-from ,name (apply #'values ,val)))))
  370
+         ,(if attachment
  371
+              `(let ((,attachment (parser-context-attachment ,ctx)))
  372
+                 ,(transform-grammar ret ctx t :checkpoint body))
  373
+              (transform-grammar ret ctx t :checkpoint body))))))
368 374
 
369 375
 (defmacro defrenderer (name (&rest args) (&optional attachment) &body body)
370 376
   (with-unique-names (ctx)

0 notes on commit 77e5194

Please sign in to comment.
Something went wrong with that request. Please try again.