; Record.scm.  This more or less implements the records that are
; proposed for R5RS - unfortunately, all records created in this
; manner look like vectors.  I believe the original record proposal
; was made by Jonathan Rees.  This implementation defines some symbols
; other than those that are part of the record proposal - this
; wouldn't be a problem if Scheme had a module system, but it doesn't.

; Written by david carlton, carlton@husc.harvard.edu.  This code is in
; the public domain.

; Tags to help identify rtd's.  (A record is identified by the rtd
; that begins it.)
(define record:*rtd-tag* (cons 'rtd '()))

; Length of the extra junk that we stick on the beginning of a vector
; representing a record object.
(define record:*header-length* 1)

; Checks to see if a list has any duplicates.  Also checks to see if
; it a list, for that matter.
(define record:has-duplicates?
  (lambda (list)
    (let loop ((list list))
      (cond
       ((null? list) #f)
       ((not (pair? list)) #t)
       ((memq (car list) (cdr list)) #t)
       (else (loop (cdr list)))))))

; Checks to see it all of the elments of a list satisfy a certain
; predicate.
(define record:satisfies-predicate
  (lambda (list predicate?)
    (let loop ((list list))
      (cond
       ((null? list) #t)
       ((predicate? (car list)) (loop (cdr list)))
       (else #f)))))

; Determines whether or not a certain element is in a list.  If not,
; it returns #f; if so, it returns its (zero-based) position in the
; list, adding to the position the length of the header of a record.
(define record:corrected-index
  (lambda (element list)
    (let index-loop ((list list)
		     (n 0))
      (cond
       ((null? list) #f)
       ((eq? element (car list)) (+ n record:*header-length*))
       (else (index-loop (cdr list) (+ n 1)))))))

; May or may not be the best way to define this; at least it's tail
; recursive, and probably does a reasonable job on many systems.  And
; it's certainly an easy way to do things.
(define record:list-copy
  (lambda (list)
    (reverse (reverse list))))
;(define record:list-copy list-copy)

; Various accessor functions.  No error checking; if you call these,
; you should know that they will work.
(define record:rtd-name (lambda (rtd) (vector-ref rtd 1)))
(define record:rtd-fields (lambda (rtd) (vector-ref rtd 2)))
(define record:rtd-length (lambda (rtd) (vector-ref rtd 3)))
(define record:get-tag (lambda (x) (vector-ref x 0)))
(define record:record-rtd (lambda (x) (vector-ref x 0)))

(define make-record-type
  (lambda (type-name field-names)
    (if (not (string? type-name))
	(error "make-record-type: non-string type-name argument."))
    (if (or (record:has-duplicates? field-names)
	    (not (record:satisfies-predicate field-names symbol?)))
	(error "make-record-type: illegal field-names argument."))
    (vector record:*rtd-tag* type-name field-names
	    (length field-names))))

; Determines whether or not a certain object looks like an rtd.
; Doesn't do as much error-checking as it could, but it would be quite
; unlikely for somebody to accidentally fool this function.
(define record:rtd?
  (lambda (object)
    (and (vector? object)
	 ; Could check for the exact value here, but then I'd have to
	 ; keep changing this as I change the format of a rtd.  This
	 ; is good enough to get the vector-ref to work.
	 (not (= (vector-length object) 0))
	 (eq? (record:get-tag object) record:*rtd-tag*))))

(define record-constructor
  (lambda (rtd . field-names)
    (if (not (record:rtd? rtd))
	(error "record-constructor: illegal rtd argument."))
    (if (null? field-names)
	(let ((record-length (record:rtd-length rtd)))
	  (lambda elts
	    (if (not (= (length elts) record-length))
		(error "record-constructor: "
			(record:rtd-name rtd)
			": wrong number of arguments."))
	    (apply vector rtd elts)))
	(let ((record-fields (record:rtd-fields rtd))
	      (corrected-record-length
	       (+ (record:rtd-length rtd)
		  record:*header-length*))
	      (field-names (car field-names)))
	  (if (or (record:has-duplicates? field-names)
		  (not (record:satisfies-predicate
			field-names
			(lambda (x)
			  (memq x record-fields)))))
	      (perror
	       "record-constructor: invalid field-names argument."))
	  (let ((field-length (length field-names))
		(record-offsets
		 (let r-o-loop ((offsets '())
				(names field-names))
		   (if (null? names)
		       (reverse offsets)
		       (r-o-loop
			(cons (record:corrected-index (car names)
						      record-fields)
			      offsets)
			(cdr names))))))
	    (lambda elts
	      (if (not (= (length elts) field-length))
		  (perror "record-constructor: "
			  (record:rtd-name rtd)
			  ": wrong number of arguments."))
	      (let ((result (make-vector corrected-record-length)))
		(vector-set! result 0 rtd)
		(let r-c-loop ((offsets record-offsets)
			       (elts elts))
		  (if (null? elts) result
		      (begin
			(vector-set! result
				     (car offsets)
				     (car elts))
			(r-c-loop (cdr offsets) (cdr elts))))))))))))

(define record-predicate
  (lambda (rtd)
    (if (not (record:rtd? rtd))
	(perror "record-predicate: invalid argument."))
    (let ((corrected-length (+ (record:rtd-length rtd)
			       record:*header-length*)))
      (lambda (x)
	(and (vector? x)
	     (= (vector-length x) corrected-length)
	     (eq? (record:record-rtd x) rtd))))))

(define record-accessor
  (lambda (rtd field-name)
    (if (not (record:rtd? rtd))
	(perror "record-accessor: invalid rtd argument."))
    (let ((name-index (record:corrected-index field-name
					      (record:rtd-fields rtd)))
	  (predicate (record-predicate rtd)))
      (if (not name-index)
	  (perror "record-accessor: invalid field-name argument."))
      (lambda (x)
	(if (not (predicate x))
	    (perror "record-accessor: "
		    (record:rtd-name rtd)
		    " "
		    field-name
		    ": invalid argument."))
	(vector-ref x name-index)))))

(define record-updater
  (lambda (rtd field-name)
    (if (not (record:rtd? rtd))
	(perror "record-updater: invalid rtd argument."))
    (let ((name-index (record:corrected-index field-name
					      (record:rtd-fields rtd)))
	  (predicate (record-predicate rtd)))
      (if (not name-index)
	  (perror "record-updater: invalid field-name argument."))
      (lambda (x y)
	(if (not (predicate x))
	    (perror "record-updater: "
		    (record:rtd-name rtd)
		    " "
		    field-name
		    ": invalid argument."))
	(vector-set! x name-index y)))))

(define record?
  (lambda (obj)
    (and (vector? obj)
	 (>= (vector-length obj) 1)
	 (record:rtd? (record:record-rtd obj))
	 (= (vector-length obj)
	    (+ record:*header-length*
	       (record:rtd-length (record:record-rtd obj)))))))

(define record-type-descriptor
  (lambda (record)
    (if (not (record? record))
	(perror "record-type-descriptor: invalid argument."))
    (record:record-rtd record)))

(define record-type-name
  (lambda (rtd)
    (if (not (record:rtd? rtd))
	(perror "record-type-name: invalid argument."))
    (record:rtd-name rtd)))

; For this function, make a copy of the value returned in order to
; make it a bit harder for the user to screw things up.
(define record-type-field-names
  (lambda (rtd)
    (if (not (record:rtd? rtd))
	(perror "record-type-field-names: invalid argument."))
    (record:list-copy (record:rtd-fields rtd))))