More dynamically process keywords to `deftype' form.

1 files changed, 28 insertions, 10 deletions

diff --git a/src/guile/de-paul-records.scm b/src/guile/de-paul-records.scm
index 3639910..f626667 100644
--- a/src/guile/de-paul-records.scm
+++ b/src/guile/de-paul-records.scm
@@ -3,10 +3,10 @@
 ;;; Copyright (C) 2023, 2025 Wojtek Kosior <koszko@koszko.org>
 
 (define-module (de-paul-records)
-  #:use-module ((srfi srfi-1) #:select (append-map))
+  #:use-module ((srfi srfi-1) #:select (append-map fold))
   #:use-module ((srfi srfi-9 gnu)
                 #:select (define-immutable-record-type set-field set-fields))
-  #:use-module ((srfi srfi-26) #:select (cut))
+  #:use-module ((srfi srfi-26) #:select (cut cute))
   #:use-module ((ice-9 format) #:select (format))
   #:use-module ((ice-9 match) #:select (match match-lambda))
   #:use-module ((ice-9 match) #:prefix ice-9-match:)
@@ -76,10 +76,26 @@
     (export?  record-spec-export?  record-spec-set-export?)
     (finalize record-spec-finalize record-spec-set-finalize))
 
+  (define record-spec-field-proc
+    (compose (cute eval <> (resolve-module '(de-paul-records)))
+             string->symbol
+             (lambda (keyword fmt)
+               (format #f fmt (keyword->symbol keyword)))))
+
+  (define record-spec-getter
+    (cut record-spec-field-proc <> "record-spec-~a"))
+
+  (define record-spec-setter
+    (cut record-spec-field-proc <> "record-spec-set-~a"))
+
+  (define %bool-flag-field-keywords
+    '(#:export?))
+
   (define %null-record-spec
-    (set-fields (make-record-spec)
-      ((record-spec-fields) '())
-      ((record-spec-export?) 'false-by-default)))
+    (fold (lambda (keyword record)
+            ((record-spec-setter keyword) record 'false-by-default))
+          (record-spec-set-fields (make-record-spec) '())
+          %bool-flag-field-keywords))
 
   (define (syntax->record-spec x)
     (syntax-case x ()
@@ -93,10 +109,13 @@
               ((record-spec-name) #'record-name)
               ((record-spec-fields) (reverse (record-spec-fields
                                               record-spec)))))
-           ((#:export? export? . args-rest)
-            (eq? (record-spec-export? record-spec) 'false-by-default)
-            (loop (record-spec-set-export? record-spec
-                    (and (syntax->datum #'export?) #t))
+           ((bool-flag-keyword value . args-rest)
+            (let ((keyword (syntax->datum #'bool-flag-keyword)))
+              (and (memq keyword %bool-flag-field-keywords)
+                   (eq? ((record-spec-getter keyword) record-spec)
+                        'false-by-default)))
+            (loop ((record-spec-setter (syntax->datum #'bool-flag-keyword))
+                   record-spec (and (syntax->datum #'value) #t))
                   #'args-rest))
            ((#:finalize finalizer . args-rest)
             (not (record-spec-finalize record-spec))
@@ -398,7 +417,6 @@
 ;;; Local Variables:
 ;;; eval: (put 'format-identifiers 'scheme-indent-function 1)
 ;;; eval: (put 'record-spec-set-finalize 'scheme-indent-function 1)
-;;; eval: (put 'record-spec-set-export? 'scheme-indent-function 1)
 ;;; eval: (put 'record-spec-set-fields 'scheme-indent-function 1)
 ;;; eval: (put 'record-init-set-fields 'scheme-indent-function 1)
 ;;; End: