(library (srfi n9)
  (export define-record-type)
  (import (rnrs base)
	  (prefix (rnrs records procedural) r6rs:)
	  (prefix (rnrs records inspection) r6rs:))

  (define (field-index field-name field-tags)
    (let loop ((i 0))
      (if (eq? field-name (vector-ref field-tags i))
          i
          (loop (+ 1 i)))))

  (define (make-record-type name field-tags)
    (r6rs:make-record-type-descriptor name #f #f #t #f  
      (list->vector (map (lambda (n) (list 'mutable n)) field-tags))))

  (define (record-accessor type field-name)
    (r6rs:record-accessor type 
      (field-index field-name (r6rs:record-type-field-names type))))

  (define (record-modifier type field-name)
    (r6rs:record-mutator type 
      (field-index field-name (r6rs:record-type-field-names type))))

  (define (record-constructor type cons-tags)
    (r6rs:record-constructor
     (r6rs:make-record-constructor-descriptor type #f #f)))

  (define (record-predicate type)
    (r6rs:record-predicate type))

;; Excerpted from:

;; SRFI 9 Reference Implementation
;; http://srfi.schemers.org/srfi-9/srfi-9.html

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Definition of DEFINE-RECORD-TYPE

(define-syntax define-record-type
  (syntax-rules ()
    ((define-record-type type
       (constructor constructor-tag ...)
       predicate
       (field-tag accessor . more) ...)
     (begin
       (define type
         (make-record-type 'type '(field-tag ...)))
       (define constructor
         (record-constructor type '(constructor-tag ...)))
       (define predicate
         (record-predicate type))
       (define-record-field type field-tag accessor . more)
       ...))))

; An auxilliary macro for define field accessors and modifiers.
; This is needed only because modifiers are optional.

(define-syntax define-record-field
  (syntax-rules ()
    ((define-record-field type field-tag accessor)
     (define accessor (record-accessor type 'field-tag)))
    ((define-record-field type field-tag accessor modifier)
     (begin
       (define accessor (record-accessor type 'field-tag))
       (define modifier (record-modifier type 'field-tag))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
) ; end srfi-9