source: project/release/4/prometheus/prometheus-2/examples/safe-object.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: 2.0 KB
Line 
1;;; This defines two Scheme 48 modules which each exports only a
2;;; single value: An object which can't be modified from the outside.
3
4;;; The first version is trivial. We just steal the parent.
5
6(define-structure safe-object-full (export full-safe-object)
7  (open scheme
8        prometheus)
9  (begin
10    (define fully-safe-object (*the-root-object* 'clone))
11    (full-safe-object 'add-value-slot! 'fnord 'set-fnord! 23)
12    (full-safe-object 'delete-slot! 'parent)))
13
14;;; The second assumes you just want to hide a few of the messages of
15;;; the parent object.
16
17;;; The trick is to overwrite all modifying messages. Since the parent
18;;; object might be used to modify us, we also hide it behind a
19;;; private message name.
20
21(define-structure safe-object-partial (export partial-safe-object)
22  (open scheme
23        srfi-23
24        prometheus)
25  (begin
26    (define partial-safe-object ((make-prometheus-root-object) 'clone))
27    ;; The private parent message
28    (let ((parent (list '*parent-message*)))
29      (partial-safe-object 'add-value-slot! 'immutable 23)
30      ;; Add our private parent
31      (partial-safe-object 'add-parent-slot! parent (safe-object 'parent))
32      ;; And delete the one added by the clone
33      (partial-safe-object 'delete-slot! 'parent)
34      ;; Overwrite all unneeded slots - since some messages need
35      ;; others internally, we do a resend until we did overwrite all
36      ;; slots:
37      (let ((resend? #t))
38        (for-each (lambda (msg)
39                    (partial-safe-object
40                     'add-method-slot! msg
41                     (lambda (self resend . args)
42                       (if resend?
43                           (apply resend #f msg args)
44                           (error "Object is immutable!")))))
45                  '(add-slot-binding!
46                    remove-slot-bindings!
47                    clone
48                    add-value-slot!
49                    add-parent-slot!
50                    add-method-slot!
51                    delete-slot!
52                    slots->list))
53        (set! resend? #f)))))
Note: See TracBrowser for help on using the repository browser.