[removed unneccassary file
atsmyles@earthlink.net**20091111192643] hunk ./err5rs-records-inspection.scm 1
-;;;===============================================================================
-;;;
-;;; Gambit ERR5RS record inspection
-;;;
-;;;
-;;; by Arthur T Smyles
-;;;
-; Copyright (c) 2008, Arthur T Smyles
-; All rights reserved.
-;
-; Redistribution and use in source and binary forms, with or without
-; modification, are permitted provided that the following conditions are met:
-;     * Redistributions of source code must retain the above copyright
-;       notice, this list of conditions and the following disclaimer.
-;     * Redistributions in binary form must reproduce the above copyright
-;       notice, this list of conditions and the following disclaimer in the
-;       documentation and/or other materials provided with the distribution.
-;     * Neither the name of the <organization> nor the
-;       names of its contributors may be used to endorse or promote products
-;       derived from this software without specific prior written permission.
-;
-; THIS SOFTWARE IS PROVIDED BY <copyright holder> ''AS IS'' AND ANY
-; EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
-; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
-; DISCLAIMED. IN NO EVENT SHALL <copyright holder> BE LIABLE FOR ANY
-; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
-; (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
-; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
-; ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
-; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
-; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-;;;===============================================================================
-
-(define (record? obj)
-  (and (structure? obj) (not (rtd-opaque? (##structure-type obj)))))
-
-(define (record-rtd obj)
-  (if (record? obj) (##structure-type obj)
-    (assertion-violation 'record-rtd "first argument must of type record" obj) 
-    ))
-
-(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))))))))) 
-
-
-
-
rmfile ./err5rs-records-inspection.scm