Moving code around

1 files changed, 8 insertions, 241 deletions

diff --git a/argot.lisp b/argot.lisp
index ec5f9b8..2218dd5 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -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)))