1 files changed, 95 insertions, 0 deletions
diff --git a/chickadee/graphics/seagull/syntax.scm b/chickadee/graphics/seagull/syntax.scm
new file mode 100644
index 0000000..81876b4
--- /dev/null
+++ b/chickadee/graphics/seagull/syntax.scm
@@ -0,0 +1,95 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2023 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Licensed under the Apache License, Version 2.0 (the "License");
+;;; you may not use this file except in compliance with the License.
+;;; You may obtain a copy of the License at
+;;;
+;;;    http://www.apache.org/licenses/LICENSE-2.0
+;;;
+;;; Unless required by applicable law or agreed to in writing, software
+;;; distributed under the License is distributed on an "AS IS" BASIS,
+;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;;; See the License for the specific language governing permissions and
+;;; limitations under the License.
+
+(define-module (chickadee graphics seagull syntax)
+  #:use-module (chickadee graphics seagull utils)
+  #:use-module (ice-9 exceptions)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-9)
+  #:use-module (system syntax internal)
+  #:export (<syntax>
+            make-seagull-syntax
+            seagull-syntax?
+            seagull-syntax-source
+            seagull-syntax-expression
+            seagull-syntax->sexp
+            build-syntax
+            $gl
+            &seagull-syntax-error
+            seagull-syntax-error
+            seagull-syntax-error-syntax))
+
+(define-record-type <syntax>
+  (make-seagull-syntax source exp)
+  seagull-syntax?
+  (source seagull-syntax-source)
+  (exp seagull-syntax-expression))
+
+(define (seagull-syntax->sexp syntax)
+  (match (seagull-syntax-expression syntax)
+    ((children ...)
+     (map seagull-syntax->sexp children))
+    (atom atom)))
+
+(define (build-syntax src exp)
+  (match exp
+    ((? seagull-syntax?)
+     exp)
+    ((children ...)
+     (make-seagull-syntax src
+                          (map (lambda (child)
+                                 (build-syntax src child))
+                               children)))
+    (atom
+     (make-seagull-syntax src atom))))
+
+;; Annotate seagull expressions with source information, producing
+;; seagull-specific syntax objects that can't be confused with scheme
+;; syntax objects.
+(define-syntax $gl
+  (lambda (x)
+    (syntax-case x ()
+      ((_ exp)
+       (with-syntax ((src (datum->syntax x (syntax-sourcev #'exp))))
+         #'(make-seagull-syntax src ($gl-recur exp)))))))
+
+;; Helper macro to annotate nested expressions.
+(define-syntax $gl-recur
+  (syntax-rules ()
+    ((_ (item ...))
+     (list ($gl item) ...))
+    ((_ atom)
+     'atom)))
+
+(define &seagull-syntax-error
+  (make-exception-type '&seagull-syntax-error &error '(syntax)))
+
+(define make-seagull-syntax-error
+  (record-constructor &seagull-syntax-error))
+
+(define seagull-syntax-error-syntax
+  (exception-accessor &seagull-syntax-error
+                      (record-accessor &seagull-syntax-error 'syntax)))
+
+(define (seagull-syntax-error msg syntax origin)
+  (raise-exception
+   (make-exception
+    (make-seagull-syntax-error syntax)
+    (make-exception-with-origin origin)
+    (make-exception-with-message
+     (format #f "Syntax error at ~a: ~a"
+             (sourcev->string (seagull-syntax-source syntax))
+             msg))
+    (make-exception-with-irritants (list (seagull-syntax->sexp syntax))))))