source: project/release/3/prometheus/prometheus.scm @ 18200

Last change on this file since 18200 was 6481, checked in by felix winkelmann, 12 years ago

fixed srfi-1 dep.

File size: 23.8 KB
Line 
1;;; prometheus.scm --- The user interface to the Prometheus object system
2
3;; Copyright (C) 2005 Jorgen Schaefer
4
5;; Author: Jorgen Schaefer <forcer@forcix.cx>
6
7;; This program is free software; you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License
9;; as published by the Free Software Foundation; either version 2
10;; of the License, or (at your option) any later version.
11
12;; This program is distributed in the hope that it will be useful,
13;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15;; GNU General Public License for more details.
16
17;; You should have received a copy of the GNU General Public License
18;; along with this program; if not, write to the Free Software
19;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
20;; 02111-1307, USA.
21
22;;; Commentary:
23
24;; This is the user API to the Prometheus object system.
25
26;; We provide value slots which only return a value, and an
27;; infrastructure for setters for value, method and parent slots.
28;; Especially the setters for value slots are much more efficient than
29;; DELETE-SLOT! + ADD-SLOT!, as they use shared store.
30
31;; See the Prometheus manual for more information.
32
33;;; Code:
34
35(use srfi-1)
36
37(module prometheus-internal (make-prometheus-internal-root-object)
38
39;;;;;;;;;;;;;;;;;;;
40;;; Root Object ;;;
41;;;;;;;;;;;;;;;;;;;
42
43;; This creates a root object which only provides the bare-bones
44;; interface of the prometheus-internal.
45
46(define (make-prometheus-internal-root-object)
47  (let ((obj (make-prometheus-object)))
48    (for-each (lambda (entry)
49                (add-slot! obj #f (car entry) (cadr entry)))
50              `((add-slot!        ,add-slot!)
51                (delete-slot!     ,delete-slot!)
52                (clone            ,clone)
53                (message-not-understood ,message-not-understood)
54                (ambiguous-message-send ,ambiguous-message-send)))
55    obj))
56
57;;;;;;;;;;;;;;;;
58;;; Messages ;;;
59;;;;;;;;;;;;;;;;
60
61;;; @deffn Message clone
62;;;
63;;; Return a clone of the message recipient. This creates a new object
64;;; with a single slot, @defvar{parent}, which points to the cloned
65;;; object.
66;;; @end deffn
67(define (clone self resend)
68  (let ((new (make-prometheus-object)))
69    (add-slot! new #f 'parent self #t)
70    new))
71
72;;; @deffn Message add-slot! name proc [parent?]
73;;;
74;;; Add a method to the recipient. Sending the object a @var{name}
75;;; message now invokes @var{proc} with the same arguments in addition
76;;; to a @var{self} argument pointing to the current object and a
77;;; @var{resend} procedure available to resend the message if the
78;;; method does not want to handle it directly.
79;;; @end deffn
80(define (add-slot! self resend name proc . rest)
81  ;; FIXME! Maybe at one point do a type check of PROC?
82  (let ((parent? (if (null? rest)
83                     #f
84                     (car rest))))
85    (if (not parent?)
86        (obj-add-slot! self name proc #f)
87        (obj-add-slot! self
88                       name
89                       (lambda (self resend)
90                         proc)
91                       proc))))
92
93;;; @deffn Message delete-slot! name
94;;;
95;;; Delete the slot @var{name} from the receiving object. Beware that
96;;; parents might contain the same slot, so a message send can still
97;;; succeed even after a slot is deleted.
98;;; @end deffn
99(define (delete-slot! self resend name)
100  (obj-delete-slot! self name))
101
102;;; @deffn message-not-understood message args
103;;;
104;;; This is received when the message @var{message} with arguments
105;;; @var{args} to the object was not understood.
106;;; The root object just signals an error.
107;;; @end deffn
108(define (message-not-understood self resend message args)
109  (error "Message not understood" self message args))
110
111;;; @deffn ambiguous-message-send message args
112;;;
113;;; This is received when the message @var{message} with arguments
114;;; @var{args} to the object would have reached multiple parents.
115;;; The root object just signals an error.
116;;; @end deffn
117(define (ambiguous-message-send self resend message args)
118  (error "Ambiguous message send" self message args))
119
120
121;;;;;;;;;;;;;;;;;;;
122;;; Object Data ;;;
123;;;;;;;;;;;;;;;;;;;
124
125;; Object data stores the data in each object. We retrieve this data
126;; with a special private message, and then can operate on it. It
127;; would not be necessary to store the parent list separately, but we
128;; do that for speed reasons.
129
130(define-record-type prometheus-data
131  (make-prometheus-data slots parents)
132  prometheus-data?
133  (slots prometheus-data-slots
134         set-prometheus-data-slots!)
135  (parents prometheus-data-parents
136           set-prometheus-data-parents!))
137
138;; We don't check for duplicates in this code for speed reasons. The
139;; code that uses these procedures should take care of ensuring that
140;; no duplicates are added.
141
142(define (data-add-parent! data name parent)
143  (set-prometheus-data-parents! data
144                                (cons (cons name parent)
145                                      (prometheus-data-parents data)))
146  (values))
147
148(define (data-delete-parent! data name)
149  (set-prometheus-data-parents! data
150                                (alist-delete! name
151                                               (prometheus-data-parents data)
152                                               eq?))
153  (values))
154
155(define (data-get-slot data name)
156  (assq name (prometheus-data-slots data)))
157
158(define (data-add-slot! data name slot)
159  (set-prometheus-data-slots! data
160                              (cons (cons name slot)
161                                    (prometheus-data-slots data)))
162  (values))
163
164(define (data-delete-slot! data name)
165  (set-prometheus-data-slots! data
166                              (alist-delete! name
167                                             (prometheus-data-slots data)))
168  (values))
169
170;;;;;;;;;;;;;;;;;;;;
171;;; Object Slots ;;;
172;;;;;;;;;;;;;;;;;;;;
173
174;; This record type stores the information about the slots within an
175;; object. The handler is just the procedure to be called when the
176;; message is received; the parent is true only if this slot is a
177;; parent, and then this is the parent object. This way, we can avoid
178;; calling the handler again to retrieve it.
179
180(define-record-type prometheus-slot
181  (make-prometheus-slot handler parent)
182  prometheus-slot?
183  (handler prometheus-slot-handler)
184  (parent prometheus-slot-parent))
185
186
187;;; This is the internal message sent to the object to retrieve the
188;;; data. Since this is a list, it can't be faked from outside the
189;;; module.
190(define *prometheus-get-data-message* (list '*prometheus-get-data-message*))
191
192(define (make-prometheus-object)
193  (let* ((data (make-prometheus-data '() '()))
194         (self #f)
195         (obj (lambda (message . args)
196                (if (eq? message *prometheus-get-data-message*)
197                    data
198                    (send self message args)))))
199    (set! self obj)
200    obj))
201
202(define (prometheus-object-data obj)
203  (obj *prometheus-get-data-message*))
204
205(define (obj-add-slot! obj name handler parent)
206  (let ((new-slot (make-prometheus-slot handler parent))
207        (data (prometheus-object-data obj)))
208    (cond
209     ((data-get-slot data name)
210      => (lambda (entry)
211           (if (prometheus-slot-parent (cdr entry))
212               (data-delete-parent! obj name))
213           (if parent
214               (data-add-parent! data name parent))
215           (set-cdr! entry new-slot)))
216     (else
217      (data-add-slot! data name new-slot)
218      (if parent
219          (data-add-parent! data name parent)))))
220  (values))
221
222(define (obj-delete-slot! obj name)
223  (let ((data (prometheus-object-data obj)))
224    (cond
225     ((data-get-slot data name)
226      => (lambda (entry)
227           (data-delete-slot! data name)
228           (if (prometheus-slot-parent (cdr entry))
229               (data-delete-parent! data name))))))
230  (values))
231
232;;;;;;;;;;;;;;;;;;;;;;;
233;;; Message Sending ;;;
234;;;;;;;;;;;;;;;;;;;;;;;
235
236;; PROC is a handler for the message ARGS in MESSAGE-HOLDER, where the
237;; message was originally sent to OBJ. Evaluate this message,
238;; providing the resend procedure.
239(define (eval-message obj message-holder proc args)
240  (apply proc
241         obj
242         (lambda (parent message . args)
243           (cond
244            ((eq? parent #f)
245             (undirected-resend obj message-holder message args))
246            ((eq? parent #t)
247             (undirected-local-resend obj message-holder message args))
248            (else
249             (directed-resend obj message-holder parent message args))))
250         args))
251
252
253;; Inputs: rec  - the receiver of the message
254;;         sel  - the message selector
255;;         args - the actual arguments
256;; Output: res  - the result object
257;;
258;; send (rec, sel, args) {
259;;   M <- lookup(rec, sel, '())
260;;   if |M| = 0: error: message-not-understood
261;;      |M| = 1: res <- eval(rec, M, args)
262;;      |M| > 1: error: ambiguous-message-send
263;;   return res
264;; }
265(define (send obj message args)
266  (send-with-receiver obj obj #f message args))
267
268;; Inputs: rec  - the receiver of the message
269;;         smh  - the sending method holder
270;;         sel  - the message selector
271;;         args - the actual arguments
272;; Output: res  - the result object
273;;
274;; undirected_resend (rec, smh, sel, args) {
275;;   M <- parent_lookup(smh, sel '())
276;;   if |M| = 0: error: message-not-understood
277;;      |M| = 1: res <- eval(rec, M, args)
278;;      |M| > 1: error: ambiguous-message-send
279;;   end
280;;   return res
281;; }
282(define (undirected-resend obj old-message-holder message args)
283  (send-with-receiver obj old-message-holder #t message args))
284
285;; This is the same as UNDIRECTED-RESEND, but it starts searching in
286;; the current object.
287(define (undirected-local-resend obj old-message-holder message args)
288  (send-with-receiver obj old-message-holder #f message args))
289
290
291;; Inputs: rec - the receiver of the message
292;;         smh - the sending method holder
293;;         del - the name of the delegatee
294;;         sel - the message selector
295;; Output: res - the result object
296;;
297;; directed_resend (rec, smh, del, sel, args) {
298;;   D <- { s \in smh | s.name = del }
299;;   if |D| = 0
300;;   then
301;;     error: missing-delegatee
302;;   fi
303;;   M <- lookup(smh.del, sel, '())
304;;   if |M| = 0: error: message-not-understood
305;;      |M| = 1: res <- eval(rec, M, args)
306;;      |M| > 1: error: ambiguous-message-send
307;;   end
308;;   return res
309;; }
310(define (directed-resend obj old-message-holder parent message args)
311  (send-with-receiver obj
312                      (send-with-receiver old-message-holder
313                                          old-message-holder
314                                          #f
315                                          parent
316                                          '())
317                      #f
318                      message
319                      args))
320
321;; Send the MESSAGE with ARGS to RECEIVER, but start with lookup only
322;; in LOOKUP-OBJ, or in its parents when START-WITH-PARENTS? is true.
323(define (send-with-receiver receiver lookup-obj start-with-parents?
324                            message args)
325  (receive (proc message-holder error-name)
326      (if start-with-parents?
327          (parent-lookup lookup-obj message '())
328          (lookup lookup-obj message '()))
329    (if (not error-name)
330        (eval-message receiver message-holder proc args)
331        (case error-name
332          ((message-not-understood)
333           (if (eq? message 'message-not-understood)
334               (error "No message not understood handler" receiver message args)
335               (receiver 'message-not-understood message args)))
336          ((ambiguous-message-send)
337           (if (eq? message 'ambiguous-message-send)
338               (error "No ambiguous message send handler" receiver message args)
339               (receiver 'ambiguous-message-send message args)))
340          (else
341           (error "Unknown error" error-name receiver message args))))))
342
343;; Inputs: obj - the object being searched
344;;         sel - the message selector
345;;         V   - visited objects
346;; Output: M   - set of matching slots
347;;
348;; lookup (obj, sel, V) {
349;;   if obj \in V
350;;   then
351;;     res <- '()
352;;   else
353;;     M <- { s \in obj | s.name = sel }
354;;     if M = '()
355;;     then
356;;        M <- parent_lookup(obj, sel, V)
357;;     end
358;;   end
359;;   return M
360;; }
361(define (lookup obj message visited)
362  ;; We use ASSQ for the cycle detection, as ASSQ is a primitive in
363  ;; Scheme 48 as compared to MEMQ. This increases speed measurably.
364  (cond
365   ((assq obj visited)
366    (values #f #f 'message-not-understood))
367   ((lookup-immediate obj message)
368    => (lambda (value)
369         (values value obj #f)))
370   (else
371    (parent-lookup obj message visited))))
372
373(define (lookup-immediate obj message)
374  (cond
375   ((data-get-slot (prometheus-object-data obj)
376                   message)
377    => (lambda (entry)
378         (prometheus-slot-handler (cdr entry))))
379   (else
380    #f)))
381
382;; parent_lookup (obj, sel, V) {
383;;   P <- { s \in obj | s.isParent }
384;;   M <- \union_{s \in P} lookup(s.contents, sel, V \union { obj })
385;; }
386(define (parent-lookup obj message old-visited)
387  (let ((visited (cons (list obj) old-visited)))
388    (let loop ((lis (prometheus-data-parents (prometheus-object-data obj)))
389               (message-holder #f)
390               (value #f))
391      (if (null? lis)
392          (if message-holder
393              (values value message-holder #f)
394              (values #f #f 'message-not-understood))
395          (receive (proc this-message-holder error)
396              (lookup (cdar lis) message visited)
397            (cond
398             ((and message-holder
399                   this-message-holder
400                   (not (eq? message-holder this-message-holder)))
401              (values #f #f 'ambiguous-message-send))
402             (this-message-holder
403              (loop (cdr lis)
404                    this-message-holder
405                    proc))
406             (else
407              (loop (cdr lis)
408                    message-holder
409                    value))))))))
410)
411
412(module prometheus (make-prometheus-root-object
413                    *the-root-object*
414                    define-method
415                    define-object define-object/add-slots!)
416
417  (import prometheus-internal)
418
419;; Our private slot message to access the slot list.
420(define *prometheus-mutate-slots-message*
421  (list '*prometheus-mutate-slots-message*))
422
423;; We keep a local list of slots so we can access them later (for
424;; introspection), and to mutate slots which are shared between
425;; setters and getters.
426(define-record-type prometheus-mutable-slot
427  (make-prometheus-mutable-slot getter setter value type)
428  prometheus-mutable-slot?
429  (getter slot-getter set-slot-getter!)
430  (setter slot-setter set-slot-setter!)
431  (value  slot-value  set-slot-value!)
432  (type   slot-type))
433
434;;; @deffn Message clone
435;;;
436;;; Return a clone of the message recipient. This creates a new object
437;;; with a single slot, @var{parent}, which points to the cloned
438;;; object.
439;;; @end deffn
440(define (clone self resend)
441  (let ((new-obj (resend #f 'clone))
442        (slots '()))
443    (new-obj 'add-method-slot! *prometheus-mutate-slots-message*
444             (lambda (self resend proc)
445               (set! slots (proc slots))))
446    new-obj))
447
448;;; @deffn Message add-value-slot! getter value
449;;; @deffnx Message add-value-slot! getter setter value
450;;;
451;;; Add a new value slot to the recipient. The value of the slot can
452;;; be retrieved with the @var{getter} message. If a @var{setter} is
453;;; given, that message can be used to change the value of the slot.
454;;; @end deffn
455(define add-value-slot!
456  (case-lambda
457   ((self resend getter value)
458    (let ((slot (make-prometheus-mutable-slot getter #f value 'value)))
459      (self 'delete-slot! getter)
460      (add-mutable-slot! self getter slot)
461      (resend #f 'add-slot! getter (lambda (self resend)
462                                     value))))
463   ((self resend getter setter value)
464    (let ((slot (make-prometheus-mutable-slot getter setter value 'value)))
465      (self 'delete-slot! getter)
466      (self 'delete-slot! setter)
467      (add-mutable-slot! self getter slot)
468      (resend #f 'add-slot! getter
469              (lambda (self resend)
470                (slot-value slot)))
471      (resend #f 'add-slot! setter
472              (lambda (new-self resend new-value)
473                (if (eq? new-self self)
474                    (set-slot-value! slot new-value)
475                    (new-self 'add-value-slot! getter setter new-value))))))))
476
477;;; @deffn Message add-method-slot! getter proc
478;;; @deffnx Message add-method-slot! getter setter proc
479;;;
480;;; Add a method to the recipient. Sending the object a @var{getter}
481;;; message now invokes @var{proc} with the same arguments in addition
482;;; to a @var{self} argument pointing to the current object and a
483;;; @var{resend} procedure available to resend the message if the
484;;; method does not want to handle it directly.
485;;;
486;;; The @var{setter} message can later be used to change the
487;;; procedure.
488;;; @end deffn
489(define add-method-slot!
490  (case-lambda
491   ((self resend getter value)
492    (let ((slot (make-prometheus-mutable-slot getter #f value 'method)))
493      (self 'delete-slot! getter)
494      (add-mutable-slot! self getter slot)
495      (resend #f 'add-slot! getter value)))
496   ((self resend getter setter value)
497    (let ((slot (make-prometheus-mutable-slot getter setter value 'method)))
498      (self 'delete-slot! getter)
499      (self 'delete-slot! setter)
500      (add-mutable-slot! self getter slot)
501      (resend #f 'add-slot! getter value)
502      (resend #f 'add-slot! setter
503              (lambda (new-self resend new-value)
504                (new-self 'add-method-slot! getter new-value)))))))
505
506;;; @deffn Message add-parent-slot! getter parent
507;;; @deffnx Message add-parent-slot! getter setter parent
508;;;
509;;; Add a parent slot to the recipient. Parent slots are searched for
510;;; slots not found directly in the object. The @var{setter} message,
511;;; if given, can be used to later change the value of the parent
512;;; slot.
513;;; @end deffn
514(define add-parent-slot!
515  (case-lambda
516   ((self resend getter value)
517    (let ((slot (make-prometheus-mutable-slot getter #f value 'parent)))
518      (self 'delete-slot! getter)
519      (add-mutable-slot! self getter slot)
520      (resend #f 'add-slot! getter value #t)))
521   ((self resend getter setter value)
522    (let ((slot (make-prometheus-mutable-slot getter setter value 'parent)))
523      (self 'delete-slot! getter)
524      (self 'delete-slot! setter)
525      (add-mutable-slot! self getter slot)
526      (resend #f 'add-slot! getter value #t)
527      (resend #f 'add-slot! setter
528              (lambda (self resend value)
529                (self 'add-parent-slot! getter value))
530              #f)))))
531
532;;; @deffn Message delete-slot! getter
533;;;
534;;; Delete the slot named @var{getter} from the receiving object. This
535;;; also removes the setter corresponding to @var{getter}, if any.
536;;; Beware that the parents might contain the same slot, so a message
537;;; send can still succeed even after a slot is deleted.
538;;; @end deffn
539(define (delete-slot! self resend getter)
540  (delete-mutable-slot! self  getter)
541  (resend #f 'delete-slot! getter))
542
543;;; Add to the local list. A mutable slot is the slot shared between a
544;;; getter and the setter.
545;;; If already there, remove getter and setter
546(define (add-mutable-slot! obj name slot)
547  (delete-mutable-slot! obj name)
548  (obj *prometheus-mutate-slots-message*
549       (lambda (old)
550         (cons slot old))))
551
552;;; Delete from the local list
553;;; - If it's a getter, remove setter
554;;; - If it's a setter, make setter slot #f
555(define (delete-mutable-slot! obj name)
556  (obj *prometheus-mutate-slots-message*
557       (lambda (old)
558         (filter (lambda (slot)
559                   (if (eq? name (slot-setter slot))
560                       (set-slot-setter! slot #f))
561                   (if (eq? name (slot-getter slot))
562                       (begin
563                         (if (slot-setter slot)
564                             (obj 'delete-slot! (slot-setter slot)))
565                         #f)
566                       #t))
567                 old))))
568
569;;; @deffn Message slots->list
570;;;
571;;; This message returns a list of slots in this object. The elements
572;;; of the list are lists with four elements, @var{getter-name},
573;;; @var{setter-name} or @code{#f}, @var{value} and @var{type}, where
574;;; @var{type} can be @code{value}, @code{method} or @code{parent}.
575;;; @end deffn
576(define (slots->list self resend)
577  (let ((slots #f))
578    (self *prometheus-mutate-slots-message*
579          (lambda (obj-slots)
580            (set! slots obj-slots)
581            obj-slots))
582    (map (lambda (slot)
583           (list (slot-getter slot)
584                 (slot-setter slot)
585                 (slot-value slot)
586                 (slot-type slot)))
587         slots)))
588
589;; We also provide an ADD-SLOT! message which overwrites the ADD-SLOT!
590;; message used by prometheus-internal.
591(define (add-slot! self resend . args)
592  (self 'message-not-understood 'add-slot! args))
593
594;;; @deffn Syntax define-method (obj 'message self resend . args) body @dots{}
595;;;
596;;; This is syntactic sugar for the often-used idiom to define a
597;;; method slot, by sending a @code{add-method-slot!} message with a
598;;; @var{message} name and a lambda form with @var{self}, @var{resend}
599;;; and @var{args} formals, and a @var{body}.
600;;; @end deffn
601(define-syntax define-method
602  (syntax-rules ()
603    ((_ (obj 'message self resend . args)
604        body ...)
605     (obj 'add-method-slot!
606          'message
607          (lambda (self resend . args)
608            body ...)))))
609
610(define-syntax define-object/add-slots!
611  (syntax-rules ()
612    ((_ o)
613     (values))
614    ((_ o ((method-name . method-args) body ...)
615        slots ...)
616     (begin
617       (o 'add-method-slot! 'method-name (lambda method-args
618                                           body ...))
619       (define-object/add-slots! o slots ...)))
620    ((_ o (slot-getter slot-setter slot-value)
621        slots ...)
622     (begin
623       (o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
624       (define-object/add-slots! o slots ...)))
625    ((_ o (slot-getter slot-value)
626        slots ...)
627     (begin
628       (o 'add-value-slot! 'slot-getter slot-value)
629       (define-object/add-slots! o slots ...)))))
630
631;;; @deffn Syntax define-object name (parent other-parents @dots{}) slots @dots{}
632;;;
633;;; This is syntactic sugar for the typical actions of cloning an
634;;; object from a @var{parent} object, and adding more slots.
635;;;
636;;; @var{other-parents} is a list of @code{(name object)} lists, where
637;;; each @var{object} is added as a parent slot named @var{name}.
638;;;
639;;; @var{slots} is a list of slot specifications, either @code{(getter
640;;; value)} or @code{(getter setter value)} for value slots, or
641;;; @code{((name self resend args @dots{}) body @dots{})} for method
642;;; slots.
643;;; @end deffn
644(define-syntax define-object
645  (syntax-rules ()
646    ((_ name (creation-parent (parent-name parent-object) ...)
647        slots ...)
648     (define name (let ((o (creation-parent 'clone)))
649                    (o 'add-parent-slot! 'parent-name parent-object)
650                    ...
651                    (define-object/add-slots! o slots ...)
652                    o)))))
653
654;;; @deffn Procedure make-prometheus-root-object
655;;;
656;;; This creates a new root object from which other objects can
657;;; cloned. This object is independent of any other objects, and thus
658;;; creates a new inheritance tree.
659;;; @end deffn
660(define (make-prometheus-root-object)
661  (let ((obj ((make-prometheus-internal-root-object) 'clone))
662        (slots '()))
663    (obj 'add-slot!
664         *prometheus-mutate-slots-message*
665         (lambda (self resend proc)
666           (set! slots (proc slots))))
667    (obj 'add-slot! 'add-method-slot! add-method-slot!)
668    (for-each (lambda (entry)
669                (obj 'add-method-slot! (car entry) (cadr entry)))
670              `((add-method-slot! ,add-method-slot!)
671                (clone ,clone)
672                (add-value-slot! ,add-value-slot!)
673                (add-parent-slot! ,add-parent-slot!)
674                (delete-slot! ,delete-slot!)
675                (add-slot! ,add-slot!)
676                (slots->list ,slots->list)))
677    obj))
678
679;;; @deffn Variable *the-root-object*
680;;;
681;;; This is the default root object. If not really intended otherwise,
682;;; this should be used as the root of other object hierarchies.
683;;; @end deffn
684(define *the-root-object* (make-prometheus-root-object))
685
686)
Note: See TracBrowser for help on using the repository browser.