aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2023-09-10 12:01:07 -0700
committercolin <colin@cicadas.surf>2023-09-10 12:01:07 -0700
commit1504c36d166a81de08d93d8a5a85e4c36467f7b1 (patch)
treea9930f25f6c6d8df4efbbab77ccafa88b8ca0b22
parentb1d927635d4a15d4904080bc9738799fb4873fff (diff)
Added custom literals comparator for grammarsHEADmain
-rw-r--r--argot.lisp9
-rw-r--r--grammars.lisp16
2 files changed, 20 insertions, 5 deletions
diff --git a/argot.lisp b/argot.lisp
index 8ab90ba..aebe3d6 100644
--- a/argot.lisp
+++ b/argot.lisp
@@ -81,7 +81,10 @@ and it returns VAR in that case."
(symbolp (second s))
(endp (cddr s)))))
-(defmacro deflanguage (name (&key (documentation "")) &body ruledefs)
+(defmacro deflanguage (name (&key
+ (documentation "")
+ literals=)
+ &body ruledefs)
(let ((bindings-var (gensym "BINDINGS")))
(labels ((collect-let-bindings (lhs vars)
"Create let-bindings forms for the body of the :action."
@@ -152,7 +155,9 @@ and it returns VAR in that case."
(setf (get ',name 'argot::grammar-property)
(make-instance 'grammar
:documentation ,documentation
- :start-rule ',(first (first ruledefs))))
+ :start-rule ',(first (first ruledefs))
+ ,@(when literals=
+ `(:literal-comparator ,literals=))))
,@rule-adder-forms
(defmacro ,name (&body tokens)
diff --git a/grammars.lisp b/grammars.lisp
index f8c99f6..da00a4c 100644
--- a/grammars.lisp
+++ b/grammars.lisp
@@ -15,6 +15,13 @@
:initarg :start-rule
:initform (error "START-RULE is required")
:type symbol)
+ (literal-comparator
+ :accessor literal-comparator
+ :initarg :literal-comparator
+ :initform #'equalp
+ :type function
+ :documentation "The function used to compare literals
+ when using this grammar")
(documentation
:reader grammar-documentation
:initarg :documentation
@@ -30,6 +37,7 @@
(defvar *grammar*)
(defvar *tokens*)
(defvar *bindings*)
+(defvar *literals-equal-p* #'equalp)
(defun succeed (result)
(values result t))
@@ -109,7 +117,7 @@ any pattern fails the whole parse fails."
(defun literals->patterns (literals)
(loop :for l :in literals :collect (list := l)))
-(defun literals-equal? (a b) (equalp a b))
+(defun literals-equal? (a b) (funcall *literals-equal-p* a b))
(defun parse-literal (literal)
(if (literals-equal? (next-token) literal)
@@ -159,7 +167,8 @@ any pattern fails the whole parse fails."
(if-let (grammar (find-grammar language))
(let ((*grammar* grammar)
(*position* 0)
- (*tokens* (coerce subtokens 'vector)))
+ (*tokens* (coerce subtokens 'vector))
+ (*literals-equal-p* (literal-comparator grammar)))
(parse-rule (start-rule grammar)))
(error "No grammar called ~s" language))
(fail))))
@@ -232,7 +241,8 @@ any pattern fails the whole parse fails."
(defun parse (grammar tokens)
(let ((*position* 0)
(*grammar* grammar)
- (*tokens* (coerce tokens 'vector)))
+ (*tokens* (coerce tokens 'vector))
+ (*literals-equal-p* (literal-comparator grammar)))
(multiple-value-bind (result successp) (parse-rule (start-rule *grammar*))
(unless successp
(error 'argot-parse-error