gistfile1.scm

(define-macro (dfsch:define-class name superklass slots 
                                  &rest class-opts
                                  &key roles &allow-other-keys)

  ;; Remove role list from list of class options
  (set! class-opts (plist-remove-keys class-opts '(:roles)))

  ;; Evaluate list of roles in outer context
  (set! roles (eval-list roles (%macro-expansion-environment)))
  (set! superklass (eval superklass (%macro-expansion-environment)))

  ;; Extend used slot and options lists by matching lists in used roles
  ;; Also remove roles that conflict with superclass roles
  (set! roles (map* (lambda (role-object)
                      (let ((role (assert-instance role-object <role>)))
                        (if (and superklass
                                 (specializer-matches-type? role superklass))
                            (begin 
                              (warning "Role already implemented by superclass"
                                       :role role
                                       :superclass superklass)
                              #n)
                            (begin
                              (set! slots (append slots 
                                                  (role-slots role)))
                              (set! class-opts (append class-opts 
                                                       (role-options role)))
                              role))))
                      roles))
  
  ;; put evaluated list of roles back
  (set! class-opts (nconc `(:roles ',roles)
                          class-opts))

  (let ((class-slots (map 
                      (lambda (desc)
                        (letrec ((name (if (pair? desc) (car desc) desc))
                                 (opts (if (pair? desc) (cdr desc) ()))
                                 (opt-expr (plist-remove-keys opts 
                                                              '(:accessor 
                                                                :reader 
                                                                :writer
                                                                :initform)))
                                 (init-form (plist-get opts :initform)))
                          `@(list ',name ,@opt-expr 
                                  ,@(when init-form
                                      `(:initfunc 
                                        (lambda () 
                                          "slot initializer" 
                                          ,(car init-form)))))))
                      slots)))
    `@(begin 
        (%define-canonical-constant ,name (make-class ',name 
                                                      ',superklass 
                                                      (list ,@class-slots)
                                                      ,@class-opts))
        ,@(mapcan 
           (lambda (desc)
             (letrec ((sname (if (pair? desc) (car desc) desc))
                      (opts (if (pair? desc) (cdr desc) ()))
                      (accessor (plist-get opts :accessor))
                      (writer (plist-get opts :writer))
                      (reader (plist-get opts :reader)))
               (append 
                (when accessor
                  `((define-slot-accessor ,(car accessor) ,name ',sname)))
                (when reader
                  `((define-slot-reader ,(car reader) ,name ',sname)))
                (when writer
                  `((define-slot-writer ,(car writer) ,name ',sname))))))
           slots)
        ,name)))