diff options
| -rw-r--r-- | argot.asd | 2 | ||||
| -rw-r--r-- | argot.lisp | 249 | ||||
| -rw-r--r-- | grammars.lisp | 245 |
3 files changed, 255 insertions, 241 deletions
@@ -8,4 +8,6 @@ :serial t :depends-on (#:trivia #:alexandria) :components ((:file "package") + ;(:file "grammars") + ;(:file "deflanguage") (:file "argot"))) @@ -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))) diff --git a/grammars.lisp b/grammars.lisp new file mode 100644 index 0000000..38f1c2f --- /dev/null +++ b/grammars.lisp @@ -0,0 +1,245 @@ +;;;; grammars.lisp + +(in-package #:argot) + +;;; GRAMMAR & RULES + +(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 ""))) + +(defun include-rule (grammar rule) + (setf (gethash (rule-lhs rule) (grammar-rules grammar)) rule)) + + +;;; PARSING + +(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))) |