From 2f97b84fb92231e9d59b8ae1f13deb4801ee41d0 Mon Sep 17 00:00:00 2001
From: Clinton Ebadi <clinton@unknownlamer.org>
Date: Sun, 23 Nov 2014 21:55:42 -0500
Subject: [PATCH 1/1] Partial implementation of scsh define-record

---
 define-record.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 48 insertions(+)
 create mode 100644 define-record.scm

diff --git a/define-record.scm b/define-record.scm
new file mode 100644
index 0000000..19f1143
--- /dev/null
+++ b/define-record.scm
@@ -0,0 +1,48 @@
+(define-syntax define-record
+  (lambda (e)
+    (syntax-case e ()
+      ((_ name field0 field1 ...)
+       (with-syntax ((%fields
+		      (map (lambda (f)
+			     (syntax-case f ()
+			       ((fname) (syntax (field fname #f)))
+			       ((fname default) (syntax (field fname default)))
+			       (fname (syntax (field fname #f)))))
+			   (syntax (field0 field1 ...)))))
+	 (syntax
+	  (define-record* name
+	    %fields)))))))
+
+(define-syntax define-record*
+  (lambda (e)
+    (letrec ((make-name (lambda args
+			  (datum->syntax e
+			   (string->symbol
+			    (apply string-append
+				   (map (lambda (a)
+					  (if (string? a)
+					      a
+					      (symbol->string
+					       (syntax->datum a))))
+					args)))))))
+      (syntax-case e (field)
+	((_ name ((field field-name default) ...))
+	 #`(begin (define* (#,(make-name "make-" (syntax name))
+			    #:optional (field-name default) ...)
+		    (vector 'name field-name ...))
+		  #,@(let ((idx 0))
+		       (map (lambda (fname)
+			      (set! idx (1+ idx))
+			      #`(begin (define (#,(make-name (syntax name)
+							     ":"
+							     fname)
+						rec)
+					 (vector-ref rec #,idx))
+				       (define (#,(make-name "set-"
+							     (syntax name)
+							     ":"
+							     fname)
+						rec val)
+					 (vector-set! rec #,idx val))))
+			    (syntax (field-name ...))))))))))
+
-- 
2.20.1