Location: lib, 106 Lines

; Scheme 9 from Empty Space, Function Library
; By Nils M Holm, 2010,2012
; Placed in the Public Domain
; (define-structure <name> <slot> ...)  ==>  unspecific
; DEFINE-STRUCTURE 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.
; <Name> is the name of the new type. Each <slot> defines a slot of the
; new type. It must be have one of the following forms:
;       <slot-name>
;       (<slot-name>)
;       (<slot-name> <initial-value>)
; <Slot-name> must be a symbol and <initial-value> may be any value.
; When an <initial-value> is specified, the corresponding slot will
; be filled with that value whenever a new instance of the structure
; is created. When the value is omitted, it defaults to an unspecific
; value. <Slot-name> is equal to (<slot-name>).
; (define-structure <type> <slot-1> ... <slot-N>) will expand to
; definitions of the following procedures:
; (make-<type> object ...) creates a new object of the type <type> and
; initializes its slots with the values specified in DEFINE-STRUCTURE.
; When some OBJECTs are given, they will replace the default values of
; the first slots of the new <type> object. The number of OBJECTs
; passed to MAKE-<TYPE> must not be larger than the number of slots
; of <type>.
; (<type>? x) is a predicate checking whether X has the type <type>.
; (<type>-assert caller object) asserts that OBJECT is of the type
; <type>. When the assertion holds, it returns an unspecific value.
; Otherwise, it prints an error message. CALLER is a symbol that
; will be reported as the source of the error (typically the
; procedure calling <type>-assert).
; (<type>-copy object) creates an exact (shallow) copy an object of
; the given type and returns it.
; (<type>-<slot-1> x) evaluates to the value stored in slot <slot-1>
; of X. When X is not of the type <type>, an error will be signalled.
; (<type>-<slot-N> x) does the same, but accesses <slot-N>.
; (<type>-set-<slot-1>! x v) changes the value stored in slot <slot-1>
; of X to V. When X is not of the type <type>, an error will be signalled.
; (<type>-set-<slot-N>! x v) does the same, but changes <slot-N>.
; Given:     (define-structure point (x 0) (y 0) (color #f))
; Example:   (let ((p (make-point)))
;              (point-set-color! p 'yellow)
;              (list (point? p)
;                    (point-color p)))       ==>  (#t yellow)

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

(define-syntax (define-structure name . slots)
  (if (not (symbol? name))
      (error "define-structure: expected name, got" name))
  (let* ((make-slot
           (lambda (x)
             (cond ((symbol? x)
                     (list x #f))
                   ((and (pair? x)
                        (symbol? (car x))
                        (null? (cdr x)))
                     (list (car x) #f))
                   ((and (pair? x)
                         (symbol? (car x))
                         (pair? (cdr x))
                         (null? (cddr x)))
                     (error "define-structure: expected slot, got" x)))))
         (slots (map make-slot slots))
         (dupes (dupq (map car slots)))
           (lambda x
               (apply string-append (map symbol->string x)))))
           (map cons
                (map car slots)
                (iota (length slots))))
           `(define ,(symbol-append '* name '-type-tag*) (list ',name)))
           (let ((args    (gensym))
                 (vec     (gensym))
                 (isym    (gensym))
                 (asym    (gensym))
                 (m-name  (symbol-append 'make- name)))
             `(define (,m-name . ,args)
                      (if (> (length ,args) ,(length slots))
                          (error (string-append
                                   (symbol->string ',m-name)
                                   ": too many arguments")
                      (let ((,vec (vector ,(symbol-append '* name '-type-tag*)
                                          ,@(map cadr slots))))
                        (do ((,isym 1 (+ 1 ,isym))
                             (,asym ,args (cdr ,asym)))
                             ((null? ,asym))
                          (vector-set! ,vec ,isym (car ,asym)))
           (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))))))))
           `(define (,(symbol-append name '-assert) who x)
              (if (not (,(symbol-append name '?) x))
                  (error (string-append (symbol->string who)
                                        ": expected type <"
                                        (symbol->string ',name)
                                        ">, got")
           (let ((c-name (symbol-append name '-copy))
                 (a-name (symbol-append name '-assert)))
             `(define ,c-name
                (let ((,a-name ,a-name))
                  (lambda (x)
                    (,a-name ',c-name x)
                    (vector-copy x))))))
           (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)))))))
           (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))))))
    (if (not (null? dupes))
        (error "define-structure: duplicate slot names" dupes))
    `(begin ,def-tag

contact  |  privacy