From 3cb1c509d88db5cf7199bd25d4fcfc5821ad4818 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Fri, 8 Mar 2019 21:55:40 +0100
Subject: A whole bunch of macro rewrites!

---
 util.scm | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 52 insertions(+), 5 deletions(-)

(limited to 'util.scm')

diff --git a/util.scm b/util.scm
index 8487806b..8cba8239 100644
--- a/util.scm
+++ b/util.scm
@@ -1,7 +1,9 @@
 (define-module (util)
   #:use-module (srfi srfi-1)
   #:export (destructure-lambda let-multi fold-lists catch-let
-                               for-each-in)
+                               for-each-in
+                               define-quick-record define-quick-record!)
+  #:replace (let*)
   )
 
 (define-public upstring->symbol (compose string->symbol string-upcase))
@@ -16,10 +18,6 @@
      (lambda (expr)
        (apply (lambda expr-list body ...) expr)))))
 
-#; 
-(map (destructure-lambda (a b) (+ a b))
-     (map list (iota 10) (iota 10 10)))
-
 (define-syntax let-multi
   (syntax-rules ()
       ((let-m identifiers lst body ...)
@@ -47,3 +45,52 @@
 
 (define-syntax-rule (for-each-in lst proc)
   (for-each proc lst))
+
+
+(define (class-name symb) (symbol-append '< symb '>))
+(define (constructor symb) (symbol-append 'make- symb))
+(define (pred symb) (symbol-append symb '?))
+
+(define (getter name symb) (symbol-append 'get- name '- symb))
+(define* (setter name symb #:optional bang?)
+  (symbol-append 'set- name '- symb (if bang? '! (symbol))))
+
+(define (%define-quick-record internal-define bang? name fields)
+  (let ((symb (gensym)))
+    `(begin (,internal-define ,(class-name name)
+             (,(constructor name) ,@fields)
+             ,(pred name)
+             ,@(map (lambda (f) `(,f ,(getter f symb) ,(setter f symb bang?)))
+                    fields))
+            ,@(map (lambda (f) `(define ,f (make-procedure-with-setter
+                                       ,(getter f symb) ,(setter f symb bang?))))
+                   fields))))
+
+(define-macro (define-quick-record name . fields)
+  (%define-quick-record '(@ (srfi srfi-9 gnu) define-immutable-record-type)
+                        #f name fields))
+
+(define-macro (define-quick-record! name . fields)
+  (%define-quick-record '(@ (srfi srfi-9) define-record-type)
+                        #t name fields))
+
+(define-syntax let*
+  (syntax-rules ()
+
+    ;; Base case
+    [(_ () body ...)
+     (begin body ...)]
+
+    ;; (let (((a b) '(1 2))) (list b a)) => (2 1)
+    [(_ (((k k* ...) list-value) rest ...)
+        body ...)
+     (apply (lambda (k k* ...)
+              (let* (rest ...)
+                    body ...))
+            list-value)]
+
+    ;; "Regular" case
+    [(_ ((k value) rest ...) body ...)
+     (let ((k value))
+       (let* (rest ...)
+        body ...))]))
-- 
cgit v1.2.3