prometheus/hermes-impl.scm

(import
  (scheme)
  (srfi-1)	 ;;List library
  )

(define (make-hermes-object)
  (let ((msg (make-messages)))
    (letrec ((self (lambda (name . args)
                     (messages-handle msg self name args))))
      (messages-add! msg '%get-handler
                     (lambda (_ resend name receiver args visited)
                       (get-handler msg self name receiver args visited))
                     #f)
      (messages-add! msg 'add-message!
                     (lambda (_ resend name handler . parentl)
                       (messages-add! msg name handler
                                      (if (null? parentl)
                                          #f
                                          (car parentl))))
                     #f)
      (messages-add! msg 'delete-message!
                     (lambda (_ resend name)
                       (messages-delete! msg name))
                     #f)
      self)))

(define (alist-set! alist name value)
  (cond
   ((assq name alist)
    => (lambda (entry)
         (set-cdr! entry value)
         alist))
   (else
    (alist-cons name value alist))))

(define-record-type messages
  (%make-messages alist parents)
  messages?
  (alist messages-alist set-messages-alist!)
  (parents messages-parents set-messages-parents!))

(define (make-messages)
  (%make-messages '() '()))

(define (messages-add! msg name handler parent?)
  (set-messages-alist! msg
                       (alist-set! (messages-alist msg)
                                   name handler))
  (if parent?
      (set-messages-parents! msg
                             (alist-set! (messages-parents msg)
                                         name handler))))

(define (messages-delete! msg name)
  (set-messages-alist! msg
                       (alist-delete! name
                                      (messages-alist msg)
                                      eq?))
  (set-messages-parents! msg
                         (alist-delete! name
                                        (messages-parents msg)
                                        eq?)))

;;; Do a direct lookup (as opposed to asking the parents) for a
;;; message handler in the record.
(define (messages-direct-lookup msg name)
  (cond
   ((assq name (messages-alist msg))
    => cdr)
   (else
    #f)))

;;; Ask the parents in the messages record for handlers. This returns
;;; two values as explained above. To enable the
;;; AMBIGUOUS-MESSAGE-SEND error, the parent list is searched
;;; completely even when a handler is found.
(define (messages-parent-lookup msg self name receiver args visited)
  (let loop ((alis (messages-parents msg))
             (handler #f)
             (found #f))
    (if (null? alis)
        (if handler
            (values handler found)
            (values 'message-not-understood #f))
        (receive (new new-found)
            (((cdar alis)
              receiver
              (lambda args
                (error "Parent slots must not use resend."
                       receiver name args)))
             '%get-handler name receiver args (cons self visited))
          (case new
            ((message-not-understood)
             (loop (cdr alis)
                   handler
                   found))
            ((ambiguous-message-send)
             (values 'ambiguous-message-send
                     #f))
            (else
             (if (and handler
                      (and (not (eq? found new-found))))
                 (values 'ambiguous-message-send
                         #f)
                 (loop (cdr alis)
                       new
                       new-found))))))))

;;; Handle a single message, checking for errors.
(define (messages-handle msg self name args)
  (receive (handler found)
      (get-handler msg self name self args '())
    (run-with-error-checking handler self name args)))

;;; Return the appropriate handler procedure.
(define (get-handler msg self name receiver args visited)
  (if (memq self visited)
      (values 'message-not-understood #f)
      (cond
       ((messages-direct-lookup msg name)
        => (lambda (handler)
             (values (lambda ()
                       (apply handler
                              receiver
                              (make-resender msg self receiver visited)
                              args))
                     self)))
       (else
        (messages-parent-lookup msg self name receiver args visited)))))

;;; Create a resender for the message.
(define (make-resender msg self receiver visited)
  (lambda (target name . args)
    (receive (handler found)
        (cond
         ((eq? target #f) ; ask parents
          (messages-parent-lookup msg self name receiver args visited))
         ((or (eq? target self) ; ask this object
              (eq? target #t)) ; hystorical syntax
          (get-handler msg self name receiver args visited))
         ((symbol? target) ; ask named parent
          ((self target) '%get-handler name receiver args (cons self visited)))
         (else ; ask that object
          (target '%get-handler name receiver args (cons self visited))))
      (run-with-error-checking handler self name args))))

;;; Signal the appropriate errors, if handler is not a procedure.
;;; Else, call that handler.
(define (run-with-error-checking handler self name args)
  (case handler
    ((message-not-understood)
     (if (eq? name 'message-not-understood)
         (error "Message MESSAGE-NOT-UNDERSTOOD not understood"
                self args)
         (self 'message-not-understood name args)))
    ((ambiguous-message-send)
     (if (eq? name 'ambiguous-message-send)
         (error "Message AMBIGUOUS-MESSAGE-SEND is ambiguous"
                self args)
         (self 'ambiguous-message-send name args)))
    (else
     (handler))))