From 804a2fe3c90c06a22a1eed5ea50d667ff3e7b08c Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Wed, 29 Jun 2022 21:52:30 -0700
Subject: Add pattern matching for record types.

I like scheme because it's possible to add any convenient language
feature I can think of.
---
 csc/match.csc | 43 ++++++++++++++++++++++++++++++++-----------
 1 file changed, 32 insertions(+), 11 deletions(-)

(limited to 'csc/match.csc')

diff --git a/csc/match.csc b/csc/match.csc
index 5b85f09..ad9b56a 100644
--- a/csc/match.csc
+++ b/csc/match.csc
@@ -1,5 +1,7 @@
 (define-library (csc match)
-  (export match)
+  (export
+    define-match-record-type
+    match)
   (import (scheme base))
   (begin
 
@@ -9,34 +11,53 @@
       no-match?)
 
 
+    (define *no-match* (make-no-match))
+
+
+    (define-syntax define-match-record-type
+      (syntax-rules ()
+        ((define-match-record-type name constructor predicate matcher (field-name* field-getter*) ...)
+          (begin
+            (define-record-type name
+              constructor
+              predicate
+              (field-name* field-getter*) ...)
+            (define (matcher x)
+              (unless (predicate x)
+                (raise *no-match*))
+              (list (field-getter* x) ...))))))
+
+
     (define-syntax match-pattern
-      (syntax-rules (_ ! when)
+      (syntax-rules (_ ! when %)
         ((match-pattern x pattern (when condition) result result* ...)
          (match-pattern x pattern
            (if condition
-             (begin result result* ...)
-             (raise (make-no-match)))))
+             (let () result result* ...)
+             (raise *no-match*))))
         ((match-pattern x _ result result* ...)
-         (begin result result* ...))
+         (let () result result* ...))
         ((match-pattern x '() result result* ...)
          (if (null? x)
-           (begin result result* ...)
-           (raise (make-no-match))))
+           (let () result result* ...)
+           (raise *no-match*)))
         ((match-pattern x (! constant) result result* ...)
          (if (equal? x constant)
-           (begin result result* ...)
-           (raise (make-no-match))))
+           (let () result result* ...)
+           (raise *no-match*)))
         ((match-pattern x (pattern) result result* ...)
          (let ((y x))
            (if (= 1 (length y))
              (match-pattern (car y) pattern result result* ...)
-             (raise (make-no-match)))))
+             (raise *no-match*))))
+        ((match-pattern x (% record-matcher . patterns) result result* ...)
+          (match-pattern (record-matcher x) patterns result result* ...))
         ((match-pattern x (pattern . rest) result result* ...)
          (let ((y x))
            (if (pair? y)
              (match-pattern (car y) pattern
                (match-pattern (cdr y) rest result result* ...))
-             (raise (make-no-match)))))
+             (raise *no-match*))))
         ((match-pattern x identifier result result* ...)
          (let ((identifier x))
            result result* ...))))
-- 
cgit v1.3.1