[Partial reimplementation of scsh `define-record'
clinton@unknownlamer.org**20100328085406
 Ignore-this: e3ce9271b1742aec72e5dc8edfd17a11
 * Proof of concept (look ma! after hours of effort I appear to have
   attained a fleeting grasp on how to use `syntax-case')
 * Needs to define `modify-FOO:BAR' and 'copy-FOO'
 * Uses vectors; should probably use Guile records instead
 * Intentionally does not support methods (`disclose' was the only
   supported one and is of questionable value given that guile-scsh
   just ignores the declaration)
] addfile ./define-record.scm
hunk ./define-record.scm 1
+(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 ...))))))))))
+