prometheus/prometheus-impl.scm

(import
  (scheme)
  (scheme case-lambda)
  (srfi 1)
  (hermes))

(define-syntax make-getter-setter
  (syntax-rules ()
    ((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER)
     (make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER PURE-GETTER))
    ((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER SETABLE-GETTER)
     (case-lambda

      ((self resend getter VALUE)
       (self 'delete-slot! getter)
       (self 'set-immediate-slot-list!
             (alist-cons getter
                         (list #f TYPE)
                         (self 'immediate-slot-list)))
       (self 'add-message! getter PURE-GETTER (eq? TYPE 'parent)))

      ((self resend getter setter VALUE)
       (self 'delete-slot! getter)
       (self 'delete-slot! setter)
       (self 'set-immediate-slot-list!
               (alist-cons getter
                           (list setter TYPE)
                           (self 'immediate-slot-list)))
         (self 'add-message! getter SETABLE-GETTER (eq? TYPE 'parent))
         (self 'add-message! setter
               (lambda (self2 resend new)
                 (if (eq? self2 self)
                     (set! VALUE new)
                     (self2 'MESSAGE getter setter new)))))))))

(define (make-prometheus-root-object)
  (let ((o (make-hermes-object)))
    (o 'add-message! 'clone root-clone)
    (o 'add-message! 'message-not-understood root-message-not-understood)
    (o 'add-message! 'ambiguous-message-send root-ambiguous-message-send)
    (o 'add-message! 'immediate-slot-list root-immediate-slot-list)
    (o 'add-message! 'set-immediate-slot-list! root-set-immediate-slot-list!)
    (o 'add-message! 'add-value-slot! root-add-value-slot!)
    (o 'add-message! 'add-method-slot! root-add-method-slot!)
    (o 'add-message! 'add-parent-slot! root-add-parent-slot!)
    (o 'add-message! 'delete-slot! root-delete-slot!)
    o))

(define (root-clone self resend)
  (let ((child (make-hermes-object)))
    (child 'add-message! 'parent
           (lambda (self2 resend)
             self)
           #t)
    (child 'add-message! 'immediate-slot-list
           (lambda (self2 resend)
             '((parent #f parent))))
    child))

(define root-add-value-slot!
  (make-getter-setter 'add-value-slot! value 'value
                      (lambda (self resend)
                        value)))

(define root-add-method-slot!
  (make-getter-setter 'add-method-slot! value 'method
                      value
                      (lambda (self resend . args)
                        (apply value self resend args))))

(define root-add-parent-slot!
  (make-getter-setter 'add-parent-slot! value 'parent
                      (lambda (self resend)
                        value)))

(define (root-delete-slot! self resend getter)
  (self 'set-immediate-slot-list!
        (let loop ((alis (self 'immediate-slot-list)))
          (cond
           ((null? alis)
            '())
           ((eq? getter (caar alis))
            (self 'delete-message! (cadar alis))
            (loop (cdr alis)))
           (else
            (cons (car alis)
                  (loop (cdr alis)))))))
  (self 'delete-message! getter))

(define (root-immediate-slot-list self resend)
  '((clone #f #f)
    (message-not-understood #f #f)
    (ambiguous-message-send #f #f)
    (immediate-slot-list set-immediate-slot-list! #f)
    (add-value-slot! #f #f)
    (add-method-slot! #f #f)
    (add-parent-slot! #f #f)
    (delete-slot! #f #f)))

(define (root-set-immediate-slot-list! self resend new)
  (self 'add-message! 'immediate-slot-list
        (lambda (self resend)
          new)))

(define (root-message-not-understood self resend message args)
  (error "Message not understood" self message args))

(define (root-ambiguous-message-send self resend message args)
  (error "Message ambiguous" self message args))

(define *the-root-object* (make-prometheus-root-object))

(define-syntax define-method
  (syntax-rules ()
    ((_ (obj 'message self resend args ...)
        body1 body ...)
     (obj 'add-method-slot! 'message
          (lambda (self resend args ...)
            body1 body ...)))))

(define-syntax define-object
  (syntax-rules ()
    ((_ name (creation-parent (parent-name parent-object) ...)
        slots ...)
     (define name (let ((o (creation-parent 'clone)))
                    (o 'add-parent-slot! 'parent-name parent-object)
                    ...
                    (define-object/add-slots! o slots ...)
                    o)))))

(define-syntax define-object/add-slots!
  (syntax-rules ()
    ((_ o)
     (void))
    ((_ o ((method-name . method-args) body ...)
        slots ...)
     (begin
       (o 'add-method-slot! 'method-name (lambda method-args
                                           body ...))
       (define-object/add-slots! o slots ...)))
    ((_ o (slot-getter slot-setter slot-value)
        slots ...)
     (begin
       (o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
       (define-object/add-slots! o slots ...)))
    ((_ o (slot-getter slot-value)
        slots ...)
     (begin
       (o 'add-value-slot! 'slot-getter slot-value)
       (define-object/add-slots! o slots ...)))))