From a9113e6663ff2436cbeb6b0f0c32d9b387a045b5 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sat, 29 Jul 2023 08:09:51 -0700
Subject: Add grammar class; remove defgrammar fold into deflanguage

---
 argot.lisp | 52 +++++++++++++++++++++++++++++++---------------------
 1 file changed, 31 insertions(+), 21 deletions(-)

(limited to 'argot.lisp')

diff --git a/argot.lisp b/argot.lisp
index 6c2df22..f41e6c3 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -4,11 +4,25 @@
 
 (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)))
 
 (defun include-rule (grammar rule)
-  (setf (gethash (rule-lhs rule) grammar) rule))
+  (setf (gethash (rule-lhs rule) (grammar-rules grammar)) rule))
 
 (defun nonterminal? (lhs)
   (and (symbolp lhs)
@@ -87,7 +101,8 @@ and it returns VAR in that case."
            (symbolp (second s))
            (endp (cddr s)))))
 
-(defmacro defgrammar (name (&key (documentation "")) &body ruledefs)
+
+(defmacro deflanguage (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."
@@ -117,14 +132,18 @@ and it returns VAR in that case."
                   ,@(expand-functional-argument :check lhs bindings check)
                   ,@(expand-functional-argument :action lhs bindings action))))) 
       `(progn
-         (defvar ,name nil ,documentation)
-         (setf ,name (make-hash-table :test #'eq))
+         (defvar ,name nil)
+         (setf ,name (make-instance 'grammar
+                                      :documentation ,documentation
+                                      :start-rule ',(first (first ruledefs))))
          ,@(loop
              :for ruledef :in ruledefs
              :for (lhs pattern vars check action) := (parse-rule-def ruledef)
              :for bindings := (collect-let-bindings lhs vars)
              :collect (rule-includer name lhs pattern check action bindings))
-         ,name))))
+
+         (defmacro ,name (&body tokens)
+           (argot:parse ,name tokens))))))
 
 (defvar *position*)
 (defvar *grammar*)
@@ -201,11 +220,11 @@ any pattern fails the whole parse fails."
       (if-parse (rest) (parse-kleene pattern)
           (succeed (cons first rest)))))
 
-(defun parse-alernatives (patterns)
+(defun parse-alternatives (patterns)
   (if (endp patterns) (fail)
       (try-parse (result) (parse-pattern (first patterns))
           (succeed result)
-          (parse-alernatives (rest patterns)))))
+          (parse-alternatives (rest patterns)))))
 
 (defun literals->patterns (literals)
   (loop :for l :in literals :collect (list := l)))
@@ -218,7 +237,7 @@ any pattern fails the whole parse fails."
       (fail)))
 
 (defun parse-literal-alternatives (literals)
-  (parse-alernatives (literals->patterns literals)))
+  (parse-alternatives (literals->patterns literals)))
 
 (defun parse-kleene-literal (literal)
   (parse-kleene (list := literal)))
@@ -259,7 +278,7 @@ any pattern fails the whole parse fails."
           (:? (parse-optional (first args)))
           (:* (parse-kleene (first args)))
           (:+ (parse-one-or-more (first args)))
-          (:or (parse-alernatives args))
+          (:or (parse-alternatives args))
           (:or= (parse-literal-alternatives args))
           (:= (parse-literal (first args)))
           (:*= (parse-kleene-literal (first args)))
@@ -281,7 +300,7 @@ any pattern fails the whole parse fails."
           (succeed result)))))
 
 (defun parse-rule (nonterminal)
-  (if-let (rule (gethash nonterminal *grammar*))
+  (if-let (rule (gethash nonterminal (grammar-rules *grammar*)))
     (let ((*bindings* nil))
       (if-parse (result) (parse-pattern (rule-pattern rule))
           (handle-post-rule rule result)))
@@ -314,11 +333,11 @@ any pattern fails the whole parse fails."
      (loop :repeat (1+ (length front)) :collect #\Space)
      "^" (list #\Newline))))
 
-(defun parse (grammar rule tokens)
+(defun parse (grammar tokens)
   (let ((*position* 0)
         (*grammar* grammar)
         (*tokens* (coerce tokens 'vector)))
-    (multiple-value-bind (result successp)  (parse-rule rule)
+    (multiple-value-bind (result successp)  (parse-rule (start-rule *grammar*))
       (unless successp
         (error 'argot-parse-error
                :position *position*
@@ -327,12 +346,3 @@ any pattern fails the whole parse fails."
 
 
 
-;;; deflanguage
-
-(defmacro deflanguage (name options &body rules)
-  `(progn
-     (eval-when (:compile-toplevel)
-      (argot:defgrammar ,name ,options ,@rules))
-
-     (defmacro ,name (&body tokens)
-       (argot:parse ,name ',(car (first rules)) tokens))))
-- 
cgit v1.2.3