elk/scm/record.scm

;;; -*-Scheme-*-
;;;
;;; The Scheme layer of the record extension.

(require 'record.la)

(define (record-field-index name fields)
  (let loop ((fields fields) (index 0))
       (cond ((null? fields)
	      (error 'record-field-index "invalid field name"))
	     ((eq? name (car fields))
	      index)
	     (else
	      (loop (cdr fields) (1+ index))))))

(define (record-constructor rtd . fields)

  (define (check-fields f)
    (if (not (null? f))
        (if (or (not (symbol? (car f))) (memq (car f) (cdr f)))
            (error 'record-constructor "invalid field name")
            (check-fields (cdr f)))))

  (let* ((rtd-fields (record-type-field-names rtd))
	 (indexes '())
	 (size (length rtd-fields)))
    (if (null? fields)
	(set! fields rtd-fields)
	(if (not (null? (cdr fields)))
	    (error 'record-constructor "too many arguments"))
	(set! fields (car fields))
	check-fields fields)
    (set! indexes
	  (map (lambda (x) (record-field-index x rtd-fields)) fields))
    (lambda args
      (if (not (= (length args) (length fields)))
	  (error 'record-constructor "invalid number of fields"))
      (let ((vec (make-vector size '())))
        (for-each
	  (lambda (index value)
	    (vector-set! vec index value))
	  indexes args)
	(make-record rtd vec)))))

(define (record-predicate rtd)
  (if (not (record-type? rtd))
      (error 'record-predicate "argument not a record-type"))
  (lambda (obj)
    (and (record? obj) (eq? (record-type-descriptor obj) rtd))))

(define (record-accessor rtd field-name)
  (let ((index (record-field-index field-name (record-type-field-names rtd))))
    (lambda (obj)
      (if (and (record? obj) (eq? (record-type-descriptor obj) rtd))
          (vector-ref (record-values obj) index)
	  (error 'record-accessor "argument not of correct record type")))))

(define (record-modifier rtd field-name)
  (let ((index (record-field-index field-name (record-type-field-names rtd))))
    (lambda (obj val)
      (if (and (record? obj) (eq? (record-type-descriptor obj) rtd))
          (vector-set! (record-values obj) index val)
	  (error 'record-modifier "argument not of correct record type")))))

(define (describe-record-type rtd)
  (format #t "a record type.~%")
  (if (null? (record-type-field-names rtd))
      (format #t "It has no fields.~%")
      (format #t "Its fields are: ~s.~%" (record-type-field-names rtd))))

(define (describe-record rec)
  (format #t "a record.~%")
  (let ((fields (record-type-field-names (record-type-descriptor rec))))
    (if (null? fields)
	(format #t "It has no fields.~%")
	(format #t "Its fields are:")
	(for-each (lambda (f v) (format #t " (~s ~s)" f v))
		  fields (vector->list (record-values rec)))
	(format #t ".~%"))))

(provide 'record)