Permalink
Browse files

- 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...
1 parent 1d9f454 commit 77e5194e0b19873b0c976b1d6c535175d3eed131 Volkan YAZICI committed Dec 20, 2007
Showing with 85 additions and 79 deletions.
  1. +2 −2 README
  2. +83 −77 meta-sexp.lisp
View
4 README
@@ -64,12 +64,12 @@ Here is another example demonstrating the usage of META symbol.
(:return t))
(in-wonderland?
- (create-parser-context :data "META-SEXP in Wonderland!"))
+ (create-parser-context "META-SEXP in Wonderland!"))
META-SEXP in Wonderland!
==> T
(in-wonderland?
- (create-parser-context :data "META-SEXP in Fooland!"))
+ (create-parser-context "META-SEXP in Fooland!"))
META-SEXP in Wonderland!
==> NIL
View
160 meta-sexp.lisp
@@ -106,238 +106,244 @@
;;; Grammar Compiler
-(define-condition parser-return ()
- ((value :initarg :value :accessor parser-return-value)))
-
-(defgeneric transform-grammar (ctx in-meta directive &optional args)
+(defgeneric transform-grammar (ret ctx in-meta directive &optional args)
(:documentation "META grammar transformation methods."))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive character) &optional args)
+ (ret ctx (in-meta (eql t)) (directive character) &optional args)
"Transforms a character form."
- (declare (ignore args))
+ (declare (ignore ret args))
`(match-atom ,ctx ,directive))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive string) &optional args)
+ (ret ctx (in-meta (eql t)) (directive string) &optional args)
"Transforms a string form."
(declare (ignore args))
(transform-grammar
- ctx t :checkpoint
+ ret ctx t :checkpoint
`((and
,@(mapcar
- #'(lambda (form) `(match-atom ,ctx ,form))
+ (lambda (form) `(match-atom ,ctx ,form))
(coerce directive 'list))
,directive))))
-(defmethod transform-grammar (ctx in-meta directive &optional args)
+(defmethod transform-grammar (ret ctx in-meta directive &optional args)
"The most unspecific transformation method."
(declare (ignore args))
(cond
((and in-meta (consp directive) (keywordp (car directive)))
- (transform-grammar ctx t (car directive) (cdr directive)))
+ (transform-grammar ret ctx t (car directive) (cdr directive)))
((and (not in-meta) (consp directive) (eql 'meta (car directive)))
- (transform-grammar ctx t :and (cdr directive)))
+ (transform-grammar ret ctx t :and (cdr directive)))
((consp directive)
- (mapcar #'(lambda (form) (transform-grammar ctx nil form)) directive))
+ (mapcar (lambda (form) (transform-grammar ret ctx nil form)) directive))
(t directive)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :icase)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :icase)) &optional args)
"\(:ICASE FORM FORM ...)
Make case-insensitive atom comparison in supplied FORMs."
- (with-unique-names (ret)
+ (with-unique-names (wrapper-ret val)
`(progn
(push t (parser-context-icases ,ctx))
- (let ((,ret
- (handler-case ,(transform-grammar ctx t :and args)
- (parser-return (data)
- (pop (parser-context-icases ,ctx))
- (signal 'parser-return
- :value (parser-return-value data))))))
- (pop (parser-context-icases ,ctx))
- ,ret))))
+ (let ((,wrapper-ret
+ (lambda (,val)
+ (pop (parser-context-icases ,ctx))
+ (funcall ,ret ,val))))
+ (declare (ignorable ,wrapper-ret))
+ (let ((,val ,(transform-grammar wrapper-ret ctx t :and args)))
+ (pop (parser-context-icases ,ctx))
+ ,val)))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :checkpoint)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :checkpoint)) &optional args)
"\(:CHECKPOINT FORM FORM ...)
Sequentially evaluates supplied forms and if any of them fails, moves cursor
back to its start position :CHECKPOINT began."
- (with-unique-names (ret)
+ (with-unique-names (wrapper-ret val)
`(progn
(checkpoint ,ctx)
- (let ((,ret
- (handler-case ,(transform-grammar ctx t :and args)
- (parser-return (data)
- (let ((value (parser-return-value data)))
- (if value
- (commit ,ctx)
- (rollback ,ctx))
- (signal 'parser-return :value value))))))
- (if ,ret
- (commit ,ctx)
- (rollback ,ctx))
- ,ret))))
+ (let ((,wrapper-ret
+ (lambda (,val)
+ (if ,val
+ (commit ,ctx)
+ (rollback ,ctx))
+ (funcall ,ret ,val))))
+ (declare (ignorable ,wrapper-ret))
+ (let ((,val ,(transform-grammar wrapper-ret ctx t :and args)))
+ (if ,val
+ (commit ,ctx)
+ (rollback ,ctx))
+ ,val)))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :and)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :and)) &optional args)
"\(:AND FORM FORM ...)
Sequentially evaluates FORMs identical to AND."
- `(and ,@(mapcar #'(lambda (form) (transform-grammar ctx t form)) args)))
+ `(and ,@(mapcar (lambda (form) (transform-grammar ret ctx t form)) args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :or)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :or)) &optional args)
"\(:OR FORM FORM ...)
Sequentially evalutes FORMs identical to OR."
- `(or ,@(mapcar #'(lambda (form) (transform-grammar ctx t form)) args)))
+ `(or ,@(mapcar (lambda (form) (transform-grammar ret ctx t form)) args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :not)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :not)) &optional args)
"\(:NOT FORM)
Identical to \(NOT FORM). \(FORM is encapsulated within a :CHECKPOINT before
getting evaluated.)"
(transform-grammar
- ctx t :checkpoint
- `((not ,(transform-grammar ctx t (car args))))))
+ ret ctx t :checkpoint
+ `((not ,(transform-grammar ret ctx t (car args))))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :return)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :return)) &optional args)
"\(:RETURN VALUE VALUE ...)
Returns from the rule with supplied VALUEs."
- `(signal 'parser-return :value (list ,@args)))
+ (declare (ignore ctx))
+ `(funcall ,ret (list ,@args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :render)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :render)) &optional args)
"\(:RENDER RENDERER ARG ARG ...)
Calls specified renderer \(which is defined with DEFRENDERER) with the supplied
arguments."
+ (declare (ignore ret))
`(,(car args) ,@(nconc (list ctx) (cdr args))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :?)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :?)) &optional args)
"\(:? FORM FORM ...)
Sequentially evaluates supplied FORMs within an AND scope and regardless of the
return value of ANDed FORMs, block returns T. \(Similar to `?' in regular
expressions.)"
`(prog1 t (and ,@(mapcar
- #'(lambda (form) (transform-grammar ctx t form))
+ (lambda (form) (transform-grammar ret ctx t form))
args))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :*)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :*)) &optional args)
"\(:* FORM FORM ...)
Sequentially evaluates supplied FORMs within an AND scope until it returns
NIL. Regardless of the return value of ANDed FORMs, block returns T. \(Similar
to `*' in regular expressions.)"
- `(not (do () ((not ,(transform-grammar ctx t :and args))))))
+ `(not (do () ((not ,(transform-grammar ret ctx t :and args))))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :+)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :+)) &optional args)
"\(:+ FORM FORM ...)
Sequentially evaluates supplied FORMs within an AND scope, and repeats this
process till FORMs return NIL. Scope returns T if FORMs returned T once or more,
otherwise returns NIL. \(Similar to `{1,}' in regular expressions.)"
- (transform-grammar ctx t :and `(,@args (:* ,@args))))
+ (transform-grammar ret ctx t :and `(,@args (:* ,@args))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :type)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :type)) &optional args)
"\(:TYPE TYPE-CHECKER)
\(:TYPE \(OR TYPE-CHECKER TYPE-CHECKER ...))
Checks type of the atom at the current position through supplied function(s)."
+ (declare (ignore ret))
`(match-type ,ctx ,(car args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :rule)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :rule)) &optional args)
"\(:RULE RULE ARG ARG ...)
\(:RULE (OR RULE RULE ...) ARG ARG ...)
Tests input in the current cursor position using specified type/form. If any,
supplied arguments will get passed to rule."
(if (and (consp (car args)) (eql 'or (caar args)))
(transform-grammar
- ctx t :or (mapcar #'(lambda (form) `(:rule ,form ,@(cdr args)))
- (cdar args)))
+ ret ctx t :or (mapcar (lambda (form) `(:rule ,form ,@(cdr args)))
+ (cdar args)))
`(match-rule ,ctx ,(car args) ,(cdr args))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :assign)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :assign)) &optional args)
"\(:ASSIGN VAR FORM)
\(:ASSIGN \(VAR1 VAR2 ...) FORM)
Assigns returned value of FORM to VAR, and returns assigned value. \(Latter form
works similar to MULTIPLE-VALUE-SETQ.)"
(if (consp (car args))
- `(multiple-value-setq ,(car args) ,(transform-grammar ctx t (cadr args)))
- `(setq ,(car args) ,(transform-grammar ctx t (cadr args)))))
+ `(multiple-value-setq ,(car args)
+ ,(transform-grammar ret ctx t (cadr args)))
+ `(setq ,(car args) ,(transform-grammar ret ctx t (cadr args)))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :list-push)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :list-push)) &optional args)
"\(:LIST-PUSH ITEM-VAR LIST-ACCUM)
Pushes ITEM-VAR into the specified LIST-ACCUM. (See MAKE-LIST-ACCUM and
EMPTY-LIST-ACCUM-P.)"
+ (declare (ignore ret ctx))
`(list-accum-push ,(car args) ,(cadr args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :list-reset)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :list-reset)) &optional args)
"\(:LIST-RESET LIST-ACCUM)
Resets supplied LIST-ACCUM."
+ (declare (ignore ret ctx))
`(reset-list-accum ,(car args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :char-push)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :char-push)) &optional args)
"\(:CHAR-PUSH CHAR-VAR CHAR-ACCUM)
\(:CHAR-PUSH CHAR-ACCUM)
Pushes supplied CHAR-VAR into specified CHAR-ACCUM. If called with
a single argument, current character gets read and pushed into supplied
accumulator. (See MAKE-CHAR-ACCUM and EMPTY-CHAR-ACCUM-P.)"
+ (declare (ignore ret))
(if (cdr args)
`(char-accum-push ,(car args) ,(cadr args))
`(char-accum-push (read-atom ,ctx) ,(car args))))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :char-reset)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :char-reset)) &optional args)
"\(:CHAR-RESET CHAR-ACCUM)
Resets supplied CHAR-ACCUM."
+ (declare (ignore ret ctx))
`(reset-char-accum ,(car args)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :eof)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :eof)) &optional args)
"\(:EOF)
Returns T when reached to the end of supplied input data."
- (declare (ignore args))
+ (declare (ignore ret args))
`(= (parser-context-cursor ,ctx) (parser-context-size ,ctx)))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :read-atom)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :read-atom)) &optional args)
"\(:READ-ATOM)
Reads current atom at the cursor position and returns read atom."
- (declare (ignore args))
+ (declare (ignore ret args))
`(read-atom ,ctx))
(defmethod transform-grammar
- (ctx (in-meta (eql t)) (directive (eql :debug)) &optional args)
+ (ret ctx (in-meta (eql t)) (directive (eql :debug)) &optional args)
"\(:DEBUG)
\(:DEBUG VAR)
Print current character and its position in the input data. If VAR is specified,
print the value of the VAR."
+ (declare (ignore ret))
`(prog1 t
,(if (car args)
`(format t "DEBUG: ~s: ~a~%" ',(car args) ,(car args))
@@ -356,15 +362,15 @@ print the value of the VAR."
(deftype ,name () `(satisfies ,',name))))
(defmacro defrule (name (&rest args) (&optional attachment) &body body)
- (with-unique-names (ctx)
+ (with-unique-names (ctx ret val)
`(defun ,name (,ctx ,@args)
- (handler-case
- ,(if attachment
- `(let ((,attachment (parser-context-attachment ,ctx)))
- ,(transform-grammar ctx t :checkpoint body))
- (transform-grammar ctx t :checkpoint body))
- (parser-return (data)
- (return-from ,name (apply #'values (parser-return-value data))))))))
+ (let ((,ret
+ (lambda (,val)
+ (return-from ,name (apply #'values ,val)))))
+ ,(if attachment
+ `(let ((,attachment (parser-context-attachment ,ctx)))
+ ,(transform-grammar ret ctx t :checkpoint body))
+ (transform-grammar ret ctx t :checkpoint body))))))
(defmacro defrenderer (name (&rest args) (&optional attachment) &body body)
(with-unique-names (ctx)

0 comments on commit 77e5194

Please sign in to comment.