[New Implementation of `define-record' from scsh
clinton@unknownlamer.org**20100330054753
 Ignore-this: 4f123d3a75809fa0c3d89757956bdcd7
 * From Scratch Using `syntax-case'
 * Does not define `copy-RECORD' (doing so would require using the
   struct protcol directly)
 * `disclose' method MUST be the final field in a defined record. All
   of the records in scsh itself conform to this.
] addfile ./module/scsh/define-record.scm
hunk ./module/scsh/define-record.scm 1
+;;; Reimplementation of define-record from scsh for Guile Facade
+;;; Copyright (c) 2010 Clinton Ebadi
+
+;;; Deficiences:
+;;; - copy-RECORD is not provided
+;;; - disclose method must be the last field specified
+;;; That should be the only thing
+
+(define-module (scsh define-record)
+  #:export (define-record))
+
+;;; Emulates the scsh printer behavior
+(define (make-record-printer printer)
+  (lambda (record port)
+    (let ((print-representation (printer record)))
+      (display "#{" port)
+      (display (car print-representation) port)
+      (let pl ((slots (cdr print-representation)))
+	(if (pair? slots)
+	    (begin
+	      (display " " port)
+	      (write (car slots) port)
+	      (pl (cdr slots)))))
+      (display "}" port))))
+
+(define-syntax define-record
+  (lambda (e)
+    (let ((expand-field (lambda (f)
+			  (syntax-case f ()
+			    ((fname) (syntax (field fname #f)))
+			    ((fname default) (syntax (field fname default)))
+			    (fname (syntax (field fname #f)))))))
+      (syntax-case e (disclose)
+	((_ name field0 field1 ... ((disclose x) body ...))
+	 (identifier? (syntax x))
+	 (with-syntax (((%fields ...)
+			(map expand-field (syntax (field0 field1 ...)))))
+	   (syntax
+	    (define-record* name (make-record-printer (lambda (x)
+							body ...))
+	      %fields ...))))
+	((_ name field0 field1 ...)
+	 (with-syntax (((%fields ...)
+			(map expand-field (syntax (field0 field1 ...)))))
+	   (syntax
+	    (define-record* name #f
+	      %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 printer (field field-name default) ...)
+	 (let ((%type-name (make-name "type/" (syntax name))))
+	   (with-syntax
+	       ((constructor (make-name "make-" (syntax name)))
+		(predicate (make-name (syntax name) "?"))
+		(name-string (symbol->string
+			      (syntax->datum (syntax name))))
+		((field-accessors ...)
+		 (map
+		  (lambda (f)
+		    (syntax-case f ()
+		      ((field-name default)
+		       #`(begin
+			   (define #,(make-name (syntax name)
+						":"
+						(syntax field-name))
+			     (record-accessor #,%type-name 'field-name))
+			   (define #,(make-name "set-"
+						(syntax name)
+						":"
+						(syntax field-name))
+			     (record-modifier #,%type-name 'field-name))
+			   (define #,(make-name "modify-"
+						(syntax name)
+						":"
+						(syntax field-name))
+			     (let ((rm (record-modifier #,%type-name 'field-name))
+				   (ra (record-accessor #,%type-name 'field-name)))
+			       (lambda (record closure)
+				 (rm record (closure (ra record))))))))))
+		  (syntax ((field-name default) ...)))))
+	     
+	     #`(begin
+		 (define #,%type-name (make-record-type name-string
+						     '(field-name ...)
+						     printer))
+
+		 ;; record-constructor involves a call to
+		 ;; primitive-eval--important to cache it
+		 (define constructor
+		   (let ((rc (record-constructor #,%type-name)))
+		     (lambda* (#:optional (field-name default) ...)
+			 (rc field-name ...))))
+	       
+		 (define predicate (record-predicate #,%type-name))
+		 	       
+		 field-accessors ...))))))))
+