Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

382 lines (311 sloc) 13.611 kb
;;; 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 Structure & Routines
(defstruct parser-context
(data nil :read-only t :type string)
(size nil :read-only t :type unsigned-byte)
(cursor 0 :type unsigned-byte)
(checkpoints nil)
(icases nil)
attachment)
(defgeneric create-parser-context (input &rest args))
(defmethod create-parser-context ((input string) &key start end attachment)
(make-parser-context :data input
:cursor (or start 0)
:size (or end (length input))
:attachment attachment))
(defmethod create-parser-context
((input string-stream) &key buffer-size start end attachment)
(loop with out = (make-string-output-stream)
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
until (zerop pos)
do (write-string buf out :end pos)
finally (return
(create-parser-context
(get-output-stream-string out)
:start start
:end (or end size)
:attachment attachment))))
(declaim (inline peek-atom))
(defun peek-atom (ctx)
(if (< (parser-context-cursor ctx) (parser-context-size ctx))
(elt (parser-context-data ctx) (parser-context-cursor ctx))))
(declaim (inline read-atom))
(defun read-atom (ctx)
(if (< (parser-context-cursor ctx) (parser-context-size ctx))
(elt (parser-context-data ctx) (1- (incf (parser-context-cursor ctx))))))
(declaim (inline checkpoint))
(defun checkpoint (ctx)
(push (parser-context-cursor ctx) (parser-context-checkpoints ctx)))
(declaim (inline rollback))
(defun rollback (ctx)
(setf (parser-context-cursor ctx) (pop (parser-context-checkpoints ctx))))
(declaim (inline commit))
(defun commit (ctx)
(pop (parser-context-checkpoints ctx)))
;;; Atom, Rule & Type Matching
(declaim (inline match-atom))
(defun match-atom (ctx atom &aux (c (peek-atom ctx)))
(if (and c
(if (first (parser-context-icases ctx))
(char= (char-upcase atom) (char-upcase 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)))
;;; Grammar Compiler
(defgeneric transform-grammar (ret ctx in-meta directive &optional args)
(:documentation "META grammar transformation methods."))
(defmethod transform-grammar
(ret ctx (in-meta (eql t)) (directive character) &optional args)
"Transforms a character form."
(declare (ignore ret args))
`(match-atom ,ctx ,directive))
(defmethod transform-grammar
(ret ctx (in-meta (eql t)) (directive string) &optional args)
"Transforms a string form."
(declare (ignore args))
(transform-grammar
ret ctx t :checkpoint
`((and
,@(mapcar
(lambda (form) `(match-atom ,ctx ,form))
(coerce directive 'list))
,directive))))
(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 ret ctx t (car directive) (cdr directive)))
((and (not in-meta) (consp directive) (eql 'meta (car directive)))
(transform-grammar ret ctx t :and (cdr directive)))
((consp directive)
(mapcar (lambda (form) (transform-grammar ret ctx nil form)) directive))
(t directive)))
(defmethod transform-grammar
(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 (wrapper-ret val)
`(progn
(push t (parser-context-icases ,ctx))
(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
(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 (wrapper-ret val)
`(progn
(checkpoint ,ctx)
(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
(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 ret ctx t form)) args)))
(defmethod transform-grammar
(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 ret ctx t form)) args)))
(defmethod transform-grammar
(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
ret ctx t :checkpoint
`((not ,(transform-grammar ret ctx t (car args))))))
(defmethod transform-grammar
(ret ctx (in-meta (eql t)) (directive (eql :return)) &optional args)
"\(:RETURN VALUE VALUE ...)
Returns from the rule with supplied VALUEs."
(declare (ignore ctx))
`(funcall ,ret (list ,@args)))
(defmethod transform-grammar
(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
(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 ret ctx t form))
args))))
(defmethod transform-grammar
(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 ret ctx t :and args))))))
(defmethod transform-grammar
(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 ret ctx t :and `(,@args (:* ,@args))))
(defmethod transform-grammar
(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
(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
ret ctx t :or (mapcar (lambda (form) `(:rule ,form ,@(cdr args)))
(cdar args)))
`(match-rule ,ctx ,(car args) ,(cdr args))))
(defmethod transform-grammar
(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 ret ctx t (cadr args)))
`(setq ,(car args) ,(transform-grammar ret ctx t (cadr args)))))
(defmethod transform-grammar
(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
(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
(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
(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
(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 ret args))
`(= (parser-context-cursor ,ctx) (parser-context-size ,ctx)))
(defmethod transform-grammar
(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 ret args))
`(read-atom ,ctx))
(defmethod transform-grammar
(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))
`(format t "DEBUG: cursor: [~s] `~s'~%"
(parser-context-cursor ,ctx)
(elt (parser-context-data ,ctx)
(parser-context-cursor ,ctx))))))
;;; Atom, Rule & Renderer Definition Macros
(defmacro defatom (name (c) &body body)
`(progn
(declaim (inline ,name))
(defun ,name (,c) (when ,c ,@body))
(deftype ,name () `(satisfies ,',name))))
(defmacro defrule (name (&rest args) (&optional attachment) &body body)
(with-unique-names (ctx ret val)
`(defun ,name (,ctx ,@args)
(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)
`(defun ,name (,ctx ,@args)
,(if attachment
`(let ((,attachment (parser-context-attachment ,ctx)))
,@body)
`(progn ,@body))
t)))
Jump to Line
Something went wrong with that request. Please try again.