; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010
; See the LICENSE file of the S9fES package for terms of use
;
; (define-record <type-name> (<slot-name> <value>) ...)  ==>  unspecific
;
; DEFINE-RECORD creates a new type, which is a sub-type of the vector,
; and defines a set of procedures for creating objects of the new type,
; accessing its slots, and checking for its type.
;
; <Type-name> is the name of the new type. Each (<slot-name> <value>) pair
; defines a slot of the new type, where <slot-name> is a symbol naming the
; slot and <value> is a default value for this slot.
;
; (define-record <type> (<s1> <v1>) ... (<sN> <vN>)) will expand to
; definitions of the following procedures:
;
; (<type>? x) is a predicate checking whether X has the type <type>.
;
; (make-<type>) creates a new object of the type <type> and initializes
; its slots with the values specified in DEFINE-RECORD.
;
; (<type>-<s1> x) evaluates to the value stored in slot <s1> of X. When
; X is not of the type <type>, an error will be signalled.
; (<type>-<sN> x) does the same, but accesses slot <sN>.
;
; (<type>-set-<s1>! x v) changes the value stored in slot <s1> of X to V.
; When X is not of the type <type>, an error will be signalled.
; (<type>-set-<sN>! x v) does the same, but changes slot <sN>.
;
; Example:   (begin
;              (define-record point (x 0) (y 0) (color #f))
;              (let ((p (make-point)))
;                (point-set-color! p 'yellow)
;                (list (point? p)
;                      (point-color p))))               ==>  (#t yellow)

(load-from-library "iota.scm")

(define-syntax (define-record name . slots)
  (if (not (symbol? name))
      (error "define-record: expected name, got" name))
  (let ((slot?
          (lambda (x)
            (and (pair? x)
                 (symbol? (car x))
                 (pair? (cdr x))
                 (null? (cddr x))))))
    (let loop ((s slots))
      (cond ((null? s))
            ((not (slot? (car s)))
              (error "define-record: expected slot, got" (car s)))
            (else
              (loop (cdr s))))))
  (let* ((symbol-append
          (lambda x
            (string->symbol
              (apply string-append (map symbol->string x)))))
         (slot-defs
           (map cons
                (map car slots)
                (iota 1 (length slots))))
         (def-tag
           `(define ,(symbol-append '* name '-type-tag*) (list ',name)))
         (def-maker
           `(define (,(symbol-append 'make- name))
                    (vector ,(symbol-append '* name '-type-tag*)
                            ,@(map cadr slots))))
         (def-predicate
           (let ((p-name (symbol-append name '?)))
             `(define ,p-name
                (let ((tag ,(symbol-append '* name '-type-tag*)))
                  (lambda (x)
                    (and (vector? x)
                         (positive? (vector-length x))
                         (eq? tag (vector-ref x 0))))))))
         (def-assert
           `(define (,(symbol-append name '-assert) who x)
              (if (not (,(symbol-append name '?) x))
                  (error (string-append (symbol->string who)
                                        ": expected "
                                        (symbol->string ',name)
                                        ", got")
                         x))))
         (def-getters
           (map (lambda (s)
                  (let ((g-name (symbol-append name '- (car s)))
                        (a-name (symbol-append name '-assert)))
                    `(define ,g-name
                       (let ((,a-name ,a-name))
                         (lambda (x)
                           (,a-name ',g-name x)
                           (vector-ref x ,(cdr s)))))))
              slot-defs))
         (def-setters
           (map (lambda (s)
                  (let ((s-name (symbol-append name '-set- (car s) '!))
                        (a-name (symbol-append name '-assert)))
                    `(define ,s-name
                       (let ((,a-name ,a-name))
                         (lambda (x v)
                           (,a-name ',s-name x)
                           (vector-set! x ,(cdr s) v))))))
                slot-defs)))
    `(begin ,def-tag
            ,def-predicate
            ,def-assert
            ,def-maker
            ,@def-getters
            ,@def-setters)))
