Prometheus is a prototype-based message-passing object system for Scheme similar to the Self language
Prometheus is a prototype-based message-passing object system for Scheme similar to the Self language
In a prototype-based object system, an object is just a set of slots. A slot has a name and a value (or handler procedure). Some slots are special, and are called parent slots.
Objects receive messages. A message consists of a selector and zero or more arguments. When an object receives a message, the handler of the slot with the name equal to the message selector is invoked. When the slot is not in the object, all objects in parent slots are queried for that slot.
An object is created by cloning an existing object. The new object is empty except for a single parent slot, which points to the cloned object. This way, the new object behaves exactly like the old one.
In a prototype-based object system, objects are created and modified until they behave as it is required. Then, that object is cloned to create the real objects to work with—it forms the prototype for the other objects.
Prometheus is shipped as a package for Scheme48. The structure
prometheus serves as the main user API. To use it, issue the
following commands at the REPL:
> ,config ,load .../prometheus/scheme/packages.scm > ,open prometheus
A simple test would be the following:
> (define o (*the-root-object* 'clone)) > (o 'add-value-slot! 'fnord 'set-fnord! 23) > (o 'fnord) 23
In Prometheus, an object is a closure. To send a message to that object, the closure is applied to a number of arguments. The first argument is the message selector, or slot name. The return values of the message are returned from this application.
Prometheus knows about three kinds of slots.
Value slots only store a value which is returned when the corresponding message is received.
Parent slots are just like value slots, but have a special flag marking them as parents.
Method slots contain a procedure which is invoked for messages corresponding to this slot. The procedure is called with at least two arguments, conventionally called self and resend. If the message received any arguments, they are also passed here. Self is the object which received the messages. Resend is a procedure which can be used to resend the message to further parents, if the current method does not wish to handle the message. See Inheritance, for more information about this.
Every slot can be created with an associated setter methods. A setter method is a method which receives a single argument, and replaces the value of the corresponding slot with this argument. Setter methods are removed when the corresponding getter method is removed (but not vice-versa). Because of this, they are sometimes not considered to be slots, even if they are. See Setters are Methods, for an example where this distinction is important.
When a slot for a message is not found in the current object, all parent slots are queried—this is recursive, i.e. parent slots which don't know the slot query their parents, etc.
If no parent knows the slot, the original message receiving object is
message-not-understood message. If more than one parent
knows the slot, the original message receiving object is sent a
ambiguous-message-send message. See Root Objects, for a
documentation of those messages. By default, they signal an error.
A method slot is passed a special procedure,
resend, when it is
This procedure will resend a message. Contrary to sending the message to self, this won't find the current message handler, nor any previous ones which did a resend already. Just sending the message to the parent object directly would mean self now points to the parent object.
Resendwill retain self as it is at the moment.
Whereto can be
#t, indicating to start the lookup for the message in the current object,
#f, indicating to use any parent object, or the name of a specific parent slot, indicating that the lookup should begin in that parent object.
Resend is roughly equivalent to CLOS'
Since objects are created by sending a
clone message to other
objects, there has to be a kind of root object. Prometheus provides a
procedure to create such root objects.
This creates a new root object from which other objects can cloned. This object is independent of any other objects, and thus creates a new inheritance tree.
Prometheus also provides a single existing root object, created with the procedure above. Unless specifically wanted otherwise, using this object as the root object ensures that all prometheus objects share a common ancestor.
This is the default root object. If not really intended otherwise, this should be used as the root of other object hierarchies.
The root objects contain a number of slots by default.
Return a clone of the message recipient. This creates a new object with a single slot, parent, which points to the cloned object.
Add a new value slot to the recipient. The value of the slot can be retrieved with the getter message. If a setter is given, that message can be used to change the value of the slot.
Add a method to the recipient. Sending the object a getter message now invokes proc with the same arguments in addition to a self argument pointing to the current object and a resend procedure available to resend the message if the method does not want to handle it directly.
The setter message can later be used to change the procedure.
Add a parent slot to the recipient. Parent slots are searched for slots not found directly in the object. The setter message, if given, can be used to later change the value of the parent slot.
Delete the slot named getter from the receiving object. This also removes the setter corresponding to getter, if any. Beware that the parents might contain the same slot, so a message send can still succeed even after a slot is deleted.
This message returns a list of slots in this object. The elements of the list are lists with four elements, getter-name, setter-name or
#f, value and type, where type can be
This is received when the message message with arguments args to the object was not understood. The root object just signals an error.
This is received when the message message with arguments args to the object would have reached multiple parents. The root object just signals an error.
Prometheus provides two forms of syntactic sugar for common operations on objects.
A very common operation is to add method slots to an object, which usually looks like this:
(obj 'add-method-slot! 'average (lambda (self resend a b) (/ (+ a b) 2)))
Using the special form of
define-method, this can be shortened
(define-method (obj 'average self resend a b) (/ (+ a b) 2))
This is syntactic sugar for the often-used idiom to define a method slot, by sending a
add-method-slot!message with a message name and a lambda form with self, resend and args formals, and a body.
Another common operation is to clone an object, and add a number of value and method slots:
(define o (*the-root-object* 'clone)) (o 'add-value-slot! 'constant 'set-constant! 5) (o 'add-method-slot! 'add (lambda (self resend summand) (+ summand (self 'constant))))
This can be more succintly written as:
(define-object o (*the-root-object*) (constant set-constant! 5) ((add self resend summand) (+ summand (self 'constant)))
This is syntactic sugar for the typical actions of cloning an object from a parent object, and adding more slots.
other-parents is a list of
(name object)lists, where each object is added as a parent slot named name.
slots is a list of slot specifications, either
(getter setter value)for value slots, or
((name self resend args ...) body ...)for method slots.
Message names in Prometheus don't have any required type. They are
only compared using
eq?. Because of this, any kind of Scheme
object can be used as a message name. This means that it is possible
to use a private Scheme value—for example, a freshly-allocated
list—as a slot name. This can be used to keep slot names private,
since it is not possible to create an object which is
another one except by receiving a reference to that object.
This is from the file examples/account.scm in the Prometheus distribution:
;;; This is a simple account-keeping object. ;;; It's just like a normal object (define account (*the-root-object* 'clone)) ;;; But it has a balance (account 'add-value-slot! 'balance 'set-balance! 0) ;;; Which can be modified (account 'add-method-slot! 'payment! (lambda (self resend amount) (self 'set-balance! (+ (self 'balance) amount)))) ;;; Some tests: (define a1 (account 'clone)) (define a2 (account 'clone)) (a1 'payment! 100) (a2 'payment! 200) (a1 'balance) ;;; => 100 (a2 'balance) ;;; => 200 (a1 'payment! -20) (a1 'balance) ;;; => 80 ;;; The typing for the slot definitions above can be rather tedious. ;;; Prometheus provides syntactic sugar for those operations. ;;; A method can be added with the DEFINE-METHOD syntax. This code is ;;; equivalent to the code above which adds the PAYMENT! method: (define-method (account 'payment! self resend amount) (self 'set-balance! (+ (self 'balance) amount))) ;;; And this defines the whole object with the BALANCE slot and the ;;; PAYMENT! method just as above: (define-object account (*the-root-object*) (balance set-balance! 0) ((payment! self resend amount) (self 'set-balance! (+ (self 'balance) amount))))
This is from the file examples/create-on-use.scm in the Prometheus distribution:
;;; A simple object which creates slots as they are used. This ;;; demonstrates the use of the MESSAGE-NOT-UNDERSTOOD error message. ;;; Slots are pure value slots - no methods are created by default - ;;; and the accessors use a second argument as the "default value". If ;;; that is not given, (if #f #f) is used, which is usually not what ;;; is intended. (define-object create-on-use-object (*the-root-object*) ((message-not-understood self resend slot args) (self 'add-method-slot! slot (lambda (self resend . default) (if (pair? args) (car args)))) (self slot)))
This is from the file examples/diamond.scm in the Prometheus distribution:
;;; This requires SRFI-23 ;;; We create an amphibious vehicle which inherits from a car - which ;;; can only drive on ground - and from a ship - which can only drive ;;; on water. Roads have a type of terrain. The amphibious vehicle ;;; drives along the road, using either the drive method of the car or ;;; of the ship. ;;; First, let's build a road. (define-object road-segment (*the-root-object*) (next set-next! #f) (type set-type! 'ground) ((clone self resend next type) (let ((o (resend #f 'clone))) (o 'set-next! next) (o 'set-type! type) o))) ;;; Create a road with the environment types in the ENVIRONMENTS list. (define (make-road environments) (if (null? (cdr environments)) (road-segment 'clone #f (car environments)) (road-segment 'clone (make-road (cdr environments)) (car environments)))) ;;; Now, we need a vehicle - the base class. (define-object vehicle (*the-root-object*) (location set-location! #f) ((drive self resend) #f) ((clone self resend . location) (let ((o (resend #f 'clone))) (if (not (null? location)) (o 'set-location! (car location))) o))) ;;; All vehicles have to drive quite similarily - no one stops us from ;;; using a normal helper procedure here. (define (handle-drive self handlers) (let ((next ((self 'location) 'next))) (cond ((not next) (display "Yay, we're at the goal!") (newline)) ((assq (next 'type) handlers) => (lambda (handler) ((cdr handler) next))) (else (error "Your vehicle crashed on a road segment of type" (next 'type)))))) ;;; And a car. Hm. Wait. A CAR is something pretty specific in Scheme, ;;; make an automobile instead. (define-object automobile (vehicle) ((drive self resend) (resend #f 'drive) (handle-drive self `((ground . ,(lambda (next) (display "*wrooom*") (newline) (self 'set-location! next))))))) ;;; And now a ship, for waterways. (define-object ship (vehicle) ((drive self resend) (resend #f 'drive) (handle-drive self `((water . ,(lambda (next) (display "*whoosh*") (newline) (self 'set-location! next))))))) ;;; And an amphibious vehicle for good measure! (define-object amphibious (ship (ground-parent automobile)) ((drive self resend) (handle-drive self `((water . ,(lambda (next) (resend 'parent 'drive))) (ground . ,(lambda (next) (resend 'ground-parent 'drive))))))) ;;; The code above works already. We can clone ships, automobiles and ;;; amphibious vehicles as much as we want, and they drive happily on ;;; roads. But we could extend this, and add gas consumption. This ;;; will even modify already existing vehicles, because they inherit ;;; from the vehicle object we extend: (vehicle 'add-value-slot! 'gas 'set-gas! 0) (vehicle 'add-value-slot! 'needed-gas 'set-needed-gas! 0) (define-method (vehicle 'drive self resend) (let ((current-gas (self 'gas)) (needed-gas (self 'needed-gas))) (if (>= current-gas needed-gas) (self 'set-gas! (- current-gas needed-gas)) (error "Out of gas!")))) ;;; If you want to test the speed of the implementation: (define (make-infinite-road) (let* ((ground (road-segment 'clone #f 'ground)) (water (road-segment 'clone ground 'water))) (ground 'set-next! water) ground)) (define (test n) (let ((o (amphibious 'clone (make-infinite-road)))) (do ((i 0 (+ i 1))) ((= i n) #t) (o 'drive))))
This is from the file examples/safe-object.scm in the Prometheus distribution:
;;; This defines two Scheme 48 modules which each exports only a ;;; single value: An object which can't be modified from the outside. ;;; The first version is trivial. We just steal the parent. (define-structure safe-object-full (export full-safe-object) (open scheme prometheus) (begin (define fully-safe-object (*the-root-object* 'clone)) (full-safe-object 'add-value-slot! 'fnord 'set-fnord! 23) (full-safe-object 'delete-slot! 'parent))) ;;; The second assumes you just want to hide a few of the messages of ;;; the parent object. ;;; The trick is to overwrite all modifying messages. Since the parent ;;; object might be used to modify us, we also hide it behind a ;;; private message name. (define-structure safe-object-partial (export partial-safe-object) (open scheme srfi-23 prometheus) (begin (define partial-safe-object ((make-prometheus-root-object) 'clone)) ;; The private parent message (let ((parent (list '*parent-message*))) (partial-safe-object 'add-value-slot! 'immutable 23) ;; Add our private parent (partial-safe-object 'add-parent-slot! parent (safe-object 'parent)) ;; And delete the one added by the clone (partial-safe-object 'delete-slot! 'parent) ;; Overwrite all unneeded slots - since some messages need ;; others internally, we do a resend until we did overwrite all ;; slots: (let ((resend? #t)) (for-each (lambda (msg) (partial-safe-object 'add-method-slot! msg (lambda (self resend . args) (if resend? (apply resend #f msg args) (error "Object is immutable!"))))) '(add-slot-binding! remove-slot-bindings! clone add-value-slot! add-parent-slot! add-method-slot! delete-slot! slots->list)) (set! resend? #f)))))
Since Prometheus does not allow for ambiguous message sends, and setter methods are just messages, this can lead to a confusing situation. Consider the following code:
(define o1 (*the-root-object* 'clone)) (o1 'add-value-slot! 'foo 'set-foo! 1) (define o2 (o1 'clone)) (define o3 (o2 'clone)) (o3 'add-parent-slot! 'parent2 o1)
This creates a diamond-shaped inheritance tree. Now it is possible to
set-foo! message to
o3, though it inherits this
slot from two parents, the slot is ultimately inherited from the same
object. But now witness the following:
> (o3 'foo) => 3 > (o2 'set-foo! 2) > (o3 'set-foo! 3) error--> Ambiguous message send
What happened here? The
set-foo! message added the
o2, but with it, also the associated method to mutate
set-foo!. So, sending
will find the same message both in
o2, and cause an
ambiguous message send.
Morale: Be extra careful with multiple inheritance.