diff options
Diffstat (limited to 'argot.lisp')
| -rw-r--r-- | argot.lisp | 249 |
1 files changed, 8 insertions, 241 deletions
@@ -2,30 +2,12 @@ (in-package #:argot) -(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)) (:report (lambda (e stream) (format stream "The rule ~s is malformed." (car (rule e)))))) -(defun include-rule (grammar rule) - (setf (gethash (rule-lhs rule) (grammar-rules grammar)) rule)) - (defun nonterminal? (lhs) (and (symbolp lhs) (let* ((name (symbol-name lhs)) @@ -113,28 +95,30 @@ 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-functional-argument (initarg lhs bindings action ) + (expand-functional-argument (initarg lhs bindings action vars) (cond ((and action (symbolp action)) (list initarg `(lambda (,bindings-var) (let ,bindings + (declare (ignorable ,lhs ,@vars)) (,action ,lhs))))) ((function-form-p action) (list initarg `(lambda (,bindings-var) (let ,bindings + (declare (ignorable ,lhs ,@vars)) (funcall ,action ,lhs))))) ((consp action) (list initarg `(lambda (,bindings-var) (let ,bindings - (declare (ignorable ,lhs)) + (declare (ignorable ,lhs ,@vars)) ,action)))))) - (rule-includer (name lhs pattern &optional check action bindings) + (rule-includer (name lhs pattern &optional check action bindings vars) `(include-rule ,name (make-rule :lhs ',lhs :pattern ',pattern - ,@(expand-functional-argument :check lhs bindings check) - ,@(expand-functional-argument :action lhs bindings action))))) + ,@(expand-functional-argument :check lhs bindings check vars) + ,@(expand-functional-argument :action lhs bindings action vars))))) `(progn (defvar ,name nil) (setf ,name (make-instance 'grammar @@ -145,228 +129,11 @@ and it returns VAR in that case." :for (lhs pattern vars check action) := (handler-case (parse-rule-def ruledef) (invalid-rule-def (e) (invoke-debugger e))) :for bindings := (collect-let-bindings lhs vars) - :collect (rule-includer name lhs pattern check action bindings)) + :collect (rule-includer name lhs pattern check action bindings vars)) (defmacro ,name (&body tokens) (argot:parse ,name tokens)))))) -(defvar *position*) -(defvar *grammar*) -(defvar *tokens*) -(defvar *bindings*) - -(defun succeed (result) - (values result t)) - -(defun fail () - (values nil nil)) - -(defparameter +eof+ #()) - -(defun next-token () - (if (< *position* (length *tokens*)) - (prog1 (elt *tokens* *position*) - (incf *position*)) - +eof+)) - -(defun update-bindings (var value) - (setf *bindings* (acons var value *bindings*))) - -(defmacro try-parse - ((&optional (result (gensym))) - parse-expression - &optional - (success-clause `(succeed ,result)) - (fail-clause '(fail))) - (alexandria:with-gensyms (successp pos) - `(let ((,pos *position*)) - (multiple-value-bind (,result ,successp) ,parse-expression - (if ,successp ,success-clause - (progn - (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." - (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 - (res) (parse-pattern pattern) - (succeed res) - (succeed nil))) - -(defun parse-kleene (pattern) - (loop :for (res successp) := (multiple-value-list (try-parse () (parse-pattern pattern))) - :while successp :collect res :into results - :finally (return-from parse-kleene (succeed results)))) - -(defun parse-one-or-more (pattern) - (if-parse (first) (parse-pattern pattern) - (if-parse (rest) (parse-kleene pattern) - (succeed (cons first rest))))) - -(defun parse-alternatives (patterns) - (if (endp patterns) (fail) - (try-parse (result) (parse-pattern (first patterns)) - (succeed result) - (parse-alternatives (rest patterns))))) - -(defun literals->patterns (literals) - (loop :for l :in literals :collect (list := l))) - -(defun literals-equal? (a b) (eq a b)) - -(defun parse-literal (literal) - (if (literals-equal? (next-token) literal) - (succeed literal) - (fail))) - -(defun parse-literal-alternatives (literals) - (parse-alternatives (literals->patterns literals))) - -(defun parse-kleene-literal (literal) - (parse-kleene (list := literal))) - -(defun parse-one-or-more-literal (literal) - (parse-one-or-more (list := literal))) - -(defun parse-optional-literal (literal) - (parse-optional (list := literal))) - -(defun parse-literal-sequence (literals) - (parse-sequence (literals->patterns literals))) - -(defun parse-binding-pattern (var pattern) - (if-parse - (result) (parse-pattern pattern) - (progn - (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) - (fail))) - -(defun find-grammar (name) - (and (symbolp name) - (boundp name) - (let ((val (symbol-value name))) - (and (typep val 'grammar) - val)))) - -(defun parse-grammar-pattern (language) - (if-parse (subtokens) (parse-item) - (if (listp subtokens) - (if-let (grammar (find-grammar language)) - (let ((*grammar* grammar) - (*position* 0) - (*tokens* (coerce subtokens 'vector))) - (parse-rule (start-rule grammar))) - (error "No grammar called ~s" language)) - (fail)))) - -(defun parse-pattern (pattern) - (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-alternatives 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))) - (:{} (parse-grammar-pattern (first args))) - (: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-rules *grammar*))) - (let ((*bindings* nil)) - (if-parse (result) (parse-pattern (rule-pattern rule)) - (handle-post-rule rule result))) - (fail))) - - -(define-condition argot-parse-error (error) - ((position :initarg :position) - (input :initarg :input)) - (:report (lambda (err stream) - (with-slots (position input) err - (let ((pos (max 0 (- position 2)))) - (format - stream - "Parse failed at position ~a, around:~%~a" - pos (print-seq-range-pointing-at-center input pos 4))))))) - -(defun listslice (seq start stop) - (coerce (alexandria-2:subseq* seq start stop) 'list)) - -(defun print-seq-range-pointing-at-center (items position radius) - (let* ((front - (format nil "... ~{~s~^ ~}" (listslice items (max 0 (- position radius)) position ))) - (line - (format nil "~a ~{~s~^ ~} ..." - front (listslice items position (+ position radius 1))))) - (concatenate - 'string - line (list #\Newline) - (loop :repeat (1+ (length front)) :collect #\Space) - "^" (list #\Newline)))) - -(defun parse (grammar tokens) - (let ((*position* 0) - (*grammar* grammar) - (*tokens* (coerce tokens 'vector))) - (multiple-value-bind (result successp) (parse-rule (start-rule *grammar*)) - (unless successp - (error 'argot-parse-error - :position *position* - :input *tokens*)) - result))) |