[srfi-99 fixes and additions
atsmyles@earthlink.net**20100410215123
 Ignore-this: df27e57fa3f8d527bb3f4b911ed5d589
 
 1. created the following functions
 rtd-map-all
 rtd-for-all
 rtd-deconstructor
 
 also fixed some bugs
] hunk ./srfi-99.scm 109
+;this is an extension function. Creates a generic destructor
+(define (rtd-deconstructor rtd . predicate)
+  (if (rtd? rtd)
+  (let ((predicate? (if (null? predicate) (rtd-predicate rtd) (car predicate)))
+	(rtd-indexer (eval `(lambda (field)
+		(case field
+			,@(reverse (rtd-map-all rtd (lambda (i name . rest) `((,name) ,(+ i 1)))))))))
+	(accessor (if (rtd-sealed? rtd) ##direct-structure-ref ##structure-ref))
+	(decons (lambda (obj) (let ((result (##subvector obj 1 (##vector-length obj)))) (##subtype-set! result 5 #|boxvalues type|#) result))))
+  (lambda (obj . fields)
+	(cond
+	    ((not (predicate? obj))(assertion-violation 'rtd-deconstructor (string-append "First argument must be of type " (symbol->string (rtd-name rtd))) obj))
+	    ((null? fields) (decons obj)) ;(apply values (rtd-map-all rtd (lambda (i . rest) (accessor obj (+ i 1) rtd #f)))))
+	    ((null? (cdr fields)) (values (accessor obj (rtd-indexer (car fields)) rtd #f)))
+	    (else (apply values (map (lambda (field) (accessor obj (rtd-indexer field) rtd #f)) fields))))))
+  (assertion-violation 'rtd-deconstructor "first argument must be a record type descriptor" rtd)))
+		
hunk ./srfi-99.scm 139
-    (assertion-violation 'rtd-accessor "first argument must be an record type descriptor" rtd)))
+    (assertion-violation 'rtd-accessor "first argument must be a record type descriptor" rtd)))
hunk ./srfi-99.scm 183
+  (define offset (##type-field-count (rtd-parent rtd)))
hunk ./srfi-99.scm 188
-	  (proc i (vector-ref fields i) (vector-ref fields (+ i 1)) (vector-ref fields (+ i 2)))
+	  (proc (+ offset (/ i 3)) (vector-ref fields i) (vector-ref fields (+ i 1)) (vector-ref fields (+ i 2)))
hunk ./srfi-99.scm 206
-;proc is (lambda (index name init flags))
+
+;proc is (lambda (index name flags init))
hunk ./srfi-99.scm 210
-  (list->vector (rtd-map (##type-fields rtd) (lambda field (cadr field)))))
+  (list->vector (rtd-map rtd (lambda (i name . rest) name))))
+
+(define (rtd-map-all rtd proc)
+   (if (rtd-parent rtd)
+      (append (rtd-map-all (rtd-parent rtd) proc) (rtd-map rtd proc))
+      (rtd-map rtd proc)))
hunk ./srfi-99.scm 217
+(define (rtd-for-all rtd proc)
+    (if (rtd-parent rtd) (rtd-for-all (rtd-parent rtd) proc)) 
+	(rtd-for-each rtd proc)) 
hunk ./srfi-99.scm 222
-  (define (all-field-names rtd)
-    (if (rtd? rtd)
-    	(append (rtd-map rtd (lambda field (cadr field)) #f) (all-field-names (rtd-parent rtd)))
-	'()))
-  (list->vector (reverse (all-field-names rtd))))
+  (list->vector (rtd-map-all rtd (lambda (i name . rest) name))))