source: project/prometheus/prometheus-manual.html @ 1

Last change on this file since 1 was 1, checked in by azul, 14 years ago

Import everything.

File size: 30.9 KB
Line 
1<html lang="en">
2<head>
3<title>The Prometheus prototype-based object system</title>
4<meta http-equiv="Content-Type" content="text/html">
5<meta name="description" content="The Prometheus prototype-based object system">
6<meta name="generator" content="makeinfo 4.7">
7<link title="Top" rel="top" href="#Top">
8<link href="http://www.gnu.org/software/texinfo/" rel="generator-home" title="Texinfo Homepage">
9<!--
10Copyright (C) Jorgen Scha"fer
11
12This program is free software; you can redistribute it and/or
13modify it under the terms of the GNU General Public License
14as published by the Free Software Foundation; either version 2
15of the License, or (at your option) any later version.
16
17This program is distributed in the hope that it will be useful,
18but WITHOUT ANY WARRANTY; without even the implied warranty of
19MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
20GNU General Public License for more details.
21
22You should have received a copy of the GNU General Public License
23along with this program; if not, write to the Free Software
24Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
2502111-1307, USA.-->
26<meta http-equiv="Content-Style-Type" content="text/css">
27<style type="text/css"><!--
28  pre.display { font-family:inherit }
29  pre.format  { font-family:inherit }
30  pre.smalldisplay { font-family:inherit; font-size:smaller }
31  pre.smallformat  { font-family:inherit; font-size:smaller }
32  pre.smallexample { font-size:smaller }
33  pre.smalllisp    { font-size:smaller }
34  span.sc { font-variant:small-caps }
35  span.roman { font-family: serif; font-weight: normal; } 
36--></style>
37</head>
38<body>
39<h1 class="settitle">The Prometheus prototype-based object system</h1>
40   <div class="contents">
41<h2>Table of Contents</h2>
42<ul>
43<li><a name="toc_Top" href="#Top">Prometheus: A prototype-based object system for Scheme</a>
44<li><a name="toc_Introduction" href="#Introduction">1 Introduction</a>
45<li><a name="toc_Installation" href="#Installation">2 Installation</a>
46<li><a name="toc_Prometheus" href="#Prometheus">3 Prometheus</a>
47<ul>
48<li><a href="#Objects">3.1 Objects</a>
49<li><a href="#Slots">3.2 Slots</a>
50<li><a href="#Inheritance">3.3 Inheritance</a>
51<li><a href="#Root-Objects">3.4 Root Objects</a>
52<li><a href="#Syntactic-Sugar">3.5 Syntactic Sugar</a>
53<li><a href="#Private-Messages">3.6 Private Messages</a>
54</li></ul>
55<li><a name="toc_Examples" href="#Examples">4 Examples</a>
56<ul>
57<li><a href="#Simple-Account-Object">4.1 Simple Account Object</a>
58<li><a href="#Creating-Slots-on-Use">4.2 Creating Slots on Use</a>
59<li><a href="#Diamond-Inheritance">4.3 Diamond Inheritance</a>
60<li><a href="#Safe-Objects">4.4 Safe Objects</a>
61</li></ul>
62<li><a name="toc_Pitfalls" href="#Pitfalls">5 Pitfalls</a>
63<ul>
64<li><a href="#Setters-are-Methods">5.1 Setters are Methods</a>
65</li></ul>
66</li></ul>
67</div>
68
69
70
71<div class="node">
72<p><hr>
73<a name="Top"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Introduction">Introduction</a>,
74Previous:&nbsp;<a rel="previous" accesskey="p" href="#dir">(dir)</a>,
75Up:&nbsp;<a rel="up" accesskey="u" href="#dir">(dir)</a>
76<br>
77</div>
78
79<h2 class="unnumbered">Prometheus: A prototype-based object system for Scheme</h2>
80
81<p>Prometheus is a prototype-based message-passing object system for Scheme
82similar to the <a href="http://research.sun.com/self/">Self language</a>
83
84<ul class="menu">
85<li><a accesskey="1" href="#Introduction">Introduction</a>
86<li><a accesskey="2" href="#Installation">Installation</a>
87<li><a accesskey="3" href="#Prometheus">Prometheus</a>
88<li><a accesskey="4" href="#Examples">Examples</a>
89<li><a accesskey="5" href="#Pitfalls">Pitfalls</a>
90</ul>
91
92<div class="node">
93<p><hr>
94<a name="Introduction"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Installation">Installation</a>,
95Previous:&nbsp;<a rel="previous" accesskey="p" href="#Top">Top</a>,
96Up:&nbsp;<a rel="up" accesskey="u" href="#Top">Top</a>
97<br>
98</div>
99
100<h2 class="chapter">1 Introduction</h2>
101
102<p>Prometheus is a prototype-based message-passing object system for Scheme
103similar to the <a href="http://research.sun.com/self/">Self language</a>
104
105   <p>In a prototype-based object system, an object is just a set of slots.
106A slot has a name and a value (or handler procedure). Some slots are
107special, and are called <em>parent slots</em>.
108
109   <p>Objects receive messages. A message consists of a selector and zero or
110more arguments. When an object receives a message, the handler of the
111slot with the name equal to the message selector is invoked. When the
112slot is not in the object, all objects in parent slots are queried for
113that slot.
114
115   <p>An object is created by <em>cloning</em> an existing object. The new
116object is empty except for a single parent slot, which points to the
117cloned object. This way, the new object behaves exactly like the old
118one.
119
120   <p>In a prototype-based object system, objects are created and modified
121until they behave as it is required. Then, that object is cloned to
122create the real objects to work with&mdash;it forms the <em>prototype</em>
123for the other objects.
124
125<div class="node">
126<p><hr>
127<a name="Installation"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Prometheus">Prometheus</a>,
128Previous:&nbsp;<a rel="previous" accesskey="p" href="#Introduction">Introduction</a>,
129Up:&nbsp;<a rel="up" accesskey="u" href="#Top">Top</a>
130<br>
131</div>
132
133<h2 class="chapter">2 Installation</h2>
134
135<p>Prometheus is shipped as a package for Scheme48. The structure
136<code>prometheus</code> serves as the main user API. To use it, issue the
137following commands at the REPL:
138
139<pre class="example">     &gt; ,config ,load .../prometheus/scheme/packages.scm
140     &gt; ,open prometheus
141</pre>
142   <p>A simple test would be the following:
143
144<pre class="example">     &gt; (define o (*the-root-object* 'clone))
145     &gt; (o 'add-value-slot! 'fnord 'set-fnord! 23)
146     &gt; (o 'fnord)
147     23
148</pre>
149   <div class="node">
150<p><hr>
151<a name="Prometheus"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Examples">Examples</a>,
152Previous:&nbsp;<a rel="previous" accesskey="p" href="#Installation">Installation</a>,
153Up:&nbsp;<a rel="up" accesskey="u" href="#Top">Top</a>
154<br>
155</div>
156
157<h2 class="chapter">3 Prometheus</h2>
158
159<ul class="menu">
160<li><a accesskey="1" href="#Objects">Objects</a>
161<li><a accesskey="2" href="#Slots">Slots</a>
162<li><a accesskey="3" href="#Inheritance">Inheritance</a>
163<li><a accesskey="4" href="#Root-Objects">Root Objects</a>
164<li><a accesskey="5" href="#Syntactic-Sugar">Syntactic Sugar</a>
165<li><a accesskey="6" href="#Private-Messages">Private Messages</a>
166</ul>
167
168<div class="node">
169<p><hr>
170<a name="Objects"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Slots">Slots</a>,
171Previous:&nbsp;<a rel="previous" accesskey="p" href="#Prometheus">Prometheus</a>,
172Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
173<br>
174</div>
175
176<h3 class="section">3.1 Objects</h3>
177
178<p>In Prometheus, an object is a closure. To send a message to that
179object, the closure is applied to a number of arguments. The first
180argument is the message selector, or slot name. The return values of
181the message are returned from this application.
182
183<div class="node">
184<p><hr>
185<a name="Slots"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Inheritance">Inheritance</a>,
186Previous:&nbsp;<a rel="previous" accesskey="p" href="#Objects">Objects</a>,
187Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
188<br>
189</div>
190
191<h3 class="section">3.2 Slots</h3>
192
193<p>Prometheus knows about three kinds of slots.
194
195   <p><em>Value slots</em> only store a value which is returned when the
196corresponding message is received.
197
198   <p><em>Parent slots</em> are just like value slots, but have a special flag
199marking them as parents.
200
201   <p><em>Method slots</em> contain a procedure which is invoked for messages
202corresponding to this slot. The procedure is called with at least two
203arguments, conventionally called <var>self</var> and <var>resend</var>. If the
204message received any arguments, they are also passed here. <var>Self</var>
205is the object which received the messages. <var>Resend</var> is a procedure
206which can be used to resend the message to further parents, if the
207current method does not wish to handle the message.
208See <a href="#Inheritance">Inheritance</a>, for more information about this.
209
210   <p>Every slot can be created with an associated <em>setter methods</em>. A
211setter method is a method which receives a single argument, and
212replaces the value of the corresponding slot with this argument.
213Setter methods are removed when the corresponding getter method is
214removed (but not vice-versa). Because of this, they are sometimes not
215considered to be slots, even if they are. See <a href="#Setters-are-Methods">Setters are Methods</a>,
216for an example where this distinction is important.
217
218<div class="node">
219<p><hr>
220<a name="Inheritance"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Root-Objects">Root Objects</a>,
221Previous:&nbsp;<a rel="previous" accesskey="p" href="#Slots">Slots</a>,
222Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
223<br>
224</div>
225
226<h3 class="section">3.3 Inheritance</h3>
227
228<p>When a slot for a message is not found in the current object, all
229parent slots are queried&mdash;this is recursive, i.e. parent slots which
230don't know the slot query their parents, etc.
231
232   <p>If no parent knows the slot, the original message receiving object is
233sent a <code>message-not-understood</code> message. If more than one parent
234knows the slot, the original message receiving object is sent a
235<code>ambiguous-message-send</code> message. See <a href="#Root-Objects">Root Objects</a>, for a
236documentation of those messages. By default, they signal an error.
237
238   <p>A method slot is passed a special procedure, <code>resend</code>, when it is
239invoked.
240
241<div class="defun">
242&mdash; Procedure: <b>resend</b><var> whereto message args <small class="dots">...</small><a name="index-resend-1"></a></var><br>
243<blockquote>
244<p>This procedure will resend a message. Contrary to sending the message
245to <var>self</var>, this won't find the current message handler, nor any
246previous ones which did a resend already. Just sending the message to
247the parent object directly would mean <var>self</var> now points to the
248parent object. <code>Resend</code> will retain <var>self</var> as it is at the
249moment.
250
251        <p><var>Whereto</var> can be <code>#t</code>, indicating to start the lookup for the
252message in the current object, <code>#f</code>, indicating to use any parent
253object, or the name of a specific parent slot, indicating that the
254lookup should begin in that parent object.
255
256        <p><var>Resend</var> is roughly equivalent to CLOS' <code>(next-method)</code>.
257</p></blockquote></div>
258
259<div class="node">
260<p><hr>
261<a name="Root-Objects"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Syntactic-Sugar">Syntactic Sugar</a>,
262Previous:&nbsp;<a rel="previous" accesskey="p" href="#Inheritance">Inheritance</a>,
263Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
264<br>
265</div>
266
267<h3 class="section">3.4 Root Objects</h3>
268
269<p>Since objects are created by sending a <code>clone</code> message to other
270objects, there has to be a kind of root object. Prometheus provides a
271procedure to create such root objects.
272
273<div class="defun">
274&mdash; Procedure: <b>make-prometheus-root-object</b><var><a name="index-make_002dprometheus_002droot_002dobject-2"></a></var><br>
275<blockquote>
276<p>This creates a new root object from which other objects can
277cloned. This object is independent of any other objects, and thus
278creates a new inheritance tree.
279</p></blockquote></div>
280
281<p class="noindent">Prometheus also provides a single existing root object, created with
282the procedure above. Unless specifically wanted otherwise, using this
283object as the root object ensures that all prometheus objects share a
284common ancestor.
285
286<div class="defun">
287&mdash; Variable: <b>*the-root-object*</b><var><a name="index-_002athe_002droot_002dobject_002a-3"></a></var><br>
288<blockquote>
289<p>This is the default root object. If not really intended otherwise,
290this should be used as the root of other object hierarchies.
291</p></blockquote></div>
292
293<p class="noindent">The root objects contain a number of slots by default.
294
295<div class="defun">
296&mdash; Message: <b>clone</b><var><a name="index-clone-4"></a></var><br>
297<blockquote>
298<p>Return a clone of the message recipient. This creates a new object
299with a single slot, <var>parent</var>, which points to the cloned
300object.
301</p></blockquote></div>
302
303<div class="defun">
304&mdash; Message: <b>add-value-slot!</b><var> getter value<a name="index-add_002dvalue_002dslot_0021-5"></a></var><br>
305&mdash; Message: <b>add-value-slot!</b><var> getter setter value<a name="index-add_002dvalue_002dslot_0021-6"></a></var><br>
306<blockquote>
307<p>Add a new value slot to the recipient. The value of the slot can
308be retrieved with the <var>getter</var> message. If a <var>setter</var> is
309given, that message can be used to change the value of the slot.
310</p></blockquote></div>
311
312<div class="defun">
313&mdash; Message: <b>add-method-slot!</b><var> getter proc<a name="index-add_002dmethod_002dslot_0021-7"></a></var><br>
314&mdash; Message: <b>add-method-slot!</b><var> getter setter proc<a name="index-add_002dmethod_002dslot_0021-8"></a></var><br>
315<blockquote>
316<p>Add a method to the recipient. Sending the object a <var>getter</var>
317message now invokes <var>proc</var> with the same arguments in addition
318to a <var>self</var> argument pointing to the current object and a
319<var>resend</var> procedure available to resend the message if the
320method does not want to handle it directly.
321
322        <p>The <var>setter</var> message can later be used to change the
323procedure.
324</p></blockquote></div>
325
326<div class="defun">
327&mdash; Message: <b>add-parent-slot!</b><var> getter parent<a name="index-add_002dparent_002dslot_0021-9"></a></var><br>
328&mdash; Message: <b>add-parent-slot!</b><var> getter setter parent<a name="index-add_002dparent_002dslot_0021-10"></a></var><br>
329<blockquote>
330<p>Add a parent slot to the recipient. Parent slots are searched for
331slots not found directly in the object. The <var>setter</var> message,
332if given, can be used to later change the value of the parent
333slot.
334</p></blockquote></div>
335
336<div class="defun">
337&mdash; Message: <b>delete-slot!</b><var> getter<a name="index-delete_002dslot_0021-11"></a></var><br>
338<blockquote>
339<p>Delete the slot named <var>getter</var> from the receiving object. This
340also removes the setter corresponding to <var>getter</var>, if any.
341Beware that the parents might contain the same slot, so a message
342send can still succeed even after a slot is deleted.
343</p></blockquote></div>
344
345<div class="defun">
346&mdash; Message: <b>slots-&gt;list</b><var><a name="index-slots_002d_003elist-12"></a></var><br>
347<blockquote>
348<p>This message returns a list of slots in this object. The elements
349of the list are lists with four elements, <var>getter-name</var>,
350<var>setter-name</var> or <code>#f</code>, <var>value</var> and <var>type</var>, where
351<var>type</var> can be <code>value</code>, <code>method</code> or <code>parent</code>.
352</p></blockquote></div>
353
354<div class="defun">
355&mdash; Message: <b>message-not-understood</b><var> message args<a name="index-message_002dnot_002dunderstood-13"></a></var><br>
356<blockquote>
357<p>This is received when the message <var>message</var> with arguments
358<var>args</var> to the object was not understood.
359The root object just signals an error.
360</p></blockquote></div>
361
362<div class="defun">
363&mdash; Message: <b>ambiguous-message-send</b><var> message args<a name="index-ambiguous_002dmessage_002dsend-14"></a></var><br>
364<blockquote>
365<p>This is received when the message <var>message</var> with arguments
366<var>args</var> to the object would have reached multiple parents.
367The root object just signals an error.
368</p></blockquote></div>
369
370<div class="node">
371<p><hr>
372<a name="Syntactic-Sugar"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Private-Messages">Private Messages</a>,
373Previous:&nbsp;<a rel="previous" accesskey="p" href="#Root-Objects">Root Objects</a>,
374Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
375<br>
376</div>
377
378<h3 class="section">3.5 Syntactic Sugar</h3>
379
380<p>Prometheus provides two forms of syntactic sugar for common operations
381on objects.
382
383   <p>A very common operation is to add method slots to an object, which
384usually looks like this:
385
386<pre class="lisp">     (obj 'add-method-slot!
387          'average
388          (lambda (self resend a b)
389            (/ (+ a b)
390               2)))
391</pre>
392   <p class="noindent">Using the special form of <code>define-method</code>, this can be shortened
393to:
394
395<pre class="lisp">     (define-method (obj 'average self resend a b)
396       (/ (+ a b)
397          2))
398</pre>
399   <div class="defun">
400&mdash; Syntax: <b>define-method</b> (<var>obj 'message self resend . args</var>)<var> body <small class="dots">...</small><a name="index-define_002dmethod-15"></a></var><br>
401<blockquote>
402<p>This is syntactic sugar for the often-used idiom to define a
403method slot, by sending a <code>add-method-slot!</code> message with a
404<var>message</var> name and a lambda form with <var>self</var>, <var>resend</var>
405and <var>args</var> formals, and a <var>body</var>.
406</p></blockquote></div>
407
408<p class="noindent">Another common operation is to clone an object, and add a number of
409value and method slots:
410
411<pre class="lisp">     (define o (*the-root-object* 'clone))
412     (o 'add-value-slot! 'constant 'set-constant! 5)
413     (o 'add-method-slot! 'add
414        (lambda (self resend summand)
415          (+ summand (self 'constant))))
416</pre>
417   <p class="noindent">This can be more succintly written as:
418
419<pre class="lisp">     (define-object o (*the-root-object*)
420       (constant set-constant! 5)
421       ((add self resend summand)
422        (+ summand (self 'constant)))
423</pre>
424   <div class="defun">
425&mdash; Syntax: <b>define-object</b><var> name </var>(<var>parent other-parents <small class="dots">...</small></var>)<var> slots <small class="dots">...</small><a name="index-define_002dobject-16"></a></var><br>
426<blockquote>
427<p>This is syntactic sugar for the typical actions of cloning an
428object from a <var>parent</var> object, and adding more slots.
429
430        <p><var>other-parents</var> is a list of <code>(name object)</code> lists, where
431each <var>object</var> is added as a parent slot named <var>name</var>.
432
433        <p><var>slots</var> is a list of slot specifications, either <code>(getter
434value)</code> or <code>(getter setter value)</code> for value slots, or
435<code>((name self resend args ...) body ...)</code> for method
436slots.
437</p></blockquote></div>
438
439<div class="node">
440<p><hr>
441<a name="Private-Messages"></a>Previous:&nbsp;<a rel="previous" accesskey="p" href="#Syntactic-Sugar">Syntactic Sugar</a>,
442Up:&nbsp;<a rel="up" accesskey="u" href="#Prometheus">Prometheus</a>
443<br>
444</div>
445
446<h3 class="section">3.6 Private Messages</h3>
447
448<p>Message names in Prometheus don't have any required type. They are
449only compared using <code>eq?</code>. Because of this, any kind of Scheme
450object can be used as a message name. This means that it is possible
451to use a private Scheme value&mdash;for example, a freshly-allocated
452list&mdash;as a slot name. This can be used to keep slot names private,
453since it is not possible to create an object which is <code>eq?</code> with
454another one except by receiving a reference to that object.
455
456<div class="node">
457<p><hr>
458<a name="Examples"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Pitfalls">Pitfalls</a>,
459Previous:&nbsp;<a rel="previous" accesskey="p" href="#Prometheus">Prometheus</a>,
460Up:&nbsp;<a rel="up" accesskey="u" href="#Top">Top</a>
461<br>
462</div>
463
464<h2 class="chapter">4 Examples</h2>
465
466<ul class="menu">
467<li><a accesskey="1" href="#Simple-Account-Object">Simple Account Object</a>
468<li><a accesskey="2" href="#Creating-Slots-on-Use">Creating Slots on Use</a>
469<li><a accesskey="3" href="#Diamond-Inheritance">Diamond Inheritance</a>
470<li><a accesskey="4" href="#Safe-Objects">Safe Objects</a>
471</ul>
472
473<div class="node">
474<p><hr>
475<a name="Simple-Account-Object"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Creating-Slots-on-Use">Creating Slots on Use</a>,
476Previous:&nbsp;<a rel="previous" accesskey="p" href="#Examples">Examples</a>,
477Up:&nbsp;<a rel="up" accesskey="u" href="#Examples">Examples</a>
478<br>
479</div>
480
481<h3 class="section">4.1 Simple Account Object</h3>
482
483<p>This is from the file <span class="file">examples/account.scm</span> in the Prometheus
484distribution:
485
486<pre class="verbatim">;;; This is a simple account-keeping object.
487
488;;; It's just like a normal object
489(define account (*the-root-object* 'clone))
490
491;;; But it has a balance
492(account 'add-value-slot! 'balance 'set-balance! 0)
493
494;;; Which can be modified
495(account 'add-method-slot! 'payment!
496         (lambda (self resend amount)
497           (self 'set-balance!
498                 (+ (self 'balance)
499                    amount))))
500
501;;; Some tests:
502(define a1 (account 'clone))
503(define a2 (account 'clone))
504
505(a1 'payment! 100)
506(a2 'payment! 200)
507
508(a1 'balance)
509;;; => 100
510(a2 'balance)
511;;; => 200
512
513(a1 'payment! -20)
514(a1 'balance)
515;;; => 80
516
517;;; The typing for the slot definitions above can be rather tedious.
518;;; Prometheus provides syntactic sugar for those operations.
519
520;;; A method can be added with the DEFINE-METHOD syntax. This code is
521;;; equivalent to the code above which adds the PAYMENT! method:
522(define-method (account 'payment! self resend amount)
523  (self 'set-balance!
524        (+ (self 'balance)
525           amount)))
526
527;;; And this defines the whole object with the BALANCE slot and the
528;;; PAYMENT! method just as above:
529(define-object account (*the-root-object*)
530  (balance set-balance! 0)
531  ((payment! self resend amount)
532   (self 'set-balance!
533         (+ (self 'balance)
534            amount))))
535</pre>
536
537<div class="node">
538<p><hr>
539<a name="Creating-Slots-on-Use"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Diamond-Inheritance">Diamond Inheritance</a>,
540Previous:&nbsp;<a rel="previous" accesskey="p" href="#Simple-Account-Object">Simple Account Object</a>,
541Up:&nbsp;<a rel="up" accesskey="u" href="#Examples">Examples</a>
542<br>
543</div>
544
545<h3 class="section">4.2 Creating Slots on Use</h3>
546
547<p>This is from the file <span class="file">examples/create-on-use.scm</span> in the
548Prometheus distribution:
549
550<pre class="verbatim">;;; A simple object which creates slots as they are used. This
551;;; demonstrates the use of the MESSAGE-NOT-UNDERSTOOD error message.
552
553;;; Slots are pure value slots - no methods are created by default -
554;;; and the accessors use a second argument as the "default value". If
555;;; that is not given, (if #f #f) is used, which is usually not what
556;;; is intended.
557(define-object create-on-use-object (*the-root-object*)
558  ((message-not-understood self resend slot args)
559   (self 'add-method-slot! slot (lambda (self resend . default)
560                                  (if (pair? args)
561                                      (car args))))
562   (self slot)))
563</pre>
564
565<div class="node">
566<p><hr>
567<a name="Diamond-Inheritance"></a>Next:&nbsp;<a rel="next" accesskey="n" href="#Safe-Objects">Safe Objects</a>,
568Previous:&nbsp;<a rel="previous" accesskey="p" href="#Creating-Slots-on-Use">Creating Slots on Use</a>,
569Up:&nbsp;<a rel="up" accesskey="u" href="#Examples">Examples</a>
570<br>
571</div>
572
573<h3 class="section">4.3 Diamond Inheritance</h3>
574
575<p>This is from the file <span class="file">examples/diamond.scm</span> in the Prometheus
576distribution:
577
578<pre class="verbatim">;;; This requires SRFI-23
579
580;;; We create an amphibious vehicle which inherits from a car - which
581;;; can only drive on ground - and from a ship - which can only drive
582;;; on water. Roads have a type of terrain. The amphibious vehicle
583;;; drives along the road, using either the drive method of the car or
584;;; of the ship.
585
586;;; First, let's build a road.
587(define-object road-segment (*the-root-object*)
588  (next set-next! #f)
589  (type set-type! 'ground)
590  ((clone self resend next type)
591   (let ((o (resend #f 'clone)))
592     (o 'set-next! next)
593     (o 'set-type! type)
594     o)))
595
596;;; Create a road with the environment types in the ENVIRONMENTS list.
597(define (make-road environments)
598  (if (null? (cdr environments))
599      (road-segment 'clone
600                    #f
601                    (car environments))
602      (road-segment 'clone
603                    (make-road (cdr environments))
604                    (car environments))))
605
606;;; Now, we need a vehicle - the base class.
607(define-object vehicle (*the-root-object*)
608  (location set-location! #f)
609  ((drive self resend)
610   #f)
611  ((clone self resend . location)
612   (let ((o (resend #f 'clone)))
613     (if (not (null? location))
614         (o 'set-location! (car location)))
615     o)))
616
617
618;;; All vehicles have to drive quite similarily - no one stops us from
619;;; using a normal helper procedure here.
620(define (handle-drive self handlers)
621  (let ((next ((self 'location) 'next)))
622    (cond
623     ((not next)
624      (display "Yay, we're at the goal!")
625      (newline))
626     ((assq (next 'type) handlers)
627      => (lambda (handler)
628           ((cdr handler) next)))
629     (else
630      (error "Your vehicle crashed on a road segment of type"
631             (next 'type))))))
632
633;;; And a car. Hm. Wait. A CAR is something pretty specific in Scheme,
634;;; make an automobile instead.
635(define-object automobile (vehicle)
636  ((drive self resend)
637   (resend #f 'drive)
638   (handle-drive self `((ground . ,(lambda (next)
639                                     (display "*wrooom*")
640                                     (newline)
641                                     (self 'set-location! next)))))))
642
643;;; And now a ship, for waterways.
644(define-object ship (vehicle)
645  ((drive self resend)
646   (resend #f 'drive)
647   (handle-drive self `((water . ,(lambda (next)
648                                    (display "*whoosh*")
649                                    (newline)
650                                    (self 'set-location! next)))))))
651
652;;; And an amphibious vehicle for good measure!
653(define-object amphibious (ship (ground-parent automobile))
654  ((drive self resend)
655   (handle-drive self `((water . ,(lambda (next)
656                                   (resend 'parent 'drive)))
657                       (ground . ,(lambda (next)
658                                    (resend 'ground-parent 'drive)))))))
659
660
661;;; The code above works already. We can clone ships, automobiles and
662;;; amphibious vehicles as much as we want, and they drive happily on
663;;; roads. But we could extend this, and add gas consumption. This
664;;; will even modify already existing vehicles, because they inherit
665;;; from the vehicle object we extend:
666(vehicle 'add-value-slot! 'gas 'set-gas! 0)
667(vehicle 'add-value-slot! 'needed-gas 'set-needed-gas! 0)
668(define-method (vehicle 'drive self resend)
669  (let ((current-gas (self 'gas))
670        (needed-gas (self 'needed-gas)))
671    (if (>= current-gas needed-gas)
672        (self 'set-gas! (- current-gas needed-gas))
673        (error "Out of gas!"))))
674
675;;; If you want to test the speed of the implementation:
676(define (make-infinite-road)
677  (let* ((ground (road-segment 'clone #f 'ground))
678         (water (road-segment 'clone ground 'water)))
679    (ground 'set-next! water)
680    ground))
681
682(define (test n)
683  (let ((o (amphibious 'clone (make-infinite-road))))
684    (do ((i 0 (+ i 1)))
685        ((= i n) #t)
686      (o 'drive))))
687
688</pre>
689
690<div class="node">
691<p><hr>
692<a name="Safe-Objects"></a>Previous:&nbsp;<a rel="previous" accesskey="p" href="#Diamond-Inheritance">Diamond Inheritance</a>,
693Up:&nbsp;<a rel="up" accesskey="u" href="#Examples">Examples</a>
694<br>
695</div>
696
697<h3 class="section">4.4 Safe Objects</h3>
698
699<p>This is from the file <span class="file">examples/safe-object.scm</span> in the Prometheus
700distribution:
701
702<pre class="verbatim">;;; This defines two Scheme 48 modules which each exports only a
703;;; single value: An object which can't be modified from the outside.
704
705;;; The first version is trivial. We just steal the parent.
706
707(define-structure safe-object-full (export full-safe-object)
708  (open scheme
709        prometheus)
710  (begin
711    (define fully-safe-object (*the-root-object* 'clone))
712    (full-safe-object 'add-value-slot! 'fnord 'set-fnord! 23)
713    (full-safe-object 'delete-slot! 'parent)))
714
715;;; The second assumes you just want to hide a few of the messages of
716;;; the parent object.
717
718;;; The trick is to overwrite all modifying messages. Since the parent
719;;; object might be used to modify us, we also hide it behind a
720;;; private message name.
721
722(define-structure safe-object-partial (export partial-safe-object)
723  (open scheme
724        srfi-23
725        prometheus)
726  (begin
727    (define partial-safe-object ((make-prometheus-root-object) 'clone))
728    ;; The private parent message
729    (let ((parent (list '*parent-message*)))
730      (partial-safe-object 'add-value-slot! 'immutable 23)
731      ;; Add our private parent
732      (partial-safe-object 'add-parent-slot! parent (safe-object 'parent))
733      ;; And delete the one added by the clone
734      (partial-safe-object 'delete-slot! 'parent)
735      ;; Overwrite all unneeded slots - since some messages need
736      ;; others internally, we do a resend until we did overwrite all
737      ;; slots:
738      (let ((resend? #t))
739        (for-each (lambda (msg)
740                    (partial-safe-object
741                     'add-method-slot! msg
742                     (lambda (self resend . args)
743                       (if resend?
744                           (apply resend #f msg args)
745                           (error "Object is immutable!")))))
746                  '(add-slot-binding!
747                    remove-slot-bindings!
748                    clone
749                    add-value-slot!
750                    add-parent-slot!
751                    add-method-slot!
752                    delete-slot!
753                    slots->list))
754        (set! resend? #f)))))
755</pre>
756
757<div class="node">
758<p><hr>
759<a name="Pitfalls"></a>Previous:&nbsp;<a rel="previous" accesskey="p" href="#Examples">Examples</a>,
760Up:&nbsp;<a rel="up" accesskey="u" href="#Top">Top</a>
761<br>
762</div>
763
764<h2 class="chapter">5 Pitfalls</h2>
765
766<ul class="menu">
767<li><a accesskey="1" href="#Setters-are-Methods">Setters are Methods</a>
768</ul>
769
770<div class="node">
771<p><hr>
772<a name="Setters-are-Methods"></a>Previous:&nbsp;<a rel="previous" accesskey="p" href="#Pitfalls">Pitfalls</a>,
773Up:&nbsp;<a rel="up" accesskey="u" href="#Pitfalls">Pitfalls</a>
774<br>
775</div>
776
777<h3 class="section">5.1 Setters are Methods</h3>
778
779<p>Since Prometheus does not allow for ambiguous message sends, and setter
780methods are just messages, this can lead to a confusing situation.
781Consider the following code:
782
783<pre class="lisp">     (define o1 (*the-root-object* 'clone))
784     (o1 'add-value-slot! 'foo 'set-foo! 1)
785     (define o2 (o1 'clone))
786     (define o3 (o2 'clone))
787     (o3 'add-parent-slot! 'parent2 o1)
788</pre>
789   <p class="noindent">This creates a diamond-shaped inheritance tree. Now it is possible to
790send a <code>set-foo!</code> message to <code>o3</code>, though it inherits this
791slot from two parents, the slot is ultimately inherited from the same
792object. But now witness the following:
793
794<pre class="lisp">     &gt; (o3 'foo)
795     =&gt; 3
796     &gt; (o2 'set-foo! 2)
797     &gt; (o3 'set-foo! 3)
798     error--&gt; Ambiguous message send
799</pre>
800   <p class="noindent">What happened here? The <code>set-foo!</code> message added the <code>foo</code>
801slot to <code>o2</code>, but with it, also the associated method to mutate
802that slot, <code>set-foo!</code>. So, sending <code>set-foo!</code> to <code>o3</code>
803will find the same message both in <code>o1</code> and <code>o2</code>, and cause an
804ambiguous message send.
805
806   <p>Morale: Be extra careful with multiple inheritance.
807
808</body></html>
809
Note: See TracBrowser for help on using the repository browser.