diff options
| -rw-r--r-- | argot.lisp | 89 |
1 files changed, 55 insertions, 34 deletions
@@ -90,7 +90,7 @@ and it returns VAR in that case." (defmacro defgrammar (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. " + "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)))) @@ -162,17 +162,28 @@ and it returns VAR in that case." (setf *position* ,pos) ,fail-clause)))))) +(defmacro if-parse + ((&optional (result (gensym))) + parse-expression + &optional + (success-clause `(succeed ,result)) + (fail-clause '(fail))) + (alexandria:with-gensyms (successp) + `(multiple-value-bind (,result ,successp) ,parse-expression + (if ,successp ,success-clause + ,fail-clause)))) + + (defun parse-sequence (patterns) "Parse each member of PATTERNS and succeed with a list of results. If any pattern fails the whole parse fails." - (try-parse - () (loop :for pattern :in patterns - :for (result successp) - := (multiple-value-list (parse-pattern pattern)) - :if successp - :collect result :into results - :else :return (fail) - :finally (return (succeed results))))) + (loop :for pattern :in patterns + :for (result successp) + := (multiple-value-list (parse-pattern pattern)) + :if successp + :collect result :into results + :else :return (fail) + :finally (return (succeed results)))) (defun parse-optional (pattern) (try-parse @@ -186,8 +197,8 @@ any pattern fails the whole parse fails." :finally (return-from parse-kleene (succeed results)))) (defun parse-one-or-more (pattern) - (try-parse (first) (parse-pattern pattern) - (try-parse (rest) (parse-kleene pattern) + (if-parse (first) (parse-pattern pattern) + (if-parse (rest) (parse-kleene pattern) (succeed (cons first rest))))) (defun parse-alernatives (patterns) @@ -222,7 +233,7 @@ any pattern fails the whole parse fails." (parse-sequence (literals->patterns literals))) (defun parse-binding-pattern (var pattern) - (try-parse + (if-parse (result) (parse-pattern pattern) (progn (update-bindings var result) @@ -240,25 +251,24 @@ any pattern fails the whole parse fails." (fail))) (defun parse-pattern (pattern) - (try-parse () - (if (nonterminal? pattern) - (parse-rule pattern) - (destructuring-bind (op . args) pattern - (case op - (:seq (parse-sequence args)) - (:? (parse-optional (first args))) - (:* (parse-kleene (first args))) - (:+ (parse-one-or-more (first args))) - (:or (parse-alernatives args)) - (:or= (parse-literal-alternatives args)) - (:= (parse-literal (first args))) - (:*= (parse-kleene-literal (first args))) - (:+= (parse-one-or-more-literal (first args))) - (:?= (parse-optional-literal (first args))) - (:seq= (parse-literal-sequence args)) - (:@ (parse-binding-pattern (first args) (second args))) - (:item (parse-item)) - (:eof (parse-eof))))))) + (if (nonterminal? pattern) + (parse-rule pattern) + (destructuring-bind (op . args) pattern + (case op + (:seq (parse-sequence args)) + (:? (parse-optional (first args))) + (:* (parse-kleene (first args))) + (:+ (parse-one-or-more (first args))) + (:or (parse-alernatives args)) + (:or= (parse-literal-alternatives args)) + (:= (parse-literal (first args))) + (:*= (parse-kleene-literal (first args))) + (:+= (parse-one-or-more-literal (first args))) + (:?= (parse-optional-literal (first args))) + (:seq= (parse-literal-sequence args)) + (:@ (parse-binding-pattern (first args) (second args))) + (:item (parse-item)) + (:eof (parse-eof)))))) (defun handle-post-rule (rule result) (with-slots (lhs check action) rule @@ -273,13 +283,24 @@ any pattern fails the whole parse fails." (defun parse-rule (nonterminal) (if-let (rule (gethash nonterminal *grammar*)) (let ((*bindings* nil)) - (try-parse (result) (parse-pattern (rule-pattern rule)) + (if-parse (result) (parse-pattern (rule-pattern rule)) (handle-post-rule rule result))) (fail))) +(define-condition argot-parse-error (error) + ((position :initarg :position) + (token :initarg :token) + (input :initarg :input))) + (defun parse (grammar rule tokens) (let ((*position* 0) (*grammar* grammar) - (*tokens* tokens)) - (parse-rule rule))) + (*tokens* (coerce tokens 'vector))) + (multiple-value-bind (result successp) (parse-rule rule) + (unless successp + (error 'argot-parse-error + :position *position* + :input *tokens* + :token (elt *tokens* (1- *position*)))) + result))) |