[rnrs-records-procedural implementation
atsmyles@earthlink.net**20090723195645
 
 Implements the record-constructor code. untested.
 
 
] hunk ./compile-r6rs-libs 28
-  (path-expand* "libs/rnrs/" "exceptions.scm" "conditions.scm" "base.scm" "records.scm" "syntax-case.scm" "control.scm" "hashtables.scm" "lists.scm" "enumerations.scm" "arithmetic.scm" "eval.scm" "r5rs.scm" "mutable.scm"))
+  (path-expand* "libs/rnrs/" "exceptions.scm" "conditions.scm" "base.scm" "syntax-case.scm" "control.scm" "lists.scm" "records.scm" "hashtables.scm" "enumerations.scm" "arithmetic.scm" "eval.scm" "r5rs.scm" "mutable.scm"))
hunk ./libs/rnrs/records.scm 8
+    (rnrs lists)
+    (rnrs control)
hunk ./libs/rnrs/records.scm 11
+    (core records inspection) 
+    (only (core primitives) eval)
+    (only (gambit extensions) gensym)
hunk ./libs/rnrs/records.scm 23
-	(make-rtd 'record-constructor-descriptor '#((immutable rtd) (immutable pcd) (immutable protocol))))
+	(make-rtd 'record-constructor-descriptor '#((immutable rtd) (immutable pcd) (immutable protocol) (immutable maker))))
+  (define record-constructor-rtd (rtd-accessor record-constructor-descriptor 'rtd))
+  (define record-constructor-pcd (rtd-accessor record-constructor-descriptor 'pcd))
+  (define record-constructor-protocol (rtd-accessor record-constructor-descriptor 'protocol))
+  (define record-constructor-maker (rtd-accessor record-constructor-descriptor 'maker))
+  (define record-constructor-descriptor? (rtd-predicate record-constructor-descriptor))
hunk ./libs/rnrs/records.scm 30
-  (define make-record-constructor-descriptor (rtd-constructor record-constructor-descriptor))
+  (define make-record-constructor-descriptor
+     (let ((constructor (rtd-constructor record-constructor-descriptor))
+           (compose (lambda (f g) (lambda (x) (f (g x)))))
+	   (identity (lambda (f) f)))
+           
+	(lambda (rtd pcd protocol)
+           (define parent (rtd-parent rtd))
+	   (unless (rtd? rtd) (error 'make-record-constructor-descriptor "first argument must be a record-type-descriptor" rtd))
+	   (when (and (not parent) pcd) (error 'make-record-constructor-descriptor "Cannot set a parent-constructor-descriptor for a base type"))
+	   (unless (or (not pcd) (record-constructor-descriptor? pcd) (equal? parent (record-constructor-rtd pcd))) 
+		(error 'make-record-constructor-descriptor "parent constructor descriptor must be a record-constructor-descriptor of the parent rtd or #f" pcd))
+	   (unless (or (not protocol) (procedure? protocol)) (error 'make-record-constructor-descriptor "protocol must be a procedure or #f" protocol))
+			
hunk ./libs/rnrs/records.scm 44
-  (define record-constructor
-    (let ((rtd (rtd-accessor record-constructor-descriptor 'rtd))
-	  (pcd (rtd-accessor record-constructor-descriptor 'pcd))
-	  (protocol (rtd-accessor record-constructor-descriptor 'protocol))
-	  (rcd? (rtd-predicate record-constructor-descriptor)))
-      (lambda (rtc)
-	(define (make-record-constructor rtd pcd protocol)
-	  (cond
-	    ((and pcd protocol) (error "don't know how to deal with that yet"))
-	    (pcd (error "currently can't handle parent-constructor-descriptors"))
-	    (protocol (protocol (make-record-constructor rtd #f #f)))
-	    (else (rtd-constructor rtd))))
-	(if (rcd? rtc)
-	  (make-record-constructor (rtd rtc) (pcd rtc) (protocol rtc))))))
-)
+	  (let* ((pcd (if parent (or pcd (make-record-constructor-descriptor parent #f #f)) #f)) ;if there is a parent and a pcd, use that otherwise make a default one
+	         (protocol (compose (or protocol (default-constructor-protocol rtd)) (or (and pcd (record-constructor-protocol pcd)) identity)))
+		 (maker (constructor-maker rtd)))  	   
+	   (constructor rtd pcd protocol maker)))))
+
+  (define (gensyms l) (map (lambda (x) (gensym)) l))
+
+  (define (default-constructor-protocol rtd)
+	(let ((parent (rtd-parent rtd))
+	      (fields (gensyms (rtd-field-names rtd))))
+	   (if parent
+		(let ((parent-fields (gensyms (rtd-field-names parent))))
+		   (eval `(lambda (n) 
+				(lambda ,(append parent-fields fields) 
+					(let ((p (n ,@parent-fields)))
+					    (p ,@fields)))) '((rnrs base))))
+		(eval `(lambda (p) (lambda ,fields (p ,@fields))) '(rnrs base)))))
hunk ./libs/rnrs/records.scm 62
+  (define (constructor-maker rtd)
+     (let      ((constructor (gensym))
+		(fields (let loop ((rtd rtd)) (cons (rtd-field-names rtd) (if (rtd-parent rtd) (loop (rtd-parent rtd)) '())))))
+	(eval `(lambda (,constructor) ,(let loop ((fields fields))
+				    `(lambda ,(car fields) ,(if (pair? (cdr fields)) (loop (cdr fields)) (cons constructor (apply append fields))))))
+		'((rnrs base)))))
+		
+  (define (record-constructor rtc)
+      ((record-constructor-protocol rtc) ((record-constructor-maker rtc) (rtd-constructor (record-constructor-rtd rtc)))))
+#|
+  (define-syntax syntax-append
+      (syntax-rules ()
+	 ((syntax-append (field ...) (field2 ...) rest ...)
+	  (syntax-append (field ... field2 ...) rest ...))
+	 ((syntax-append (field ...) (field2 ...))
+	  (field ... field2 ...))
+	 ((syntax-append (field ...)) (field ...))))
+
+  (define-syntax constructor-maker
+	(lambda (x)
+	    (syntax-case x ()
+		((maker rtd)
+		 (let* ((all-rtds (reverse (let loop ((rtd (syntax->datum #'rtd)))
+
+					    (if (rtd-parent rtd) (append (list rtd) (loop (rtd-parent rtd)))
+					     (list rtd)))))
+			(field-clauses (map generate-temporaries (map rtd-field-names all-rtds)))
+			(constructor-clause (generate-temporaries (list 1))))
+	        	 #`(lambda constructor-clause 
+			    #,(let create-lambdas ((clauses field-clauses))
+		      		(if (pair? clauses)
+			  		#`(lambda #,(car field-clauses) #,(create-lambdas (cdr clauses)))
+			  		#`(syntax-append #,constructor-clause #,@field-clauses)))))))))
+|#
+				   
+)