From a6244ee560fd1b7e21ea9bcc30425956e018902d Mon Sep 17 00:00:00 2001
From: Andrew Whatson <whatson@gmail.com>
Date: Thu, 21 Jul 2022 23:00:03 +1000
Subject: [PATCH] Port define-node-type macro

---
 ps-compiler/node/node.scm | 53 +++++++++++++++++++++------------------
 1 file changed, 29 insertions(+), 24 deletions(-)

diff --git a/ps-compiler/node/node.scm b/ps-compiler/node/node.scm
index 6e34df1..1df9b6d 100644
--- a/ps-compiler/node/node.scm
+++ b/ps-compiler/node/node.scm
@@ -12,6 +12,10 @@
 ;;; Records to represent variables.
 
 (define-module (ps-compiler node node)
+  #:use-module (prescheme s48-defrecord)
+  #:use-module (prescheme record-discloser)
+  #:use-module (prescheme syntax-utils)
+  #:use-module (ps-compiler util syntax)
   #:export (variable? make-variable
             global-variable? make-global-variable
             variable-name set-variable-name!
@@ -428,34 +432,35 @@
 ;; Syntax for defining the different types of nodes.
 
 (define-syntax define-node-type
-  (lambda (form rename compare)
-    (let ((id (cadr form))
-          (slots (cddr form)))
-      (let ((pred (concatenate-symbol id '- 'node?)))
-        `(begin (define (,pred x)
-                  (eq? ',id (node-variant x)))
-                . ,(do ((i 0 (+ i 1))
-                        (s slots (cdr s))
-                        (r '() (let ((n (concatenate-symbol id '- (car s)))
-                                     (f (concatenate-symbol 'node-stuff- i)))
-                                 `((define-node-field ,n ,pred ,f)
-                                   . ,r))))
-                       ((null? s) (reverse r))))))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ id slots ...)
+       (let* ((pred (syntax-conc #'id '-node?))
+              (slots #'(slots ...))
+              (indexes (iota (length slots))))
+         #`(begin
+             (define (#,pred x)
+               (eq? 'id (node-variant x)))
+             #,@(map (lambda (slot i)
+                       (let* ((getter (syntax-conc #'id '- slot))
+                              (number (string->symbol (number->string i)))
+                              (field (datum->syntax slot (symbol-append 'node-stuff- number))))
+                         #`(define-node-field #,getter #,pred #,field)))
+                     slots indexes)))))))
 
 ;; These are used to rename the NODE-STUFF fields of particular node variants.
 
 (define-syntax define-node-field
-  (lambda (form rename compare)
-    (let ((id (cadr form))
-          (predicate (caddr form))
-          (field (cadddr form)))
-      `(begin
-         (define (,id node)
-           (,field (enforce ,predicate node)))
-         (define (,(concatenate-symbol 'set- id '!) node val)
-           (,(concatenate-symbol 'set- field '!)
-            (enforce ,predicate node)
-            val))))))
+  (lambda (x)
+    (syntax-case x ()
+      ((_ getter pred field)
+       (with-syntax ((setter (syntax-conc 'set- #'getter '!))
+                     (set-field (syntax-conc 'set- #'field '!)))
+         #'(begin
+             (define (getter node)
+               (field (enforce pred node)))
+             (define (setter node val)
+               (set-field (enforce pred node) val))))))))
 
 ;;-------------------------------------------------------------------------
 ;; literals