;; hermes.scm --- A very simple prototype-based object system ;; Copyright (C) 2006 Jorgen Schaefer ;; Author: Jorgen Schaefer <forcer@forcix.cx> ;; This program is free software; you can redistribute it and/or ;; modify it under the terms of the GNU General Public License ;; as published by the Free Software Foundation; either version 2 ;; of the License, or (at your option) any later version. ;; This program is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with this program; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA ;; 02110-1301 USA ;;; Commentary: ;; Hermes is a very simple object system upon which Prometheus is ;; built. ;; Hermes provides a simple object which knows about messages, message ;; handlers, and inheritance. Each message is associated with a ;; boolean on whether this messages' value is a parent. ;; More specifically, a Hermes object is a closure to which a message ;; can be sent by applying it to the message name and a possible empty ;; list of message arguments. When the object does not know the ;; message, any parent slot's value is asked to handle this message. ;; If none knows how to, the original object receives a ;; MESSAGE-NOT-UNDERSTOOD message, with the arguments being the ;; message not being understood and a list of arguments. If more than ;; one parent knows about this message, the original object receives a ;; AMBIGUOUS-MESSAGE-SEND message, with the arguments again being the ;; ambiguous message and a list of arguments. Hermes is intelligent ;; enough to notice when the same object is reachable via different ;; parents, so diamond inheritance is no problem. ;; On the other hand, when the objects knows the message, the message ;; handler will be called with the message arguments in addition to ;; two values: SELF, a reference to the object that received the ;; original message, and RESEND, a procedure which can be used to ask ;; other objects to handle this message for you, while maintaining the ;; SELF object. ;; RESEND accepts two or more arguments. The first is the target. If ;; the target is #f, any parent that can handle the message receives ;; it as if the current object wouldn't have been able to handle it by ;; itself. If it is a symbol, the value of the message named by that ;; symbol is used as the parent. If it's an object, that object is ;; used directly. For messages that contain parent objects, the ;; handler must not use RESEND. ;; Hermes objects know about three messages by default, but only one ;; of them is essential. ;; Message: add-message! name handler [parent?] ;; ;; This adds a message named NAME, upon receiving which, HANDLER is ;; called. If PARENT? is supplied and not false, this message contains ;; a parent object. ;; Message: delete-message! name ;; ;; Remove the handler for messages named NAME, and resend them to ;; parent objects in the future again. ;; Message: %get-handler name receiver args visited ;; ;; The only essential message. This enables inheritance. NAME is the ;; name of the message we are looking for. RECEIVER is the original ;; receiver of the message, to be used as the SELF argument to the ;; handler procedure. ARGS is a list of arguments. VISITED is a list ;; of objects we have seen so far. This is used to detect cycles in ;; the inheritance graph. ;; ;; This message returns two values. The first one is the handler and ;; the other one the object in which this handler was found. The ;; handler value can also be one of two symbols to signify an error ;; condition. If it's the symbol MESSAGE-NOT-UNDERSTOOD, then neither ;; this object nor any parents knew how to handle this message. If ;; it's AMBIGUOUS-MESSAGE-SEND, the same message could be handled by ;; multiple parents in the inheritance graph. The user needs to add a ;; message which resends the ambiguous message unambiguously to the ;; correct parent. In either case, the second return value is #f. The ;; handler procedure itself accepts no arguments, and just runs the ;; message. ;;; Code: ;;; Create a new Hermes object. Hermes objects know only three ;;; messages, %GET-HANDLER, ADD-MESSAGE! and DELETE-MESSAGE!. These ;;; suffice to create a more advanced object systems on top of this. (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))) ;;;;;;;;;;;;;;;;;;;;; ;;; Helper procedures (define (assq-set! name value alist) (cond ((assq name alist) => (lambda (entry) (set-cdr! entry value) alist)) (else (alist-cons name value alist)))) ;;;;;;;;;;;;;;;;;;; ;;; Messages record ;;; The messages record stores an association of message names and ;;; message handlers. It also stores such an association for parents. ;;; This uses two lists for efficiency reasons: The list of parents is ;;; needed much more often. (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 (assq-set! name handler (messages-alist msg))) (if parent? (set-messages-parents! msg (assq-set! name handler (messages-parents msg))))) (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)))))))) ;;;;;;;;;;;;;;;;;;;;;;;; ;;; Handling of Messages ;;; 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)))) ;;; hermes.scm ends here