diff options
| -rw-r--r-- | argot.lisp | 66 |
1 files changed, 45 insertions, 21 deletions
@@ -24,7 +24,7 @@ (defun pattern? (pat) "Every pattern PAT is either a nonterminal symbol, or a pattern expression. Such expressions look like (OP . ARGS) where OP is one of -:SEQ :? :* :+ :OR :OR= := :*= :?= :SEQ= :@ :EOF" +:SEQ :? :* :+ :OR :OR= := :*= :?= :SEQ= :@ :EOF :ITEM" (or (nonterminal? pat) (and (consp pat) (destructuring-bind (op . more) pat @@ -36,7 +36,7 @@ expression. Such expressions look like (OP . ARGS) where OP is one of (:@ (and (var? (first more)) (not (third more)) (pattern? (second more)))) - (:eof (endp more))))))) + ((:item :eof) (endp more))))))) (defun var-pattern? (pat) "VAR-PATTERN? checks that a pattern is a var pattern (:@ VAR PATTERN) @@ -46,7 +46,6 @@ 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)) @@ -68,29 +67,47 @@ and it returns VAR in that case." (trivia::match-error () (error 'invalid-rule-def :rule ruledef)))) +(defun function-form-p (s) + (or (functionp s) + (and (consp s) + (eq 'cl:function (first s)) + (symbolp (second s)) + (endp (cddr s))))) + (defmacro defgrammar (name (&key (documentation "")) &body ruledefs) (let ((bindings-var (gensym "BINDINGS"))) - (flet ((collect-let-bindings (lhs vars) - "Create let-bindings forms for the body of the :action. " - (loop :for var :in vars - :collect `(,var (cdr (assoc ',var ,bindings-var))) :into bs - :finally (return (list* lhs `(cdr (assoc ',lhs ,bindings-var)) bs)))) - (rule-includer (name lhs pattern &optional action bindings) - `(include-rule - ,name - (make-rule - :lhs ',lhs - :pattern ',pattern - ,@(when action - (list - :action `(lambda (,bindings-var) (let ,bindings ,action)))))))) + (labels ((collect-let-bindings (lhs vars) + "Create let-bindings forms for the body of the :action. " + (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) + (cond ((and action (symbolp action)) + (list :action `(lambda (,bindings-var) + (let ,bindings + (,action ,lhs))))) + ((function-form-p action) + (list :action `(lambda (,bindings-var) + (let ,bindings + (funcall ,action ,lhs))))) + ((consp action) + (list :action `(lambda (,bindings-var) + (let ,bindings ,action)))))) + (rule-includer (name lhs pattern &optional action bindings) + `(include-rule + ,name + (make-rule + :lhs ',lhs + :pattern ',pattern + ,@(expand-action-argument 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 bindings := (collect-let-bindings lhs vars) - :collect (rule-includer name lhs pattern action bindings)) + ,@(loop + :for ruledef :in ruledefs + :for (lhs pattern vars action) := (parse-rule-def ruledef) + :for bindings := (collect-let-bindings lhs vars) + :collect (rule-includer name lhs pattern action bindings)) ,name)))) (defvar *position*) @@ -195,6 +212,12 @@ any pattern fails the whole parse fails." (update-bindings var result) (succeed result)))) +(defun parse-item () + (let ((token (next-token))) + (if (not (eq token +eof+)) + (succeed token) + (fail)))) + (defun parse-eof () (if (eq +eof+ (next-token)) (succeed nil) @@ -218,6 +241,7 @@ any pattern fails the whole parse fails." (:?= (parse-optional-literal (first args))) (:seq= (parse-literal-sequence args)) (:@ (parse-binding-pattern (first args) (second args))) + (:item (parse-item)) (:eof (parse-eof))))))) (defun parse-rule (nonterminal) |