;; data/record.scm - record type implementation
;;
;; Copyright (C) 2000 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
;;
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; This software is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;; 
;; You should have received a copy of the GNU General Public License
;; along with this package; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.  

;;; This module implements a macro for defining record types from
;;; Scheme.  The macro `define-record' creates a data type as well as
;;; constructor, predicate, copy, setter and getter procedures for
;;; handling objects of the data types.
;;;
;;; This record implemention is R5RS conformant and should port to any
;;; decent Scheme implementation. Just remove the `define-module' and
;;; `export' clauses below.

(define-module (core record))

;; We must export the macro, of course, but also need to export the
;; record type descriptor because the generated constructors and
;; predicates use it.
(export define-record %*record-descriptor*%)

;; This is stored in the car of the descriptor created for every
;; user-defined record type.
(define %*record-descriptor*% '(record))

;; Create a getter function which fetches the field FIELD from a given
;; record.  INDEX is the index into the underlying vector where the
;; values are stored and PREDICATE is used to determine whether the
;; argument to the getter is of the correct record type.  REC-NAME is
;; the name of the record type and is used in the error message on
;; type mismatch.
(define (make-record-getter index field predicate rec-name)
  (let ((accessor (string->symbol
		   (string-append (symbol->string rec-name) "-"
				  (symbol->string field)))))
    `(define ,accessor
       (lambda (obj)
	 (if (,predicate obj)
	     (vector-ref obj ,index)
	     (error "wrong type -- record " ',rec-name " expected"))))))

;; Create a setter function which stores a value into the field FIELD
;; of a given record.  INDEX is the index into the underlying vector
;; where the values are stored and PREDICATE is used to determine
;; whether the argument to the getter is of the correct record type.
;; REC-NAME is the name of the record type and is used in the error
;; message on type mismatch.
(define (make-record-setter index field predicate rec-name)
  (let ((accessor (string->symbol
		   (string-append (symbol->string rec-name) "-"
				  (symbol->string field) "-set!"))))
    `(define ,accessor
       (lambda (obj val)
	 (if (,predicate obj)
	     (vector-set! obj ,index val)
	     (error "wrong type -- record " ',rec-name " expected"))))))

;; This is the might record-type creation macro.  It is called with
;; the name of the new record type in NAME (a symbol) and accepts
;; additional field names in FIELDS (must also be symbols).
;;
;; The macro defines several procedures in the current environment:
;; 
;; make-<typename> : constructor for values of the newly created type.
;;   Accepts as many arguments as FIELDS are given and initializes
;;   the record with these values.
;; <typename>? : a predicate taking one argument which returns #t if
;;   the passed value is of type <typename>
;; <typename>-copy : create a copy of a given record value.
;; <type-name>-<fieldname> : for every FIELD, a getter procedure is defined.
;; <type-name>-<fieldname>-set! : for every FIELD, a setter procedure
;;   is defined.
;;
;; Getter procedures take one argument, a record from which the field
;; should be extracted.  Setter procedures take a record and the new
;; value to store into the field.
(define-macro (define-record name . fields)
  (let ((descriptor (string->symbol
		     (string-append "*" (symbol->string name) "-descriptor*")))
	(constructor (string->symbol
		      (string-append "make-" (symbol->string name))))
	(predicate (string->symbol (string-append (symbol->string name) "?")))
	(copy (string->symbol (string-append (symbol->string name) "-copy"))))
    `(begin

       (define ,constructor #f)
       (define ,predicate #f)

       (let ((,descriptor (cons %*record-descriptor*% ',name))
	     (field-list ',fields))

	 ;; The constructor creates a new instance of the record type
	 ;; and initializes the fields with the given values.
	 (define constructor
	   (lambda fields
	     (if (not (= (length fields) ,(length fields)))
		 (error "wrong number of arguments")
		 (let ((val (make-vector ,(+ (length fields) 2))))
		   (vector-set! val 0 ,descriptor)
		   (vector-set! val 1 field-list)
		   (let loop ((index 2) (fields fields))
		     (if (pair? fields)
			 (begin
			   (vector-set! val index (car fields))
			   (loop (+ index 1) (cdr fields)))
			 val))))))

	 ;; The predicate tests if the passed object is of correct
	 ;; type.
	 (define predicate
	   (lambda (obj)
	     (and (vector? obj)
		  (= (vector-length obj) ,(+ (length fields) 2))
		  (pair? (vector-ref obj 0))
		  (eq? (vector-ref obj 0) ,descriptor))))
	 (set! ,constructor constructor)
	 (set! ,predicate predicate))
	 
       ;; The copy procedure validates the passed object for the
       ;; correct type and then returns a copy of the vector
       ;; representing the object.
       (define ,copy
	 (lambda (obj)
	   (if (,predicate obj)
	       (let ((val (make-vector (vector-length obj))))
		 (let loop ((index 0))
		   (if (< index (vector-length obj))
		       (begin
			 (vector-set! val index (vector-ref obj index))
			 (loop (+ index 1)))
		       val)))
	       (error "wrong type -- record " ',name " expected"))))

       ;; This loop generates a getter procedure for every field,
       ;; which is then merged in with `,@'.
       ,@(let loop ((index 2) (fields fields))
	   (if (pair? fields)
	       (cons (make-record-getter index (car fields) predicate name)
		     (loop (+ index 1) (cdr fields)))
	       '()))

       ;; This loop generates a setter procedure for every field,
       ;; which is then merged in with `,@'.
       ,@(let loop ((index 2) (fields fields))
	   (if (pair? fields)
	       (cons (make-record-setter index (car fields) predicate name)
		     (loop (+ index 1) (cdr fields)))
	       '())))))
