; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
; Copyright (c) 1993-2008 by Richard Kelsey and Jonathan Rees. See file COPYING.


; This is file record.scm.

;;;; Records

; This is completely vanilla Scheme code.  Should work anywhere.

(define (make-record-type type-id field-names)

  (define unique (list type-id))

  (define size (+ (length field-names) 1))

  (define (constructor . names-option)
    (let* ((names (if (null? names-option)
		      field-names
		      (car names-option)))
	   (number-of-inits (length names))
	   (indexes (map field-index names)))
      (lambda field-values
	(if (= (length field-values) number-of-inits)
	    (let ((record (make-vector size 'uninitialized)))
	      (vector-set! record 0 unique)
	      (for-each (lambda (index value)
			  (vector-set! record index value))
			indexes
			field-values)
	      record)
	    (assertion-violation
	     '<record-constructor> "wrong number of arguments to record constructor"
	     field-values type-id names)))))

  (define (predicate obj)
    (and (vector? obj)
	 (= (vector-length obj) size)
	 (eq? (vector-ref obj 0) unique)))

  (define (accessor name)
    (let ((i (field-index name)))
      (lambda (record)
	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
	    (vector-ref record i)
	    (assertion-violation
	     '<record-accessor>
	     "invalid argument to record accessor"
	     record type-id name)))))

  (define (modifier name)
    (let ((i (field-index name)))
      (lambda (record new-value)
	(if (predicate record) ;Faster: (eq? (vector-ref record 0) unique)
	    (vector-set! record i new-value)
	    (assertion-violation
	     '<record-modifier>
	     "invalid argument to record modifier"
	     record type-id name)))))

  (define (field-index name)
    (if (integer? name)
	name
	(let loop ((l field-names) (i 1))
	  (if (null? l)
	      (assertion-violation 'field-index "bad field name" name)
	      (if (eq? name (car l))
		  i
		  (loop (cdr l) (+ i 1)))))))

  (define the-descriptor
    (lambda (request)
      (case request
	((constructor) constructor)
	((predicate) predicate)
	((accessor) accessor)
	((modifier) modifier)
	((name) type-id)
	((field-names) field-names))))

  the-descriptor)

(define (record-constructor r-t . names-option)
  (apply (r-t 'constructor) names-option))

(define (record r-t . contents)
  (apply ((r-t 'constructor)) contents))

(define (record-predicate r-t)
  (r-t 'predicate))

(define (record-accessor r-t field-name)
  ((r-t 'accessor) field-name))

(define (checked-record-ref r r-t field-index)
  (((r-t 'accessor) field-index) r))
(define provisional-checked-record-ref checked-record-ref)

(define (record-modifier r-t field-name)
  ((r-t 'modifier) field-name))

(define (checked-record-set! r r-t field-index new)
  (((r-t 'modifier) field-index) r new))
(define provisional-checked-record-set! checked-record-set!)

(define (record-type-name r-t) (r-t 'name))
(define (record-type-field-names r-t) (r-t 'field-names))

(define (record-type? r-t)
  (and (procedure? r-t)
       (assertion-violation 'record-type? "record-type? not implemented" r-t)))

(define (define-record-discloser r-t proc)
  "ignoring define-record-discloser form")
