source: project/release/4/prometheus/prometheus-2/scheme/prometheus.scm @ 14451

Last change on this file since 14451 was 14451, checked in by sjamaan, 11 years ago

Port Prometheus-2 to Chicken, using the clean, unmodified code from the release

File size: 7.4 KB
Line 
1;; prometheus.scm --- A prototype-based object system
2
3;; Copyright (C) 2005, 2006 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., 51 Franklin St, Fifth Floor, Boston, MA
20;; 02110-1301  USA
21
22;;; Commentary:
23
24;; This implements the Prometheus object system ontop of the Hermes
25;; system.
26
27
28;;; Code:
29
30;;;;;;;;;;;;;;;;;;;;;
31;;; Prometheus Object
32
33;;; This creates a new root object for a Prometheus hierarchy.
34
35(define (make-prometheus-root-object)
36  (let ((o (make-hermes-object)))
37    (o 'add-message! 'clone root-clone)
38    (o 'add-message! 'message-not-understood root-message-not-understood)
39    (o 'add-message! 'ambiguous-message-send root-ambiguous-message-send)
40    (o 'add-message! 'immediate-slot-list root-immediate-slot-list)
41    (o 'add-message! 'set-immediate-slot-list! root-set-immediate-slot-list!)
42    (o 'add-message! 'add-value-slot! root-add-value-slot!)
43    (o 'add-message! 'add-method-slot! root-add-method-slot!)
44    (o 'add-message! 'add-parent-slot! root-add-parent-slot!)
45    (o 'add-message! 'delete-slot! root-delete-slot!)
46    o))
47
48;;; Return the slot list. Each entry in the slot list is a list of
49;;; three elements: The name of the getter, the name of the setter,
50;;; and a boolean whether this is a parent slot or not.
51;;; For the initial object, this is hardcoded. Bad programmer. No
52;;; cookie.
53(define (root-immediate-slot-list self resend)
54  '((clone #f #f)
55    (message-not-understood #f #f)
56    (ambiguous-message-send #f #f)
57    (immediate-slot-list set-immediate-slot-list! #f)
58    (add-value-slot! #f #f)
59    (add-method-slot! #f #f)
60    (add-parent-slot! #f #f)
61    (delete-slot! #f #f)))
62
63;;; Set the slot list to be returned in the future to a new list. This
64;;; just adds a new message so the slot list of a parent is never
65;;; overwritten.
66(define (root-set-immediate-slot-list! self resend new)
67  (self 'add-message! 'immediate-slot-list
68        (lambda (self resend)
69          new)))
70
71;;; Return a new object with the parent pointer set to this one.
72(define (root-clone self resend)
73  (let ((child (make-hermes-object)))
74    (child 'add-message! 'parent
75           (lambda (self2 resend)
76             self)
77           #t)
78    (child 'add-message! 'immediate-slot-list
79           (lambda (self2 resend)
80             '((parent #f parent))))
81    child))
82
83;;; When the root object receives a MESSAGE-NOT-UNDERSTOOD message,
84;;; signal an error. We don't handle that.
85(define (root-message-not-understood self resend message args)
86  (error "Message not understood" self message args))
87
88;;; When the root object receive an AMBIGUOUS-MESSAGE-SEND message,
89;;; signal an error. We don't handle that either.
90(define (root-ambiguous-message-send self resend message args)
91  (error "Message ambiguous" self message args))
92
93(define-syntax make-getter-setter
94  (syntax-rules ()
95    ((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER)
96     (make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER PURE-GETTER))
97    ((make-getter-setter 'MESSAGE VALUE TYPE PURE-GETTER SETABLE-GETTER)
98     (case-lambda
99
100      ((self resend getter VALUE)
101       (self 'delete-slot! getter)
102       (self 'set-immediate-slot-list!
103             (alist-cons getter
104                         (list #f TYPE)
105                         (self 'immediate-slot-list)))
106       (self 'add-message! getter PURE-GETTER (eq? TYPE 'parent)))
107
108      ((self resend getter setter VALUE)
109       (self 'delete-slot! getter)
110       (self 'delete-slot! setter)
111       (self 'set-immediate-slot-list!
112               (alist-cons getter
113                           (list setter TYPE)
114                           (self 'immediate-slot-list)))
115         (self 'add-message! getter SETABLE-GETTER (eq? TYPE 'parent))
116         (self 'add-message! setter
117               (lambda (self2 resend new)
118                 (if (eq? self2 self)
119                     (set! VALUE new)
120                     (self2 'MESSAGE getter setter new)))))))))
121
122;;; Add a value slot. Nothing fancy when no setter is given, except
123;;; that we make sure a possible earlier setter is removed. But when
124;;; there is a setter given, we make them share a value for fast
125;;; modification.
126(define root-add-value-slot!
127  (make-getter-setter 'add-value-slot! value 'value
128                      (lambda (self resend)
129                        value)))
130
131;;; A method slot is just a normal message slot, except that we record
132;;; its existence in the slot list.
133(define root-add-method-slot!
134  (make-getter-setter 'add-method-slot! value 'method
135                      value
136                      (lambda (self resend . args)
137                        (apply value self resend args))))
138
139;;; A parent slot isn't very special, either, except that we note its
140;;; special status for both Hermes and our slot list.
141(define root-add-parent-slot!
142  (make-getter-setter 'add-parent-slot! value 'parent
143                      (lambda (self resend)
144                        value)))
145
146
147;;; Delete a slot again. If it does have an associated setter, remove
148;;; that setter as well.
149(define (root-delete-slot! self resend getter)
150  (self 'set-immediate-slot-list!
151        (let loop ((alis (self 'immediate-slot-list)))
152          (cond
153           ((null? alis)
154            '())
155           ((eq? getter (caar alis))
156            (self 'delete-message! (cadar alis))
157            (loop (cdr alis)))
158           (else
159            (cons (car alis)
160                  (loop (cdr alis)))))))
161  (self 'delete-message! getter))
162
163;;;;;;;;;;;;;;;;;;;
164;;; Syntactic Sugar
165
166;;; The syntactic sugar for defining methods and objects.
167
168(define-syntax define-method
169  (syntax-rules ()
170    ((_ (obj 'message self resend args ...)
171        body1 body ...)
172     (obj 'add-method-slot! 'message
173          (lambda (self resend args ...)
174            body1 body ...)))))
175
176(define-syntax define-object
177  (syntax-rules ()
178    ((_ name (creation-parent (parent-name parent-object) ...)
179        slots ...)
180     (define name (let ((o (creation-parent 'clone)))
181                    (o 'add-parent-slot! 'parent-name parent-object)
182                    ...
183                    (define-object/add-slots! o slots ...)
184                    o)))))
185
186(define-syntax define-object/add-slots!
187  (syntax-rules ()
188    ((_ o)
189     (values))
190    ((_ o ((method-name . method-args) body ...)
191        slots ...)
192     (begin
193       (o 'add-method-slot! 'method-name (lambda method-args
194                                           body ...))
195       (define-object/add-slots! o slots ...)))
196    ((_ o (slot-getter slot-setter slot-value)
197        slots ...)
198     (begin
199       (o 'add-value-slot! 'slot-getter 'slot-setter slot-value)
200       (define-object/add-slots! o slots ...)))
201    ((_ o (slot-getter slot-value)
202        slots ...)
203     (begin
204       (o 'add-value-slot! 'slot-getter slot-value)
205       (define-object/add-slots! o slots ...)))))
206
207;;; Let there be light.
208;; FIXME! Better name?
209(define *the-root-object* (make-prometheus-root-object))
210
211;;; prometheus.scm ends here
Note: See TracBrowser for help on using the repository browser.