diff options
Diffstat (limited to 'argot.lisp')
-rw-r--r-- | argot.lisp | 52 |
1 files changed, 31 insertions, 21 deletions
@@ -4,11 +4,25 @@ (defstruct rule lhs pattern action check) +(defclass grammar () + ((rules + :accessor grammar-rules + :initform (make-hash-table :test #'eq)) + (start + :accessor start-rule + :initarg :start-rule + :initform (error "START-RULE is required") + :type symbol) + (documentation + :reader grammar-documentation + :initarg :documentation + :initform ""))) + (define-condition invalid-rule-def (error) ((rule :reader rule :initarg :rule))) (defun include-rule (grammar rule) - (setf (gethash (rule-lhs rule) grammar) rule)) + (setf (gethash (rule-lhs rule) (grammar-rules grammar)) rule)) (defun nonterminal? (lhs) (and (symbolp lhs) @@ -87,7 +101,8 @@ and it returns VAR in that case." (symbolp (second s)) (endp (cddr s))))) -(defmacro defgrammar (name (&key (documentation "")) &body ruledefs) + +(defmacro deflanguage (name (&key (documentation "")) &body ruledefs) (let ((bindings-var (gensym "BINDINGS"))) (labels ((collect-let-bindings (lhs vars) "Create let-bindings forms for the body of the :action." @@ -117,14 +132,18 @@ and it returns VAR in that case." ,@(expand-functional-argument :check lhs bindings check) ,@(expand-functional-argument :action lhs bindings action))))) `(progn - (defvar ,name nil ,documentation) - (setf ,name (make-hash-table :test #'eq)) + (defvar ,name nil) + (setf ,name (make-instance 'grammar + :documentation ,documentation + :start-rule ',(first (first ruledefs)))) ,@(loop :for ruledef :in ruledefs :for (lhs pattern vars check action) := (parse-rule-def ruledef) :for bindings := (collect-let-bindings lhs vars) :collect (rule-includer name lhs pattern check action bindings)) - ,name)))) + + (defmacro ,name (&body tokens) + (argot:parse ,name tokens)))))) (defvar *position*) (defvar *grammar*) @@ -201,11 +220,11 @@ any pattern fails the whole parse fails." (if-parse (rest) (parse-kleene pattern) (succeed (cons first rest))))) -(defun parse-alernatives (patterns) +(defun parse-alternatives (patterns) (if (endp patterns) (fail) (try-parse (result) (parse-pattern (first patterns)) (succeed result) - (parse-alernatives (rest patterns))))) + (parse-alternatives (rest patterns))))) (defun literals->patterns (literals) (loop :for l :in literals :collect (list := l))) @@ -218,7 +237,7 @@ any pattern fails the whole parse fails." (fail))) (defun parse-literal-alternatives (literals) - (parse-alernatives (literals->patterns literals))) + (parse-alternatives (literals->patterns literals))) (defun parse-kleene-literal (literal) (parse-kleene (list := literal))) @@ -259,7 +278,7 @@ any pattern fails the whole parse fails." (:? (parse-optional (first args))) (:* (parse-kleene (first args))) (:+ (parse-one-or-more (first args))) - (:or (parse-alernatives args)) + (:or (parse-alternatives args)) (:or= (parse-literal-alternatives args)) (:= (parse-literal (first args))) (:*= (parse-kleene-literal (first args))) @@ -281,7 +300,7 @@ any pattern fails the whole parse fails." (succeed result))))) (defun parse-rule (nonterminal) - (if-let (rule (gethash nonterminal *grammar*)) + (if-let (rule (gethash nonterminal (grammar-rules *grammar*))) (let ((*bindings* nil)) (if-parse (result) (parse-pattern (rule-pattern rule)) (handle-post-rule rule result))) @@ -314,11 +333,11 @@ any pattern fails the whole parse fails." (loop :repeat (1+ (length front)) :collect #\Space) "^" (list #\Newline)))) -(defun parse (grammar rule tokens) +(defun parse (grammar tokens) (let ((*position* 0) (*grammar* grammar) (*tokens* (coerce tokens 'vector))) - (multiple-value-bind (result successp) (parse-rule rule) + (multiple-value-bind (result successp) (parse-rule (start-rule *grammar*)) (unless successp (error 'argot-parse-error :position *position* @@ -327,12 +346,3 @@ any pattern fails the whole parse fails." -;;; deflanguage - -(defmacro deflanguage (name options &body rules) - `(progn - (eval-when (:compile-toplevel) - (argot:defgrammar ,name ,options ,@rules)) - - (defmacro ,name (&body tokens) - (argot:parse ,name ',(car (first rules)) tokens)))) |