From 83a18a658ac925b589d36e37ae150ec986d5eba8 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 5 Aug 2022 21:04:49 -0700
Subject: Add more of the standard library.

---
 lib/scheme/base/50-records.csc | 83 ++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 83 insertions(+)
 create mode 100644 lib/scheme/base/50-records.csc

(limited to 'lib/scheme/base/50-records.csc')

diff --git a/lib/scheme/base/50-records.csc b/lib/scheme/base/50-records.csc
new file mode 100644
index 0000000..d7fa8d1
--- /dev/null
+++ b/lib/scheme/base/50-records.csc
@@ -0,0 +1,83 @@
+(export
+  define-record-type)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  ; There are a few builtin types such as vector, which uses type code 0. We'll
+  ; start at 10 to give some room for more in the future.
+  (define *next-type-id* 10)
+
+
+  (define-syntax macro-length
+    (syntax-rules ()
+      ((macro-length ()) 0)
+      ((macro-length (x xs ...))
+        (+ 1 (macro-length (xs ...))))))
+
+
+  (define-syntax set-arguments
+    (syntax-rules ()
+      ((set-arguments _ _)
+        #f)
+      ((set-arguments r n field1 field2 ...)
+        (begin
+          (call-builtin poke field1 r n)
+          (set-arguments r (+ 1 n) field2 ...)))))
+
+
+  (define-syntax define-selectors
+    (syntax-rules ()
+      ((define-selectors (selectors ...))
+        (values selectors ...))
+      ((define-selectors (selectors ...) (field getter) selector ...)
+        (define-selectors (selectors ... (lambda (r)
+                                           (call-builtin peek r field)))
+          selector ...))
+      ((define-selectors (selectors ...) (field getter setter) selector ...)
+        (define-selectors (selectors ... (lambda (r)
+                                           (call-builtin peek r field))
+                                         (lambda (r val)
+                                           (call-builtin poke val r field)))
+          selector ...))))
+
+
+  (define-syntax enumerate-fields
+    (syntax-rules ()
+      ((enumerate-fields _ selectors)
+        (define-selectors selectors))
+      ((enumerate-fields n selectors field1 field2 ...)
+        (begin
+          (define field1 n)
+          (enumerate-fields (+ 1 n) selectors field2 ...)))))
+
+
+  (define-syntax selector-names
+    (syntax-rules ()
+      ((selector-names selectors (field ...) (name ...))
+        (define-values (name ...)
+          (enumerate-fields 1 selectors field ...)))
+      ((selector-names selectors fields (names ...) (_ getter) selector ...)
+        (selector-names selectors fields (names ... getter) selector ...))
+      ((selector-names selectors fields (names ...) (_ getter setter) selector ...)
+        (selector-names selectors fields (names ... getter setter) selector ...))))
+
+
+  (define-syntax define-record-type
+    (syntax-rules ()
+      ((define-record-type _
+         (constructor field ...)
+         pred
+         selectors ...)
+        (define type-id
+          (let ((id *next-type-id*))
+            (set! *next-type-id* (call-builtin + 1 *next-type-id*))))
+        (define (pred r)
+          (call-builtin eq? type-id (call-builtin peek r 0)))
+        (define (constructor field ...)
+          (define r (call-builtin alloc (macro-length (field ...))))
+          (call-builtin poke type-id r 0)
+          (set-arguments r 1 field ...)
+          r)
+        (selector-names (selectors ...) (field ...) () selectors ...)))))
-- 
cgit v1.3.1