From d579fede001a09d3a4047a8df71be406ff30e95e Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Sun, 9 Jan 2022 14:06:55 -0800
Subject: Add some magic to detect symbols.

I still don't understand this snippet.
---
 match.csc | 37 ++++++++++++++++++++++++++-----------
 1 file changed, 26 insertions(+), 11 deletions(-)

(limited to 'match.csc')

diff --git a/match.csc b/match.csc
index d128195..e5ee6ec 100644
--- a/match.csc
+++ b/match.csc
@@ -1,14 +1,26 @@
 (define-library (csc match)
-  (export match matches?)
+  (export match)
   (import (scheme base))
   (begin
 
 
+    ; From https://cookbook.scheme.org/check-for-symbol-in-syntax-rules/
+    (define-syntax symbol??
+      (syntax-rules ()
+        ((symbol?? (_ . _) _ kf) kf)  ; It's a pair, not a symbol.
+        ((symbol?? #(_ ...) _ kf) kf)  ; It's a vector, not a symbol.
+        ((symbol?? maybe-symbol kt kf)
+         (let-syntax
+           ((test
+              (syntax-rules ()
+                ((test maybe-symbol t _) t)
+                ((test _ _ f) f))))
+           (test abracadabra kt kf)))))
+
+
     (define-syntax matches?
-      (syntax-rules (! _)
+      (syntax-rules (_)
         ((matches? x _) #t)
-        ((matches? x (! lit))
-         (eqv? x lit))
         ((matches? x '())
          (null? x))
         ((matches? x (pattern))
@@ -18,15 +30,16 @@
          (and (pair? x)
               (matches? (car x) pattern1)
               (matches? (cdr x) pattern2)))
-        ((matches? x bind) #t)))
+        ((matches? x lit)
+         (symbol?? lit
+           #t
+           (equal? x lit)))))
 
 
     (define-syntax bind-pattern
-      (syntax-rules (! _)
+      (syntax-rules (_)
         ((bind-pattern x _ result1 result2 ...)
          (begin result1 result2 ...))
-        ((bind-pattern x (! lit) result1 result2 ...)
-         (begin result1 result2 ...))
         ((bind-pattern x '() result1 result2 ...)
          (begin result1 result2 ...))
         ((bind-pattern x (pattern) result1 result2 ...)
@@ -34,9 +47,11 @@
         ((bind-pattern x (pattern1 . pattern2) result1 result2 ...)
          (bind-pattern (car x) pattern1
            (bind-pattern (cdr x) pattern2 result1 result2 ...)))
-        ((bind-pattern x bind result1 result2 ...)
-         (let ((bind x))
-           result1 result2 ...))))
+        ((bind-pattern x lit result1 result2 ...)
+         (symbol?? lit
+           (let ((lit x))
+             result1 result2 ...)
+           (begin result1 result2 ...)))))
 
 
     (define-syntax match
-- 
cgit v1.3.1