diff options
Diffstat (limited to 'argot.lisp')
| -rw-r--r-- | argot.lisp | 55 |
1 files changed, 38 insertions, 17 deletions
@@ -2,7 +2,7 @@ (in-package #:argot) -(defstruct rule lhs pattern action) +(defstruct rule lhs pattern action check) (define-condition invalid-rule-def (error) ((rule :reader rule :initarg :rule))) @@ -46,6 +46,7 @@ and it returns VAR in that case." (destructuring-bind (at var . _) pat (declare (ignore _)) (and (eq at :@) (var? var) var)))) + (defun collect-vars (pat) "Collects all of the variables from the var patterns in PAT and returns them." (if-let (var (var-pattern? pat)) @@ -58,12 +59,24 @@ and it returns VAR in that case." (handler-case (ematch ruledef ((guard (list lhs :-> pattern) - (and (nonterminal? lhs) (pattern? pattern))) - (list lhs pattern (collect-vars pattern) nil)) + (and (nonterminal? lhs) (pattern? pattern))) + (list lhs pattern (collect-vars pattern) nil nil)) + + ((guard (list lhs :-> pattern :? check) + (and (nonterminal? lhs) (pattern? pattern))) + (list lhs pattern (collect-vars pattern) check nil)) ((guard (list lhs :-> pattern :=> action) - (and (nonterminal? lhs) (pattern? pattern))) - (list lhs pattern (collect-vars pattern) action))) + (and (nonterminal? lhs) (pattern? pattern))) + (list lhs pattern (collect-vars pattern) nil action)) + + ((guard (list lhs :-> pattern :=> action :? check) + (and (nonterminal? lhs) (pattern? pattern))) + (list lhs pattern (collect-vars pattern) check action)) + + ((guard (list lhs :-> pattern :? check :=> action) + (and (nonterminal? lhs) (pattern? pattern))) + (list lhs pattern (collect-vars pattern) check action))) (trivia::match-error () (error 'invalid-rule-def :rule ruledef)))) @@ -81,35 +94,36 @@ and it returns VAR in that case." (loop :for var :in vars :collect `(,var (cdr (assoc ',var ,bindings-var))) :into bs :finally (return (cons (list lhs `(cdr (assoc ',lhs ,bindings-var))) bs)))) - (expand-action-argument (lhs bindings action) + (expand-functional-argument (initarg lhs bindings action ) (cond ((and action (symbolp action)) - (list :action `(lambda (,bindings-var) + (list initarg `(lambda (,bindings-var) (let ,bindings (,action ,lhs))))) ((function-form-p action) - (list :action `(lambda (,bindings-var) + (list initarg `(lambda (,bindings-var) (let ,bindings (funcall ,action ,lhs))))) ((consp action) - (list :action `(lambda (,bindings-var) + (list initarg `(lambda (,bindings-var) (let ,bindings (declare (ignore ,lhs)) ,action)))))) - (rule-includer (name lhs pattern &optional action bindings) + (rule-includer (name lhs pattern &optional check action bindings) `(include-rule ,name (make-rule :lhs ',lhs :pattern ',pattern - ,@(expand-action-argument lhs bindings action))))) + ,@(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)) ,@(loop :for ruledef :in ruledefs - :for (lhs pattern vars action) := (parse-rule-def ruledef) + :for (lhs pattern vars check action) := (parse-rule-def ruledef) :for bindings := (collect-let-bindings lhs vars) - :collect (rule-includer name lhs pattern action bindings)) + :collect (rule-includer name lhs pattern check action bindings)) ,name)))) (defvar *position*) @@ -246,14 +260,21 @@ any pattern fails the whole parse fails." (:item (parse-item)) (:eof (parse-eof))))))) +(defun handle-post-rule (rule result) + (with-slots (lhs check action) rule + (let ((bindings (acons lhs result *bindings*))) + (when check + (unless (funcall check bindings) + (return-from handle-post-rule (fail)))) + (if action + (succeed (funcall action bindings)) + (succeed result))))) + (defun parse-rule (nonterminal) (if-let (rule (gethash nonterminal *grammar*)) (let ((*bindings* nil)) (try-parse (result) (parse-pattern (rule-pattern rule)) - (if (rule-action rule) - (succeed (funcall (rule-action rule) - (acons nonterminal result *bindings*))) - (succeed result)))) + (handle-post-rule rule result))) (fail))) |