[2008-08-22
atsmyles@earthlink.net**20080822221609] hunk ./libs/err5rs/records.scm 1
-(library (err5rs records procedural)
-	 (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
-(library (err5rs records inspection)
-	 (export record? record-rtd rtd-name rtd-parent rtd-feild-names rtd-all-field-names rtd-field-mutable?)
-(library (err5rs records syntactic)
-	 (export define-record-type)
-	 (import (err5rs records procedural))
rmfile ./libs/err5rs/records.scm
rmdir ./libs/err5rs
hunk ./compat-gambit.scm 56
-;; The best we can do in r5rs is make these no-ops
-; gambit already defines these
-;(define (file-exists? fn) #f)
-;(define (delete-file fn) (values))
hunk ./compat-gambit.scm 57
-(define (make-record-type-descriptor name parent uid sealed? opaque? fields)
-  (define (parse-fields fields)
-    (let* ((field-count (vector-length fields))
-	  (result (make-vector (* field-count 3))))
-      (let process-fields ((i 0))
-	    (if (not (< i field-count)) result
-	    ;gambit has other attributes of fields such as if they are printable and it's contribution to equality
-	    (let* ((field (vector-ref fields i))
-		  (mutable? (if (eq? 'mutable (car field)) 0 2))
-		  (field-name (cadr field))
-		  (j (* i 3)))
-	      (vector-set! result j field-name)
-	      (vector-set! result (+ j 1) mutable?)
-	      (vector-set! result (+ j 2) #f); used for setting initial value
-	      (process-fields (+ i 1)))))))
hunk ./compat-gambit.scm 58
-
-  (let* ((flags (##fixnum.+ (if opaque? 1 0) (if sealed? 0 2)))
-	 (uid (if uid uid (make-uninterned-symbol (symbol->string name)))))
-	 
-  (##structure ##type-type uid name flags parent (parse-fields fields))))
-
-(define record-type-descriptor? ##type?)
-(define (record-type-name rtd) (if (record-type-descriptor? rtd) (##type-name rtd)))
-(define (record-type-parent rtd) (if (record-type-descriptor? rtd) (##type-parent rtd)))
-(define (record-type-uid rtd) (if (record-type-descriptor? rtd) (##type-id rtd)))
-(define (record-type-sealed? rtd) (not (fxbit-set? (##type-flags rtd) 1)))
-(define (record-type-opaque? rtd) (fxbit-set? (##type-flags rtd) 0))
-(define (record-type-generative? rtd) (uninterned-symbol? (record-type-uid rtd)))
-
-(define (record-type-field-names rtd)
-  (let* ((fields (##type-fields rtd))
-	 (field-count (/ (vector-length fields) 3))
-	 (result (make-vector field-count)))
-    (loop process-field-names ((i 0))
-	  (if (< i field-count)
-	    (begin
-	      (vector-set! result i (vector-ref fields (* i 3)))
-	      (process-field-names (+ i 1)))
-	    result))))
-
-(define (record-type-all-field-names rtd)
-  (define (loop rtd othernames)
-    (let ((parent (rtd-parent rtd))
-	  (names (append (vector->list
-			   (rtd-field-names rtd))
-			 othernames)))
-      (if parent
-	(loop parent names)
-	(list->vector names))))
-  (loop rtd '()))
-
-(define (record-field-mutable? rtd k)
-  (if (record-type-descriptor? rtd)
-      ;k doesn't need to be incremented in this case
-      (fxbit-set? (vector-ref (##type-fields rtd) (+ (* k 3) 1)) 1))
-      )
-
-
-
-(define-record-type record-constructor-descriptor
-		    (make-record-constructor-descriptor rtd parent-constructor-descriptor protocol)
-		    record-constructor-descriptor?
-		    (rtd record-constructor-rtd)
-		    (parent-constructor-descriptor record-constructor-parent)
-		    (protocol record-constructor-protocol))
-
-
-
-
-(define (record-predicate rtd)
-  (let ((uid (record-type-uid rtd)))
-  (if (record-type-sealed? rtd)
-    (lambda (obj) (##structure-direct-instance-of? obj uid))
-    (lambda (obj) (##structure-instance-of? obj uid)))))
-
-
-(define (record-accessor rtd k)
-   (let ((k (+ k 1)))
-     (if (record-type-sealed? rtd)
-       (lambda (obj) (##structure-direct-ref obj k rtd #f))
-       (lambda (obj) (##structure-ref obj k rtd #f)))))
-    
-
-(define (rtd-accessor rtd field)
-  (if (not rtd) #f
-    (let* ((fields (##type-fields rtd))
-	   (field-count (/ (vector-length fields) 3)))
-      (loop process-field-names ((i 0))
-	    (if (< i field-count)
-	      (if (eq (vector-ref fields (* i 3)) field)
-		(record-accessor rtd i)
-		(process-field-names (+ i 1)))
-	      (rtd-accessor (record-type-parent rtd) field))))))
-
-
-(define (record-mutator rtd k)
-  (if (record-field-mutable? rtd k)
-    (let ((k (+ k 1)))
-       (if (record-type-sealed? rtd)
-	 (lambda (obj value) (##structure-direct-set! obj value k rtd #f))
-	 (lambda (obj value) (##structure-set! obj value k rtd #f))))))
-
-(define (rtd-mutator rtd field)
-  (if (not rtd) #f
-    (let* ((fields (##type-fields rtd))
-	   (field-count (/ (vector-length fields) 3)))
-      (loop process-field-names ((i 0))
-	    (if (< i field-count)
-	      (if (eq (vector-ref fields (* i 3)) field)
-		(record-mutator rtd i)
-		(process-field-names (+ i 1)))
-	      (rtd-mutator (record-type-parent rtd) field))))))
-
-(define (record? obj)
-  (and (structure? obj) (not (record-type-opaque? (##structure-type obj)))))
-
-(define (record-rtd obj)
-  (if (record? obj) (##structure-type obj)
-    ;TODO raise exception
-    ))
-
-(define (rtd-constructor rtd . rest) 
-      ; Computes permutation and allocates permutation buffer
-      ; when the constructor is created, not when the constructor
-      ; is called.  More error checking is recommended.
-
-      (define (make-constructor fieldspecs allnames maker)
-        (let* ((k (length fieldspecs))
-               (n (length allnames))
-               (buffer (make-vector n 'some-unspecified-value))
-               (reverse-all-names (reverse allnames)))
-
-          (define (position fieldname)
-            (let ((names (memq fieldname reverse-all-names)))
-              (assert names)
-              (- (length names) 1)))
-
-          (let ((indexes (map position fieldspecs)))
-
-            ; The following can be made quite efficient by
-            ; hand-coding it in some lower-level language,
-            ; e.g. Larceny's mal.  Even case-lambda would
-            ; be good enough in most systems.
-
-            (lambda args
-              (assert (= (length args) k))
-              (for-each (lambda (arg posn)
-                          (vector-set! buffer posn arg))
-                        args indexes)
-              (apply maker (vector->list buffer))))))
- 
-  (if (null? rest) (lambda fields (apply ##structure rtd fields))
-    (begin (assert (null? (cdr rest)))
-    	(make-constructor
-            (vector->list (car rest))
-            (vector->list (record-type-all-field-names rtd))
-            (rtd-constructor rtd)))))
-
-
-;TODO This needs work to fully follow spec 
-(define (record-constructor 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 (lambda fields (apply ##structure rtd fields)))))
-  (if (record-type-descriptor? rtc) (make-record-constructor rtc #f #f)
-  (make-record-constructor (record-constructor-rtd rtc) 
-			   (record-constructor-parent rtc) 
-			   (record-constructor-protocol rtc))))
-;extra, used by code outside of r6rs
-;procdural creation of conditions. the fields is just a list of fields. name and parent are the same as 
-;make-record-type-descriptor
-
-(define (make-condition-type name parent fields)
-  (make-record-type-descriptor name parent #f #f #f (list->vector (map (lambda (x) (list 'immutable x))
-							 (vector->list fields)))))
-
-;used to create your own simple conditions
-(define &condition (make-condition-type '&condition #f '#()))
-(define &compound (make-condition-type '&compound &condition '#(conditions)))
-(define &serious (make-condition-type '&serious &condition '#()))
-(define &violation (make-condition-type '&violation &serious '#()))
-(define &assertion (make-condition-type '&assertion &violation '#()))
-(define &who (make-condition-type '&who &condition '#(who)))
-(define &message (make-condition-type '&message &condition '#(message)))
-(define &irritants (make-condition-type '&irritants &condition '#(irritants)))
-(define &syntax (make-condition-type '&syntax &violation '#(form subform)))
-(define &trace (make-condition-type '&trace &condition '#(trace)))
-    
-;need to define raise for your implementation
-
-(define condition
-  (let ((constructor (record-constructor &compound)))
-    (lambda conditions
-      (cond
-	((and (pair? conditions) (null? (cdr conditions))) (car conditions))
-	(else (constructor conditions))))))
-
-(define (simple-conditions condition)
-  (let ((compound? (record-predicate &compound))
-	(conditions (record-accessor &compound 0)))
-    (lambda (condition)
-      (cond
-	((compound? condition) (conditions condition))
-	(else (list condition))))))
-
-(define make-who-condition (record-constructor &who))
-(define make-message-condition (record-constructor &message))
-(define make-irritants-condition (record-constructor &irritants))
-(define make-syntax-violation (record-constructor &syntax))
-;constructors for conditions with no fields are treated like singletons
-(define make-assertion-violation
-  (let ((assertion-violation ((record-constructor &assertion))))
-    (lambda () assertion-violation)))
-
-(define (assertion-violation who message . irritants)
-  (raise 
-    (if who
-    (condition (make-who-condition who) 
-	       (make-message-condition message) 
-	       (make-irritants-condition irritants)
-	       (make-assertion-violation))
-    (condition (make-message-condition message) 
-	       (make-irritants-condition irritants)
-	       (make-assertion-violation)))))
hunk ./compile 22
-   (path-expand* "libs/gambit/" "io.readtable.scm" "io.scm" "threads.scm" "time.scm" "will.scm" "exceptions.scm" "files.scm" "programs.scm" "extensions.scm" "bytevectors.scm" "debug.scm"))
+   (path-expand* "libs/gambit/" "io.readtable.scm" "io.scm" "threads.scm" "time.scm" "will.scm" "exceptions.scm" "files.scm" "programs.scm" "extensions.scm" "bytevectors.scm" "debug.scm" "records.scm"))
hunk ./compile 25
-     (path-expand* "libs/srfi/" "srfi-0.scm" "srfi-2.scm" "srfi-21.scm" "srfi-18.scm" "srfi-23.scm" "srfi-27.scm" "srfi-39.scm" "srfi-4.scm" "srfi-6.scm" "srfi-8.scm" "srfi-88.scm" "srfi-89.scm" "srfi-9.scm"))
+     (path-expand* "libs/srfi/" "srfi-0.scm" "srfi-2.scm" "srfi-21.scm" "srfi-18.scm" "srfi-23.scm" "srfi-27.scm" "srfi-39.scm" "srfi-4.scm" "srfi-6.scm" "srfi-8.scm" "srfi-88.scm" "srfi-89.scm" "srfi-99.scm" "srfi-9.scm"))
hunk ./compile 27
-(define standard-libraries-base (path-expand* "libs/rnrs/" "core.scm" "exceptions.scm" "records.scm" "conditions.scm" "base.scm"))
+(define standard-libraries-base (path-expand* "libs/rnrs/" "core.scm" "exceptions.scm" "conditions.scm" "base.scm"))
hunk ./compile 30
-  (path-expand* "libs/rnrs/" "syntax-case.scm" "control.scm" "arithmetic.scm" "bytevectors.scm" "io.scm" "unicode.scm" "files.scm" "lists.scm" "sorting.scm" "programs.scm" "rnrs.scm" "mutable.scm" "eval.scm" "r5rs.scm" "load.scm"))
+  (path-expand* "libs/rnrs/" "records.scm" "syntax-case.scm" "control.scm" "arithmetic.scm" "bytevectors.scm" "io.scm" "unicode.scm" "files.scm" "lists.scm" "sorting.scm" "programs.scm" "rnrs.scm" "mutable.scm" "eval.scm" "r5rs.scm" "load.scm"))
hunk ./compile 44
+(load "err5rs-records-inspection.scm")
+(load "err5rs-records-procedural.scm")
+(load "primitives.scm")
hunk ./compile 62
+				(path-expand "err5rs-records-inspection.scm") " "
+  				(path-expand "err5rs-records-procedural.scm") " "
+				(path-expand "primitives.scm") " "
addfile ./err5rs-records-inspection.scm
hunk ./err5rs-records-inspection.scm 1
+;;;===============================================================================
+;;;
+;;; Gambit ERR5RS record inspection
+;;;
+;;;
+;;; by Arthur T Smyles
+;;;===============================================================================
+
+(define (record? obj)
+  (and (structure? obj) (not (record-type-opaque? (##structure-type obj)))))
+
+(define (record-rtd obj)
+  (if (record? obj) (##structure-type obj)
+    ;TODO raise exception
+    ))
+
+(define (rtd-name rtd) (if (rtd? rtd) (##type-name rtd)))
+(define (rtd-parent rtd) (if (rtd? rtd) (##type-super rtd)))
+;ERR5RS standard extensions
+(define (rtd-uid rtd) (if (rtd? rtd) (##type-id rtd)))
+(define (rtd-sealed? rtd) (if (rtd? rtd) (not (fxbit-set? (##type-flags rtd) 1))))
+(define (rtd-opaque? rtd) (if (rtd? rtd) (fxbit-set? (##type-flags rtd) 0)))
+
+
+;(define (rtd-field-names rtd)
+;  (let* ((fields (##type-fields rtd))
+;	 (result (make-vector (/ (vector-length fields) 3))))
+;    (let process-field-names ((i 0)
+;			      (l (vector-length result)))
+;      (if (< i l)
+;	(begin
+;	   (vector-set! result i (vector-ref fields (* i 3)))
+;	   (process-field-names (+ i 1)))
+;	 result))))
+
+(define (rtd-field-flag-printable? flags) (not (fxbit-set? flags 0)))
+(define (rtd-field-flag-mutable? flags) (not (fxbit-set? flags 1)))
+(define (rtd-field-flag-equality? flags) (not (fxbit-set? flags 2)))
+(define (rtd-field-flag-init? flags) (not (fxbit-set? flags 3)))
+
+
+
+;calls a procedure for each field  	
+(define (rtd-map rtd proc . rest)
+  (define direction (or (null? rest) (car rest)))
+  (define fields (##type-fields rtd))
+  (define compare (if direction < >=))
+  (define increment (if direction  + -))
+    (let process-field ((i (if direction 0 (- (vector-length fields) 3)))
+			(l (if direction (vector-length fields) 0)))
+      (if (compare i l)
+	(cons
+	  (proc i (vector-ref fields i) (vector-ref fields (+ i 1)) (vector-ref fields (+ i 2)))
+	  (process-field (increment i 3) l))
+	'())))
+
+(define (rtd-for-each rtd proc . rest)
+  (define direction (or (null? rest) (car rest)))
+  (define fields (##type-fields rtd))
+  (define compare (if direction < >=))
+  (define increment (if direction  + -))
+  (define offset (##type-field-count (rtd-parent rtd)))
+    (let process-field ((i (if direction 0 (- (vector-length fields) 3)))
+			(l (if direction (vector-length fields) 0)))
+      (if (compare i l)
+	(begin
+	  (proc (+ offset (/ i 3)) (vector-ref fields i) (vector-ref fields (+ i 1)) (vector-ref fields (+ i 2)))
+	  (process-field (increment i 3) l))
+	(void))))
+
+;proc is (lambda (index name init flags))
+
+(define (rtd-field-names rtd)
+  (list->vector (rtd-map (##type-fields rtd) (lambda field (cadr field)))))
+
+
+(define (rtd-all-field-names rtd)
+  (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))))
+
+
+
+(define (rtd-field-mutable? rtd field)
+  (if (rtd? rtd)
+    (call/cc (lambda (k)
+    	(rtd-for-each rtd
+		      (lambda (i name flags init)
+			(if (eq? name field) (k (rtd-field-flag-mutable? flags))))))))) 
+
+
+
+
addfile ./err5rs-records-procedural.scm
hunk ./err5rs-records-procedural.scm 1
+;;;===============================================================================
+;;;
+;;; Gambit ERR5RS records procedural implementation (with r6rs optional extensions
+;;;
+;;; Arthur T Smyles
+;;;===============================================================================
+
+(define (make-rtd name fieldspecs . rest)
+  (define parent (and (pair? rest) (car rest)))
+  (define sealed? (and (pair? rest) (memq 'sealed rest) #t))
+  (define opaque? (and (pair? rest) (memq 'opaque rest) #t))
+  (define uid (let [(uid (and (pair? rest) (memq 'uid rest)))] (and uid (car uid))))
+  (define (parse-fields fields)
+    (define (make-field-flags mutable? printable? equality? init?)
+      (+ (if printable? 0 1)
+	 (if mutable? 0 2)
+	 (if equality? 0 4)
+	 (if init? 0 8)))
+    (let* ((field-count (vector-length fields))
+	  (result (make-vector (* field-count 3))))
+      (let process-fields ((i 0))
+	    (if (not (< i field-count)) result
+	    ;gambit has other attributes for fields such as if they are printable and it's contribution to equality
+	    (let* ((field (vector-ref fields i))
+		  (flags (make-field-flags (or (symbol? field) (eq? 'mutable (car field))) #t #t #f))
+		  (field-name (if (symbol? field) field (cadr field)))
+		  (j (* i 3)))
+	      (vector-set! result j field-name)
+	      (vector-set! result (+ j 1) flags)
+	      (vector-set! result (+ j 2) #f); used for setting initial value
+	      (process-fields (+ i 1)))))))
+   (let* ((flags (##fixnum.+ (if opaque? 1 0) (if sealed? 0 2)))
+	  (uid (if uid uid (make-uninterned-symbol (symbol->string name)))))
+
+     (##structure ##type-type uid name flags parent (parse-fields fieldspecs))))
+
+
+(define rtd? ##type?)
+
+(define (rtd-constructor rtd . rest) 
+      ; Computes permutation and allocates permutation buffer
+      ; when the constructor is created, not when the constructor
+      ; is called.  More error checking is recommended.
+
+      (define (make-constructor fieldspecs allnames maker)
+        (let* ((k (length fieldspecs))
+               (n (length allnames))
+               (buffer (make-vector n 'some-unspecified-value))
+               (reverse-all-names (reverse allnames)))
+
+          (define (position fieldname)
+            (let ((names (memq fieldname reverse-all-names)))
+              (assert names)
+              (- (length names) 1)))
+
+          (let ((indexes (map position fieldspecs)))
+
+            ; The following can be made quite efficient by
+            ; hand-coding it in some lower-level language,
+            ; e.g. Larceny's mal.  Even case-lambda would
+            ; be good enough in most systems.
+
+            (lambda args
+              (assert (= (length args) k))
+              (for-each (lambda (arg posn)
+                          (vector-set! buffer posn arg))
+                        args indexes)
+              (apply maker (vector->list buffer))))))
+ 
+  (if (null? rest) (lambda fields (apply ##structure rtd fields))
+    (begin (assert (null? (cdr rest)))
+    	(make-constructor
+            (vector->list (car rest))
+            (vector->list (record-type-all-field-names rtd))
+            (rtd-constructor rtd)))))
+
+(define (rtd-predicate rtd)
+  (let ((uid (rtd-uid rtd)))
+  (if (rtd-sealed? rtd)
+    (lambda (obj) (##structure-direct-instance-of? obj uid))
+    (lambda (obj) (##structure-instance-of? obj uid)))))
+
+
+(define (rtd-accessor rtd field)
+  (if (rtd? rtd)
+    (call/cc 
+      (lambda (return)
+        (rtd-for-each rtd 
+	    (lambda (i name . rest)
+	      (if (eq? field name)
+		(let ((index (+ i 1)))
+		(if (rtd-sealed? rtd)
+		  (return (lambda (obj) (##structure-direct-ref obj index rtd #f)))
+		  (return (lambda (obj) (##structure-ref obj index rtd #f))))))))
+	(return (rtd-accessor (rtd-parent rtd) field))))
+    #f))
+
+(define (rtd-mutator rtd field)
+  (if (rtd? rtd)
+    (call/cc
+      (lambda (return)
+	(rtd-for-each rtd
+          (lambda (i name flags init)
+	    (if (and (eq? name field) (rtd-field-flag-mutable? flags))
+	      (let ((index (+ i 1)))
+	      (if (rtd-sealed? rtd)
+		(return (lambda (obj value) (##structure-direct-set! obj value index rtd #f)))
+		(return (lambda (obj value) (##structure-set! obj value index rtd #f))))))))
+	(return (rtd-mutator (rtd-parent rtd) field))))
+    #f))
+	
hunk ./expander.scm 29
-;;;  - Procedures make-record-type-descriptor, make-record-constructor-descriptor,
-;;;    record-constructor, record-predicate and record-accessor.
+;;;  - ERR5RS Procedures make-rtd, rtd-constructor, rtd-predicate, and rtd-accessor
hunk ./expander.scm 375
-          (make-record-type-descriptor 'identifier #f #f #f #f
-                                       '#((immutable name)
+          (make-rtd 'identifier '#((immutable name)
hunk ./expander.scm 380
-         (make-identifier
-          (record-constructor (make-record-constructor-descriptor :identifier #f #f))))
+         (make-identifier (rtd-constructor :identifier)))
hunk ./expander.scm 385
-    (define identifier?         (record-predicate :identifier))
-    (define id-name             (record-accessor :identifier 0))
-    (define id-colors           (record-accessor :identifier 1))
-    (define id-transformer-envs (record-accessor :identifier 2))
-    (define id-displacement     (record-accessor :identifier 3))
-    (define id-maybe-library    (record-accessor :identifier 4))
+    (define identifier?         (rtd-predicate :identifier))
+    (define id-name             (rtd-accessor :identifier 'name))
+    (define id-colors           (rtd-accessor :identifier 'colors))
+    (define id-transformer-envs (rtd-accessor :identifier 'transformer-envs))
+    (define id-displacement     (rtd-accessor :identifier 'displacement))
+    (define id-maybe-library    (rtd-accessor :identifier 'maybe-library))
hunk ./expander.scm 2101
-      (let ((constructor (record-constructor &trace)))
+      (let ((constructor (rtd-constructor &trace)))
addfile ./libs/gambit/records.scm
hunk ./libs/gambit/records.scm 1
+;gambit records is a superset of srfi 99
+(library (gambit records procedural)
+	 (export make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)
+	 (import (primitives make-rtd rtd? rtd-constructor rtd-predicate rtd-accessor rtd-mutator)))
+
+(library (gambit records inspection)
+	 (export record? record-rtd rtd-name rtd-parent rtd-field-names rtd-all-field-names rtd-field-mutable?
+		 rtd-uid rtd-sealed? rtd-opaque? rtd-field-flag-printable? rtd-field-flag-mutable? 
+		 rtd-field-flag-equality rtd-field-flag-init rtd-map rtd-for-each)
+	 (import (primitives record? record-rtd rtd-name rtd-parent rtd-field-names rtd-all-field-names rtd-field-mutable?
+		 rtd-uid rtd-sealed? rtd-opaque? rtd-field-flag-printable? rtd-field-flag-mutable? 
+		 rtd-field-flag-equality rtd-field-flag-init rtd-map rtd-for-each)))
hunk ./libs/rnrs/conditions.scm 22
-	   (for (only (rnrs records procedural) 
-		      record-constructor record-predicate record-accessor) expand run)
-	   (primitives make-condition-type pair? null? car cdr list
+	   (for (only (gambit records procedural) 
+		      make-rtd rtd-constructor rtd-predicate rtd-accessor) expand run)
+	   (primitives pair? null? car cdr list
hunk ./libs/rnrs/conditions.scm 33
-		   (define condition-type (make-condition-type 'condition-type supertype '#(field ...)))
-		   ;using the non-standard record-constructor with condition-type only
-		   (define constructor (record-constructor condition-type))
+		   (define condition-type (make-rtd 'condition-type '#((immutable field) ...) supertype))
+		   (define constructor (rtd-constructor condition-type))
hunk ./libs/rnrs/conditions.scm 37
-							(record-accessor condition-type 'field))) ...))))
+							(rtd-accessor condition-type 'field))) ...))))
hunk ./libs/rnrs/conditions.scm 39
-	 (define condition? (record-predicate &condition))
+	 (define condition? (rtd-predicate &condition))
hunk ./libs/rnrs/conditions.scm 42
-	   (define predicate (record-predicate rtd))
+	   (define predicate (rtd-predicate rtd))
hunk ./libs/rnrs/conditions.scm 51
-	   (define predicate (record-predicate rtd))
+	   (define predicate (rtd-predicate rtd))
hunk ./libs/rnrs/conditions.scm 61
-	 (define make-serious-condition (record-constructor &serious))
+	 (define make-serious-condition (rtd-constructor &serious))
hunk ./libs/rnrs/conditions.scm 64
-	 (define make-violation (record-constructor &violation))
+	 (define make-violation (rtd-constructor &violation))
hunk ./libs/rnrs/conditions.scm 70
-	 (define condition-who (condition-accessor &who (record-accessor &who 0)))
+	 (define condition-who (condition-accessor &who (rtd-accessor &who 'who)))
hunk ./libs/rnrs/conditions.scm 72
-	 (define condition-message (condition-accessor &message (record-accessor &message 0)))
+	 (define condition-message (condition-accessor &message (rtd-accessor &message 'message)))
hunk ./libs/rnrs/conditions.scm 74
-	 (define condition-irritants (condition-accessor &irritants (record-accessor &irritants 0)))
+	 (define condition-irritants (condition-accessor &irritants (rtd-accessor &irritants 'irritants)))
hunk ./libs/rnrs/conditions.scm 82
-	 (define syntax-violation-form (condition-accessor &syntax (record-accessor &syntax 0)))
-	 (define syntax-violation-subform (condition-accessor &syntax (record-accessor &syntax 1)))
+	 (define syntax-violation-form (condition-accessor &syntax (rtd-accessor &syntax 'form)))
+	 (define syntax-violation-subform (condition-accessor &syntax (rtd-accessor &syntax 'subform)))
hunk ./libs/rnrs/records.scm 3
-   make-record-type-descriptor record-type-descriptor?
+   make-record-type-descriptor (rename (rtd? record-type-descriptor?) (rtd-predicate record-predicate))
hunk ./libs/rnrs/records.scm 5
-   record-predicate record-accessor record-mutator)
-  (import
-   (primitives
-    make-record-type-descriptor record-type-descriptor?
-    make-record-constructor-descriptor record-constructor
-    record-predicate record-accessor record-mutator)))
+   record-accessor record-mutator)
+  (import 
+    (rnrs base)
+    (gambit records procedural)
+    (primitives record-accessor record-mutator))
+
+
+   (define (make-record-type-descriptor name parent uid sealed? opaque? fields)
+     (if uid
+       (make-rtd name fields parent (and sealed? 'sealed) (and opaque? 'opaque) 'uid uid)
+       (make-rtd name fields parent (and sealed? 'sealed) (and opaque? 'opaque) 'uid uid)))
+ 
+  (define record-constructor-descriptor 
+	(make-rtd 'record-constructor-descriptor '#((immutable rtd) (immutable pcd) (immutable protocol))))
+
+  (define make-record-constructor-descriptor (rtd-constructor record-constructor-descriptor))
+
+  (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))))))
+)
hunk ./libs/rnrs/records.scm 44
-   (primitives
-    record? record-rtd record-type-name record-type-parent record-type-uid
-    record-type-generative? record-type-sealed? record-type-opaque?
-    record-type-field-names record-field-mutable?)))
+    (rnrs base)
+    (only (gambit extensions) uninterned-symbol?)
+    (gambit records inspection)
+    (primitives record-field-mutable?))
+    
+    (define record-type-name rtd-name)
+    (define record-type-parent rtd-parent)
+    (define record-type-uid rtd-uid)
+    (define record-type-sealed? rtd-sealed?)
+    (define record-type-opaque? rtd-opaque?)
+    (define record-type-field-names rtd-field-names)
+    (define (record-type-generative? rtd) (uninterned-symbol? (rtd-uid rtd))))
hunk ./libs/srfi/srfi-0.scm 3
-(library (srfi-0) 
+(library (srfi :0) 
hunk ./libs/srfi/srfi-18.scm 2
-(library (srfi-18) 
+(library (srfi :18 multithreading) 
hunk ./libs/srfi/srfi-18.scm 4
-	 (import (srfi-21))) 
+	 (import (srfi :21 real-time-multithreading)))
hunk ./libs/srfi/srfi-18.scm 6
+(library (srfi :18) 
+	 (export current-thread make-thread thread?  thread-name thread-specific thread-specific-set!  thread-start!  thread-sleep!  thread-yield!  thread-terminate!  thread-join!  make-mutex mutex?  mutex-name mutex-specific mutex-specific-set!  mutex-state mutex-lock!  mutex-unlock!  condition-variable?  make-condition-variable condition-variable-name condition-variable-specific condition-variable-specific-set!  condition-variable-signal!  condition-variable-broadcast!  current-time time? time->seconds seconds->time current-exception-handler with-exception-handler raise join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason)
+	 (import (srfi :18 multithreading)))
hunk ./libs/srfi/srfi-2.scm 15
-(library (srfi-2)
+(library (srfi :2 and-let*)
hunk ./libs/srfi/srfi-2.scm 44
+
+(library (srfi :2) (export and-let*) (import (srfi :2 and-let*)))
+
hunk ./libs/srfi/srfi-21.scm 2
-(library (srfi-21) 
+(library (srfi :21 real-time-multithreading) 
hunk ./libs/srfi/srfi-21.scm 18
+(library (srfi :21) 
+	 (export 
+	   ;;threads
+	   current-thread make-thread thread?  thread-name thread-specific thread-specific-set!  thread-base-priority thread-base-priority-set! thread-priority-boost thread-priority-boost-set! thread-quantum thread-quantum-set! thread-start!  thread-sleep!  thread-yield!  thread-terminate!  thread-join!
+	   ;;mutexes
+		 make-mutex mutex?  mutex-name mutex-specific mutex-specific-set!  mutex-state mutex-lock!  mutex-unlock!  
+		 ;;condition-variables
+		 condition-variable?  make-condition-variable condition-variable-name condition-variable-specific condition-variable-specific-set!  condition-variable-signal!  condition-variable-broadcast!  
+		 ;time
+		 current-time time? time->seconds seconds->time 
+		 ;exceptions and exception handling
+		 current-exception-handler with-exception-handler raise join-timeout-exception? abandoned-mutex-exception? terminated-thread-exception? uncaught-exception? uncaught-exception-reason)
+	 (import (srfi :21 real-time-multithreading)))
hunk ./libs/srfi/srfi-23.scm 2
-(library (srfi-23) 
+(library (srfi :23 error) 
hunk ./libs/srfi/srfi-23.scm 9
+
+(library (srfi :23) (export error) (import (srfi :23 error)))
hunk ./libs/srfi/srfi-27.scm 2
-(library (srfi-27) 
+(library (srfi :27 random-bits) 
hunk ./libs/srfi/srfi-27.scm 5
+
+(library (srfi :27) 
+	 (export random-integer random-real random-source-make-integers random-source-make-reals random-source-pseudo-randomize!  random-source-randomize!  random-source-state-ref random-source-state-set!  random-source?  make-random-source)
+	 (import (srfi :27 random-bits)))
hunk ./libs/srfi/srfi-39.scm 1
-(library (srfi-39) 
+(library (srfi :39 parameters) 
hunk ./libs/srfi/srfi-39.scm 12
+(library (srfi :39) (export make-parameter parameterize) (import (srfi :39 parameters)))
+
hunk ./libs/srfi/srfi-4.scm 1
-(library (srfi-4) 
+(library (srfi :4) 
hunk ./libs/srfi/srfi-6.scm 1
-(library (srfi-6) 
+(library (srfi :6 basic-string-ports) 
hunk ./libs/srfi/srfi-6.scm 4
+
+(library (srfi :6) (export get-output-string open-input-string open-output-string) (import (srfi :6 basic-string-ports)))
hunk ./libs/srfi/srfi-8.scm 2
-(library (srfi-8) 
+(library (srfi :8 receive) 
hunk ./libs/srfi/srfi-8.scm 11
+
+(library (srfi :8) (export receive) (import (srfi :8 receive)))
hunk ./libs/srfi/srfi-88.scm 1
-(library (srfi-88)
+(library (srfi :88)
hunk ./libs/srfi/srfi-88.scm 4
+
hunk ./libs/srfi/srfi-89.scm 10
-(library (srfi-89 keywords)
+(library (srfi :89 keywords)
hunk ./libs/srfi/srfi-89.scm 15
-	   (srfi-88)
+	   (srfi :88)
hunk ./libs/srfi/srfi-89.scm 98
-(library (srfi-89)
+(library (srfi :89)
hunk ./libs/srfi/srfi-89.scm 101
-	   (for (srfi-89 keywords) expand run)
+	   (for (srfi :89 keywords) expand run)
hunk ./libs/srfi/srfi-9.scm 1
-;SRFI-9 in terms of rnrs records
-(library (srfi-9) 
+;SRFI-9 in terms of srfi 99 records
+(library (srfi :9 records) 
hunk ./libs/srfi/srfi-9.scm 4
-	 (import (for (rnrs records procedural (6)) expand run)
-		 (for (rnrs syntax-case) expand run)
-		 (for (rnrs base) expand run)
-		 )
+	 (import (for (srfi :99 records procedural) expand run)
+		 (for (rnrs base) expand run))
hunk ./libs/srfi/srfi-9.scm 7
-(define-syntax define-record-type 
-  (lambda (x)
-    (define (make-field-defs x)
-      (syntax-case x ()
-	((f field-name accessor) 
-	 (eq? 'field (syntax->datum #'f))
-	 #''(immutable field-name))
+(define-syntax define-record-type
+  (syntax-rules ()
+	((define-record-type type
+	     (constructor constructor-tag ...)
+	     predicate
+	     (field-tag accessor . more) ...)
+	 (begin
+	   (define type (make-rtd 'type '#((mutable field-tag) ...)))
+	   (define constructor (rtd-constructor type '#(constructor-tag ...)))
+	   (define predicate (rtd-predicate type))
+	   (define-record-field type field-tag accessor . more)
+	   ...))))
hunk ./libs/srfi/srfi-9.scm 20
-	((f field-name accessor mutator) 
-	 (eq? 'field (syntax->datum #'f))
-	 #''(mutable field-name))
+(define-syntax define-record-field
+  (syntax-rules ()
+		((define-record-field type field-tag accessor)
+		 (define accessor (rtd-accessor type 'field-tag)))
+		((define-record-field type field-tag accessor modifier)
+		 (begin
+		   (define accessor (rtd-accessor type 'field-tag))
+		   (define modifier (rtd-modifier type 'field-tag))))))
hunk ./libs/srfi/srfi-9.scm 29
-	((form form2 )
-	 #`(#,(make-field-defs #`(field #,@(syntax form)))
-	    #,(make-field-defs #`(field #,@(syntax form2)))))
-	((form forms ...)
-	 #`(#,(make-field-defs #`(field #,@(syntax form))) 
-	    #,@(make-field-defs #'(forms ...))))))
-
-    (define (make-field-procs type index field-forms)
-      (syntax-case field-forms ()
-	((f field-name accessor)
-	 (eq? 'field (syntax->datum #'f))
-	 #`((define accessor (record-accessor #,type #,index))))
-	((f field-name accessor mutator) 
-	 (eq? 'field (syntax->datum #'f))
-	 #`((define accessor (record-accessor #,type #,index))
-	    (define mutator (record-mutator #,type #,index))))
-        ((form form2 )
-	 #`(#,@(make-field-procs type index #`(field #,@(syntax form)))
-	    #,@(make-field-procs type (+ index 1) #`(field #,@(syntax form2)))))
-	((form  forms ...)
-	 #`(#,@(make-field-procs type index #`(field #,@(syntax form ))) 
-	    #,@(make-field-procs type (+ index 1) #'(forms ...))))))
-
-	(syntax-case x ()
-	((_ type (constructor-name . constructor-fields) predicate fields ...)
-	 #`(begin
-	     (define type (make-record-type-descriptor 'type #f #f #f #f (vector #,@(make-field-defs #'(fields ...)))))
-	     (define constructor-name (record-constructor (make-record-constructor-descriptor type #f #f)))
-	     (define predicate (record-predicate type))
-	     #,@(make-field-procs #'type 0 #'(fields ...)))))))
+     
hunk ./libs/srfi/srfi-9.scm 32
+(library (srfi :9) (export define-record-type) (import (srfi :9 records)))
+
addfile ./libs/srfi/srfi-99.scm
hunk ./libs/srfi/srfi-99.scm 1
+(library (srfi :99 records procedural)
+	 (export make-rtd rtd? rtd-constructor
+		 rtd-predicate rtd-accessor rtd-mutator)
+	 (import (gambit records procedural) ))
+	     
+
+(library (srfi :99 records inspection)
+	 (export record? record-rtd
+		 rtd-name rtd-parent
+		 rtd-field-names rtd-all-field-names rtd-field-mutable?)
+	 (import
+	   (gambit records inspection)))
+
+(library (srfi :99 records syntactic)
+	 (export define-record-type)
+	 (import (for (rnrs base) run expand)
+		 (for (rnrs lists) run expand)
+		 (for (rnrs syntax-case) run expand)
+		 (srfi :99 records procedural))
+
+	 (define-syntax define-record-type
+	   (syntax-rules ()
+			 ((_ (type-name parent) constructor-spec predicate-spec . field-specs)
+			  (define-record-type-helper0
+			    type-name parent constructor-spec predicate-spec . field-specs))
+			 ((_ type-name constructor-spec predicate-spec . field-specs)
+			  (define-record-type-helper0
+			    type-name #f constructor-spec predicate-spec . field-specs))))
+
+	 (define-syntax define-record-type-helper0
+	   (lambda (x)
+	     (define (complain)
+	       (syntax-violation 'define-record-type "illegal syntax" x))
+	     (syntax-case x ()
+			  ((_ tname pname constructor-spec predicate-spec . field-specs)
+			   (let* ((type-name (syntax->datum #'tname))
+				  (parent (syntax->datum #'pname))
+				  (cspec (syntax->datum #'constructor-spec))
+				  (pspec (syntax->datum #'predicate-spec))
+				  (fspecs (syntax->datum #'field-specs))
+				  (type-name-string
+				    (begin (if (not (symbol? type-name))
+					     (complain))
+					   (symbol->string type-name)))
+				  (constructor-name
+				    (cond ((eq? cspec #f)
+					   #f)
+					  ((eq? cspec #t)
+					   (string->symbol
+					     (string-append "make-" type-name-string)))
+					  ((symbol? cspec)
+					   cspec)
+					  ((pair? cspec)
+					   (car cspec))
+					  (else (complain))))
+				  (constructor-args
+				    (cond ((pair? cspec)
+					   (if (not (for-all symbol? cspec))
+					     (complain)
+					     (list->vector (cdr cspec))))
+					  (else #f)))
+				  (predicate-name
+				    (cond ((eq? pspec #f)
+					   #f)
+					  ((eq? pspec #t)
+					   (string->symbol
+					     (string-append type-name-string "?")))
+					  ((symbol? pspec)
+					   pspec)
+					  (else (complain))))
+				  (field-specs
+				    (map (lambda (fspec)
+					   (cond ((symbol? fspec)
+						  (list 'immutable
+							fspec
+							(string->symbol
+							  (string-append
+							    type-name-string
+							    "-"
+							    (symbol->string fspec)))))
+						 ((not (pair? fspec))
+						  (complain))
+						 ((not (list? fspec))
+						  (complain))
+						 ((not (for-all symbol? fspec))
+						  (complain))
+						 ((null? (cdr fspec))
+						  (list 'mutable
+							(car fspec)
+							(string->symbol
+							  (string-append
+							    type-name-string
+							    "-"
+							    (symbol->string (car fspec))))
+							(string->symbol
+							  (string-append
+							    type-name-string
+							    "-"
+							    (symbol->string (car fspec))
+							    "-set!"))))
+						 ((null? (cddr fspec))
+						  (list 'immutable
+							(car fspec)
+							(cadr fspec)))
+						 ((null? (cdddr fspec))
+						  (cons 'mutable fspec))
+						 (else (complain))))
+					 fspecs))
+
+				  (fields (list->vector (map cadr field-specs)))
+
+				  (accessor-fields
+				    (map (lambda (x) (list (caddr x) (cadr x)))
+					 (filter (lambda (x) (>= (length x) 3))
+						 field-specs)))
+
+				  (mutator-fields
+				    (map (lambda (x) (list (cadddr x) (cadr x)))
+					 (filter (lambda (x) (= (length x) 4))
+						 field-specs))))
+
+			     (datum->syntax
+			       #'tname
+			       `(,#'define-record-type-helper
+				  ,type-name ,fields ,parent
+				  ,(if constructor-args
+				     (list constructor-name constructor-args)
+				     constructor-name)
+				  ,predicate-name
+				  ,accessor-fields ,mutator-fields)))))))
+
+	 (define-syntax define-record-type-helper
+	   (syntax-rules ()
+
+			 ((_ type-name fields parent #f predicate
+			     ((accessor field) ...) ((mutator mutable-field) ...))
+			  (define-record-type-helper
+			    type-name fields parent ignored predicate
+			    ((accessor field) ...) ((mutator mutable-field) ...)))
+
+			 ((_ type-name fields parent constructor #f
+			     ((accessor field) ...) ((mutator mutable-field) ...))
+			  (define-record-type-helper
+			    type-name fields parent constructor ignored
+			    ((accessor field) ...) ((mutator mutable-field) ...)))
+
+			 ((_ type-name fields parent (constructor args) predicate
+			     ((accessor field) ...) ((mutator mutable-field) ...))
+			  (begin (define type-name (make-rtd 'type-name 'fields parent))
+				 (define constructor (rtd-constructor type-name 'args))
+				 (define predicate (rtd-predicate type-name))
+				 (define accessor (rtd-accessor type-name 'field))
+				 ...
+				 (define mutator (rtd-mutator type-name 'mutable-field))
+				 ...))
+
+			 ((_ type-name fields parent constructor predicate
+			     ((accessor field) ...) ((mutator mutable-field) ...))
+			  (begin (define type-name (make-rtd 'type-name 'fields parent))
+				 (define constructor (rtd-constructor type-name))
+				 (define predicate (rtd-predicate type-name))
+				 (define accessor (rtd-accessor type-name 'field))
+				 ...
+				 (define mutator (rtd-mutator type-name 'mutable-field))
+				 ...))))
+
+	 ) ; err5rs records syntactic
+
+(library (srfi :99)
+	 (export make-rtd rtd? rtd-constructor
+		 rtd-predicate rtd-accessor rtd-mutator 
+		 record? record-rtd
+		 rtd-name rtd-parent
+		 rtd-field-names rtd-all-field-names rtd-field-mutable? 
+		 define-record-type)
+	 (import (srfi :99 records procedural)
+		 (srfi :99 records inspection)
+		 (srfi :99 records syntactic)))
+
+(library (err5rs records procedural)
+	 (export make-rtd rtd? rtd-constructor
+		 rtd-predicate rtd-accessor rtd-mutator)
+	 (import (srfi :99 records procedural)))
+
+(library (err5rs records inspection)
+	 (export record? record-rtd
+		 rtd-name rtd-parent
+		 rtd-field-names rtd-all-field-names rtd-field-mutable?)
+	 (import (srfi :99 records inspection)))
+
+(library (err5rs records syntactic)
+	 (export define-record-type)
+	 (import (srfi :99 records syntactic)))
addfile ./primitives.scm
hunk ./primitives.scm 1
+;;;===============================================================================
+;;;
+;;; Primitives used by various libraries that are not included as part of Gambit library 
+;;;
+;;; by Arthur T Smyles.
+;;;===============================================================================
+
+
+
+
+;R6RS record primitives (slightly more efficient then err5rs for these methods)
+
+(define (record-field-mutable? rtd k)
+  (if (record-type-descriptor? rtd)
+      ;k doesn't need to be incremented in this case
+      (fxbit-set? (vector-ref (##type-fields rtd) (+ (* k 3) 1)) 1))
+      )
+
+
+(define (record-accessor rtd k)
+   (let ((k (+ (##type-field-count (rtd-parent rtd)) k 1)))
+     (if (record-type-sealed? rtd)
+       (lambda (obj) (##structure-direct-ref obj k rtd #f))
+       (lambda (obj) (##structure-ref obj k rtd #f)))))
+
+(define (record-mutator rtd k)
+  (if (record-field-mutable? rtd k)
+    (let ((k (+ (##type-field-count (rtd-parent rtd)) k 1)))
+       (if (record-type-sealed? rtd)
+	 (lambda (obj value) (##structure-direct-set! obj value k rtd #f))
+	 (lambda (obj value) (##structure-set! obj value k rtd #f))))))
+
+
+;basic conditions system used to implement assertion-violation
+
+;used to create your own simple conditions
+(define &condition (make-rtd '&condition '#()))
+(define &compound (make-rtd '&compound '#((immutable conditions)) &condition))
+(define &serious (make-rtd '&serious '#() &condition))
+(define &violation (make-rtd '&violation '#() &serious))
+(define &assertion (make-rtd '&assertion '#() &violation))
+(define &who (make-rtd '&who '#((immutable who)) &condition))
+(define &message (make-rtd '&message '#((immutable message)) &condition))
+(define &irritants (make-rtd '&irritants '#((immutable irritants)) &condition))
+
+;used in expander.scm
+(define &syntax (make-rtd '&syntax '#((immutable form) (immutable subform)) &violation))
+(define &trace (make-rtd '&trace '#((immutable trace)) &condition))
+    
+;need to define raise for your implementation
+
+(define condition
+  (let ((constructor (rtd-constructor &compound)))
+    (lambda conditions
+      (cond
+	((and (pair? conditions) (null? (cdr conditions))) (car conditions))
+	(else (constructor conditions))))))
+
+(define (simple-conditions condition)
+  (let ((compound? (record-predicate &compound))
+	(conditions (record-accessor &compound 0)))
+    (lambda (condition)
+      (cond
+	((compound? condition) (conditions condition))
+	(else (list condition))))))
+
+(define make-who-condition (rtd-constructor &who))
+(define make-message-condition (rtd-constructor &message))
+(define make-irritants-condition (rtd-constructor &irritants))
+(define make-syntax-violation (rtd-constructor &syntax))
+(define make-assertion-violation (rtd-constructor &assertion))
+
+(define (assertion-violation who message . irritants)
+  (raise 
+    (if who
+    (condition (make-who-condition who) 
+	       (make-message-condition message) 
+	       (make-irritants-condition irritants)
+	       (make-assertion-violation))
+    (condition (make-message-condition message) 
+	       (make-irritants-condition irritants)
+	       (make-assertion-violation)))))