;;; -*-Scheme-*-
;;;
;;; Copyright (c) 1991 Massachusetts Institute of Technology
;;;
;;; This material was developed by the Scheme project at the
;;; Massachusetts Institute of Technology, Department of Electrical
;;; Engineering and Computer Science.  Permission to copy this
;;; software, to redistribute it, and to use it for any purpose is
;;; granted, subject to the following restrictions and understandings.
;;;
;;; 1. Any copy made of this software must include this copyright
;;; notice in full.
;;;
;;; 2. Users of this software agree to make their best efforts (a) to
;;; return to the MIT Scheme project any improvements or extensions
;;; that they make, so that these may be included in future releases;
;;; and (b) to inform MIT of noteworthy uses of this software.
;;;
;;; 3. All materials developed as a consequence of the use of this
;;; software shall duly acknowledge such use, in accordance with the
;;; usual standards of acknowledging credit in academic research.
;;;
;;; 4. MIT has made no warrantee or representation that the operation
;;; of this software will be error-free, and MIT is under no
;;; obligation to provide any services, by way of maintenance, update,
;;; or otherwise.
;;;
;;; 5. In conjunction with products arising from the use of this
;;; material, there shall be no use of the name of the Massachusetts
;;; Institute of Technology nor of any adaptation thereof in any
;;; advertising, promotional, or sales literature without prior
;;; written consent from MIT in each case.

;;;; Simple Record Implementation

(define (MAKE-RECORD-TYPE name fields)
  (vector 'RECORD-TYPE name fields))

(define (%RTD-SLOT rtd field)
  (let loop ((fields (vector-ref rtd 2)) (n 1))
    (cond ((null? fields) (error "unknown record field:" field))
	  ((eq? field (car fields)) n)
	  (else (loop (cdr fields) (+ n 1))))))

(define (RECORD-CONSTRUCTOR rtd fields)
  (let ((slots (map (lambda (field) (%rtd-slot rtd field)) fields))
	(result-length (+ (length (vector-ref rtd 2)) 1)))
    (let ((n-slots (length slots)))
      (lambda objects
	(let ((n-objects (length objects)))
	  (if (= n-objects n-slots)
	      (let ((record (make-vector result-length)))
		(vector-set! record 0 rtd)
		(for-each (lambda (slot object)
			    (vector-set! record slot object))
			  slots
			  objects)
		record)
	      (error "wrong number of arguments:"
			  (list n-objects n-slots))))))))

(define (RECORD-PREDICATE rtd)
  (let ((length (+ (length (vector-ref rtd 2)) 1)))
    (lambda (object)
      (and (vector? object)
	   (= (vector-length object) length)
	   (eq? rtd (vector-ref object 0))))))

(define (RECORD-ACCESSOR rtd field)
  (let ((slot (%rtd-slot rtd field))
	(predicate (record-predicate rtd)))
    (lambda (record)
      (if (predicate record)
	  (vector-ref record slot)
	  (error "illegal argument:" record)))))

(define (RECORD-UPDATER rtd field)
  (let ((slot (%rtd-slot rtd field))
	(predicate (record-predicate rtd)))
    (lambda (record object)
      (if (predicate record)
	  (vector-set! record slot object)
	  (error "illegal argument:" record)))))

;; --- added KenD

(define PRINT-RECORD ;; cheap hack
  (letrec ( (OK-VEC?
              (lambda (v)
	        (and (vector? v) 
	             (> (vector-length v) 0)))
            )
            (RECORD? 
              (lambda (rec)
	        (and (ok-vec? rec) 
	             (ok-vec? (vector-ref rec 0))
		     (eq? (vector-ref (vector-ref rec 0) 0) 'record-type)))
            )
          ) 
    (lambda (rec . optional-port)
      (let ( (port 
               (if (null? optional-port)
	           (current-output-port)
		   (car optional-port))
           ) )
        (cond 
	  ((record? rec)
	   (let ( (rtd (vector-ref rec 0)) )
	     (pretty-print 
	       (append '( record: )
	               (list (vector-ref rtd 1))
		       (map (lambda (name val) (list name val))
	                    (vector-ref rtd 2)
			    (cdr (vector->list rec))
	       )       )
	       port)
	  ))
	  (else (error "Not a record: " rec))
    ) ) )
) )

;;			--- E O F ---