Partial implementation of scsh define-record

diff --git a/define-record.scm b/define-record.scm
new file mode 100644 (file)
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 ...))))))))))
+