source: project/release/4/protobj/trunk/protobj.scm @ 19956

Last change on this file since 19956 was 19956, checked in by Mario Domenech Goulart, 10 years ago

protoobj: switching to tags/trunk layout

File size: 17.8 KB
Line 
1;;; @Package     Protobj
2;;; @Subtitle    Prototype-Delegation Object Model in Scheme
3;;; @HomePage    http://www.neilvandyke.org/protobj/
4;;; @Author      Neil W. Van Dyke
5;;; @AuthorEmail neil@@neilvandyke.org
6;;; @Version     0.1
7;;; @Date        5 January 2005
8
9;; $Id: protobj.scm,v 1.56 2005/01/06 01:58:39 neil Exp $
10
11;;; @legal
12;;; Copyright @copyright{} 2005 Neil W. Van Dyke.  This program is Free
13;;; Software; you can redistribute it and/or modify it under the terms of the
14;;; GNU Lesser General Public License as published by the Free Software
15;;; Foundation; either version 2.1 of the License, or (at your option) any
16;;; later version.  This program is distributed in the hope that it will be
17;;; useful, but without any warranty; without even the implied warranty of
18;;; merchantability or fitness for a particular purpose.  See the GNU Lesser
19;;; General Public License [LGPL] for details.  For other license options and
20;;; commercial consulting, contact the author.
21;;; @end legal
22
23;; (require (lib "9.ss" "srfi"))
24
25(module protobj (object? object-parent object-set! object-get object-apply
26                         object-apply/noslot-thunk
27                         object-raw-clone/no-slots-copy
28                         object-raw-clone/copy-immed-slots
29                         object-raw-clone/copy-all-slots
30                         current-root-object
31                         ^ ! ? %
32                         (@ protobj-internal:apply*) )
33
34  (import scheme chicken)
35
36(define-syntax protobj-internal:testeez
37  (syntax-rules () ((_ x ...)
38                    (error "Tests disabled.")
39                    ;;(testeez x ...)
40                    )))
41
42;;; @section Introduction
43
44;;; Protobj is a Scheme library that implements a simple prototype-delegation
45;;; object model, somewhat similar to that of [Self], and also related to
46;;; [SLIB-Object] and [OScheme].  Protobj was written mainly as a
47;;; @code{syntax-rules} learning exercise, but also because people ask about
48;;; prototype object models for Scheme from time to time.  Like most object
49;;; systems, it should be regarded as an amusement.  Protobj library defines
50;;; both a verbose set of procedures, and terse special syntax.
51;;;
52;;; Protobj is based on objects with named slots that can contain arbitrary
53;;; values.  Object have immediate slots, and single parent objects from which
54;;; additional slots are inherited.  When setting in a child object a slot
55;;; inherited from the parent, a new immediate slot is created in the child so
56;;; that the parent is unaffected and the slot is no longer inherited.
57;;;
58;;; Methods are simply closures stored in slots.  When a method is applied, the
59;;; first term of the closure is the receiver object.  Unlike Self, getting
60;;; getting the contents of the slot is distinguished from invoking a method
61;;; contained in the slot.  This distinction was made due to the way
62;;; first-class closures are often used in Scheme.
63;;;
64;;; An object is cloned by invoking the @code{clone} method.  The default root
65;;; object's @code{clone} method creates a new child object without any
66;;; immediate slots, rather than copying any slots.  This behavior can be
67;;; overridden to always copy certain slots, to copy immediate slots, or to
68;;; copy all inherited slots.  An overriding @code{clone} method can be
69;;; implemented to apply its parent's @code{clone} method to itself and then
70;;; set certain slots in the new child appropriately.
71;;;
72;;; Protobj requires R5RS, [SRFI-9], [SRFI-23], and [SRFI-39].
73
74;;; @section Tour
75
76;;; The following is a quick tour of Protobj using the terse special syntax.
77;;;
78;;; @enumerate
79;;;
80;;; @item
81;;; Bind @code{a} to the new object that is created by cloning the default root
82;;; object (@code{%} is special syntax for invoking the @code{clone} method):
83;;; @lisp
84;;; (define a (%))
85;;; @end lisp
86;;;
87;;; @item
88;;; Verify that @code{a} is an object and that @code{a}'s parent is the default
89;;; root object:
90;;; @lisp
91;;; (object? a) @result{} #t
92;;; (eq? (^ a) (current-root-object)) @result{} #t
93;;; @end lisp
94;;;
95;;; @item
96;;; Add to @code{a} a slot named @code{x} with value @code{1}:
97;;; @lisp
98;;; (! a x 1)
99;;; @end lisp
100;;;
101;;; @item
102;;; Get @code{a}'s slot @code{x}'s value:
103;;; @lisp
104;;; (? a x) @result{} 1
105;;; @end lisp
106;;;
107;;; @item
108;;; Bind @code{b} to a clone of @code{a}:
109;;; @lisp
110;;; (define b (% a))
111;;; @end lisp
112;;;
113;;; @item
114;;; Get @code{b}'s slot @code{x}'s value, which is inherited from @code{a}:
115;;; @lisp
116;;; (? b x) @result{} 1
117;;; @end lisp
118;;;
119;;; @item
120;;; Set @code{a}'s slot @code{x}'s value to @code{42}, and observe that
121;;; @code{b} inherits the new value:
122;;; @lisp
123;;; (! a x 42)
124;;; (? a x) @result{} 42
125;;; (? b x) @result{} 42
126;;; @end lisp
127;;;
128;;; @item
129;;; Set @code{b}'s slot @code{x}'s value to @code{69}, and observe that @var{a}
130;;; retains its own @code{x} value although @var{b}'s @code{x} value has been
131;;; changed:
132;;; @lisp
133;;; (! b x 69)
134;;; (? a x) @result{} 42
135;;; (? b x) @result{} 69
136;;; @end lisp
137;;;
138;;; @item
139;;; Add to @code{a} an @code{xplus} slot containing a closure that implements a
140;;; method of the object:
141;;; @lisp
142;;; (! a xplus (lambda (self n) (+ (? self x) n)))
143;;; @end lisp
144;;;
145;;; @item
146;;; Apply the method to the @code{a} and @code{b} objects (@code{b} inherits
147;;; any new slots added to @code{a}):
148;;; @lisp
149;;; (@@ a xplus 7) @result{} 49
150;;; (@@ b xplus 7) @result{} 76
151;;; @end lisp
152;;;
153;;; @item
154;;; Observe the shorthand syntax for applying methods to an object multiple
155;;; times, with the syntax having the value of the lastmost application:
156;;; @lisp
157;;; (@@ a (xplus 1000) (xplus 7)) @result{} 49
158;;; @end lisp
159;;;
160;;; @item
161;;; Bind to @var{c} an object that clones @var{a} and adds slot @var{y} with
162;;; value @code{101}:
163;;; @lisp
164;;; (define c (% a (y 101)))
165;;; @end lisp
166;;;
167;;; @item
168;;; Get the values of both the @code{x} and @code{y} slots of @code{c}:
169;;; @lisp
170;;; (? c x y) @result{} 42 101
171;;; @end lisp
172;;;
173;;; @item
174;;; Finally, bind @code{d} to a clone of @code{a} that overrides @code{a}'s
175;;; @code{x} slot:
176;;; @lisp
177;;; (define d (% a (x 1) (y 2) (z 3)))
178;;; (? d x y z) @result{} 1 2 3
179;;; @end lisp
180;;;
181;;; @end enumerate
182
183;;; @section Basic Interface
184
185;;; The basic interface of Protobj is a set of procedures.
186
187(define-record-type object
188  (protobj-internal:make-object parent slots)
189  object?
190  (parent object-parent          protobj-internal:set-parent!)
191  (slots  protobj-internal:slots protobj-internal:set-slots!))
192
193(define (protobj-internal:find-slot obj slot-symbol proc noslot-thunk)
194  (let loop ((o obj))
195    (cond ((assq slot-symbol (protobj-internal:slots o)) => proc)
196          (else (cond ((object-parent o) => loop)
197                      (else (noslot-thunk)))))))
198
199;;; @defproc object? x
200;;;
201;;; Predicate for whether or not @var{x} is a Protobj object.
202
203;; see define-record-type
204
205;;; @defproc object-parent obj
206;;;
207;;; Yields the parent object of object @var{obj}.
208
209;; see define-record-type
210
211;; TODO: Expose a "set-object-parent!"?
212
213;;; @defproc object-set! obj slot-symbol val
214;;;
215;;; Sets the slot identified by symbol @var{slot-symbol} in object @var{obj} to
216;;; value @code{val}.
217
218(define (object-set! obj slot-symbol val)
219  (let ((slots (protobj-internal:slots obj)))
220    (cond ((assq slot-symbol slots) => (lambda (slot) (set-cdr! slot val)))
221          (else (protobj-internal:set-slots! obj (cons (cons slot-symbol val)
222                                                       slots))))))
223
224;;; @defproc object-get obj slot-symbol
225;;;
226;;; Yields the value of slot named by symbol @var{slot-symbol} in object
227;;; @var{obj} (immediate or inherited).  If no slot of that name exists, an
228;;; error is signaled.
229
230(define (object-get obj slot-symbol)
231  (protobj-internal:find-slot
232   obj
233   slot-symbol
234   cdr
235   (lambda () (error "Object has no such slot:" obj slot-symbol))))
236
237;; (define (object-get/procs obj slot-symbol proc noslot-thunk)
238;;   (protobj-internal:find-slot obj
239;;                               slot-symbol
240;;                               (lambda (slot) (proc (cdr slot)))
241;;                               noslot-thunk))
242
243;;; @defproc object-get obj slot-symbol noslot-thunk
244;;;
245;;; Yields the value of slot named by symbol @var{slot-symbol} in object
246;;; @var{obj} (immediate or inherited), if any such slot exists.  If no slot of
247;;; that name exists, then yields the value of applying closure
248;;; @var{noslot-thunk}.
249
250(define (object-get/noslot-thunk obj slot-symbol noslot-thunk)
251  (protobj-internal:find-slot obj
252                              slot-symbol
253                              cdr
254                              noslot-thunk))
255
256;;; @defproc object-apply obj slot-symbol @{ arg @}*
257;;;
258;;; Applies the method (closure) in the slot named by@var{slot-symbol} of
259;;; object @var{obj}.  The first term of the method is @var{obj}, and one or
260;;; more @var{arg} are the remaining terms.  If no such slot exists, an error
261;;; is signaled.
262
263(define (object-apply obj slot-symbol . args)
264  (apply (object-get obj slot-symbol) obj args))
265
266;;; @defproc object-apply/noslot-thunk obj noslot-thunk slot-symbol @{ arg @}*
267;;;
268;;; Like @code{object-apply}, except that, if the slot does not exist, instead
269;;; of signalling an error, the value is the result of applying
270;;; @var{noslot-thunk}.
271
272(define (object-apply/noslot-thunk obj slot-symbol noslot-thunk . args)
273  (protobj-internal:find-slot obj
274                              slot-symbol
275                              (lambda (slot) (apply (cdr slot) obj args))
276                              noslot-thunk))
277
278;; TODO: Implement "object-apply/try", which calls a thunk (or is a no-op) if
279;; no slot can be found.  Maybe special syntax for doing this apply/try to a
280;; parent.  One of the things this might be most useful for is in a "clone"
281;; method, to invoke any parent "clone" method within additional behavior.
282
283;;; @defproc  object-raw-clone/no-slots-copy    obj
284;;; @defprocx object-raw-clone/copy-immed-slots obj
285;;; @defprocx object-raw-clone/copy-all-slots   obj
286;;;
287;;; These procedures implement different ways of cloning an object, and are
288;;; generally bound as @code{clone} methods in root objects.
289;;; @code{/no-slots-copy} does not copy any slots, @code{/copy-immed-slots}
290;;; copes immediate slots, and @code{/copy-all-slots} copies all slots
291;;; including inherited ones.
292
293(define (object-raw-clone/no-slots-copy obj)
294  (protobj-internal:make-object obj '()))
295
296(define (object-raw-clone/copy-immed-slots obj)
297  (protobj-internal:make-object obj
298                                (map (lambda (pair)
299                                       (cons (car pair) (cdr pair)))
300                                     (protobj-internal:slots obj))))
301
302(define (object-raw-clone/copy-all-slots obj)
303  ;; Note: We could save a few "(assq X '())" calls by copying the immediate
304  ;; slots first.
305  (let loop-objs ((o    obj)
306                  (seen '()))
307    (if o
308        (let loop-slots ((slots  (protobj-internal:slots o))
309                         (result seen))
310          (if (null? slots)
311              (loop-objs (object-parent o) result)
312              (loop-slots (cdr slots)
313                          (let ((name (caar slots)))
314                            (if (assq name seen)
315                                result
316                                (cons (cons name (cdar slots)) result))))))
317        (protobj-internal:make-object obj seen))))
318
319;; (define (object-clone obj)
320;;   (object-apply obj 'clone))
321
322;;; @defparam current-root-object
323;;;
324;;; Parameter for the default root object.  The initial value is a root object
325;;; that has @code{object-raw-clone/no-slots-copy} in its @code{clone} slot.
326
327;; TODO: Make this a parameter, or lose it altogether.
328
329(define current-root-object
330  (make-parameter
331   (protobj-internal:make-object
332    #f
333    (list (cons 'clone object-raw-clone/no-slots-copy)))))
334
335;;; @section Terse Syntax
336
337;;; Since Protobj's raison d'etre was to play with syntax, here it is.  Note
338;;; that slot names are never quoted.
339
340;;; @defsyntax ^ obj
341;;;
342;;; Parent of @var{obj}.
343
344(define-syntax ^ (syntax-rules () ((_ ?o) (object-parent ?o))))
345
346;;; @defsyntax  ! obj slot val
347;;; @defsyntaxx ! obj (slot val) ...
348;;;
349;;; Sets object @var{obj}'s slot @var{slot}'s value to @var{val}.  In the
350;;; second form of this syntax, multiple slots of @var{obj} may be set at once,
351;;; and are set in the order given.
352
353(define-syntax !
354  (syntax-rules ()
355    ((_ ?o (?s0 ?v0) (?s1 ?v1) ...) (let ((o ?o))
356                                      (! o ?s0 ?v0)
357                                      (! o ?s1 ?v1) ...))
358    ((_ ?o ?s ?v)                   (object-set! ?o (quote ?s) ?v))))
359
360;;; @defsyntax ? obj @{ slot @}+
361;;;
362;;; Yields the values of the given @var{slot}s of @var{obj}.  If more than one
363;;; @var{slot} is given, a multiple-value return is used.
364
365(define-syntax ?
366  (syntax-rules ()
367    ((_ ?o ?s)     (object-get ?o (quote ?s)))
368    ((_ ?o ?s ...) (let ((o ?o)) (values (? o ?s) ...)))))
369
370;;; @defsyntax  @@ obj slot @{ arg @}*
371;;; @defsyntaxx @@ obj @{ (slot @{ arg @}* ) @}+
372;;;
373;;; Applies @var{obj}'s @var{slot} method, with @var{obj} as the first term and
374;;; @var{arg}s as the remaining terms.  In the second form of this syntax,
375;;; multiple methods may be applied, and the value is the value of the last
376;;; method application.
377
378(define-syntax protobj-internal:apply*
379  (syntax-rules ()
380    ((_ (X0 X1 ...) S A0 ...) (let ((temp (X0 X1 ...)))
381                                (protobj-internal:apply* temp S A0 ...)))
382    ((_ OVAR        S A0 ...) ((object-get OVAR (quote S)) OVAR A0 ...))))
383
384(define-syntax @
385  (syntax-rules ()
386    ((_ ?o (?s0 ?a0 ...) (?s1 ?a1 ...) ...)
387     (let ((o ?o))
388       (protobj-internal:apply* o ?s0 ?a0 ...)
389       (protobj-internal:apply* o ?s1 ?a1 ...) ...))
390    ((_ ?o ?s ?a ...)
391     (protobj-internal:apply* ?o ?s ?a ...))))
392
393;;; @defsyntax % [ obj @{ (slot val) @}* ]
394;;;
395;;; Clones object @var{obj}, binding any given @var{slot}s to respective given
396;;; @var{val}s.
397
398(define-syntax %
399  (syntax-rules ()
400    ((_)                            (% (current-root-object)))
401    ((_ ?o)                         (@ ?o clone))
402    ((_ ?o (?s0 ?v0) (?s1 ?v1) ...) (let ((o (% ?o)))
403                                      (! o ?s0 ?v0)
404                                      (! o ?s1 ?v1) ...
405                                      o))))
406
407
408;;; Extensions (by felix)
409
410(define-record-printer (object x port)
411  (@ x print port) )
412
413(! (current-root-object) print
414   (lambda (self #!optional (port (current-output-port)))
415     (display "#<object>" port)))
416
417)
418
419;;; @section Tests
420
421;;; The Protobj test suite can be enabled by editing the source code file and
422;;; loading [Testeez]; the test suite is disabled by default.
423
424#;(define (protobj-internal:test)
425  (protobj-internal:testeez
426   "Protobj"
427
428   (test-define "Object \"a\""                     a (%))
429   (test/equal  "\"a\" parent is root"  (eq? (^ a) (current-root-object)) #t)
430   (test-eval   "Add to \"a\" slot \"x\" value 1"  (! a x 1))
431   (test/equal  "\"a\" slot \"x\" is 1"            (? a x)                 1)
432   (test-define "Object \"b\" clones \"a\""        b (% a))
433   (test/equal  "\"b\" inherited slot \"x\" is 1"  (? b x)                 1)
434   (test-eval   "Set \"a\" slot \"x\" to 42"       (! a x 42))
435   (test/equal  "\"b\" slot \"x\" is now 42"       (? b x)                 42)
436   (test-eval   "Set \"b\" slot \"x\" to 69"       (! b x 69))
437   (test/equal  "\"b\" slot \"x\" is 69"           (? b x)                 69)
438   (test/equal  "\"a\" slot \"x\" is still 42"     (? a x)                 42)
439
440   (test-eval "Add to object \"a\" an \"xplus\" slot containing a method"
441              (! a xplus (lambda (self n) (+ (? self x) n))))
442
443   (test/equal "42 + 7 = 49" (@ a xplus 7) 49)
444   (test/equal "69 + 7 = 76" (@ b xplus 7) 76)
445
446   (test/equal "42 + 7 = 49" (@ a (xplus 1000) (xplus 7)) 49)
447
448   (test-define "Object \"c\" clones \"a\", adds slot \"y\""
449                c (% a (y 101)))
450   (test/equal "\"c\" slot \"x\" is 42"  (? c x) 42)
451   (test/equal "\"c\" slot \"y\" is 101" (? c y) 101)
452
453   (test-define "Object \"d\" clones \"a\", adds slots"
454                d (% a (x 1) (y 2) (z 3)))
455   (test/equal "\"d\" slot \"x\" is 1"  (? d x) 1)
456   (test/equal "\"d\" slot \"y\" is 2"  (? d y) 2)
457   (test/equal "\"d\" slot \"z\" is 3"  (? d z) 3)
458
459   (test/equal
460    "Copying object-raw-clone functions"
461    (let* ((o (% (% (% (current-root-object)
462                       (a 1) (b 2) (c 3))
463                    (b 4) (a 5) (d 6))
464                 (e 7) (b 8) (c 9))))
465      (list
466       (protobj-internal:slots (object-raw-clone/copy-immed-slots o))
467       (protobj-internal:slots (object-raw-clone/copy-all-slots   o))))
468    `(((c . 9) (b . 8) (e . 7))
469      ((clone . ,object-raw-clone/no-slots-copy)
470       (a . 5) (d . 6) (e . 7) (b . 8) (c . 9))))
471
472   ;; TODO: Add more tests.
473   ))
474
475;;; @unnumberedsec History
476
477;;; @table @asis
478;;;
479;;; @item Version 0.1 --- 5 January 2005
480;;; Initial release.
481;;;
482;;; @end table
483
484;;; @unnumberedsec References
485
486;;; @table @asis
487;;;
488;;; @item [LGPL]
489;;; Free Software Foundation, ``GNU Lesser General Public License,'' Version
490;;; 2.1, February 1999, 59 Temple Place, Suite 330, Boston, MA 02111-1307
491;;; USA.@*
492;;; @uref{http://www.gnu.org/copyleft/lesser.html}
493;;;
494;;; @item [OScheme]
495;;; Anselm Baird-Smith, ``OScheme.''@*
496;;; @uref{http://koala.ilog.fr/abaird/oscheme/om.html}
497;;;
498;;; @item [Self]
499;;; David Ungar and Randall B. Smith, ``Self: The Power of Simplicity,''
500;;; @i{Lisp and Symbolic Computation}, 4, 3, 1991.@*
501;;; @uref{http://research.sun.com/self/papers/self-power.html}
502;;;
503;;; @item [SLIB-Object]
504;;; Wade Humeniuk, ``Macroless Object System,'' SLIB @code{object}.@*
505;;; @uref{http://swissnet.ai.mit.edu/~jaffer/slib_7.html#SEC180}
506;;;
507;;; @item [SRFI-9]
508;;; Richard Kelsey, ``Defining Record Types,'' SRFI 9, 9 September 1999.@*
509;;; @uref{http://srfi.schemers.org/srfi-9/srfi-9.html}
510;;;
511;;; @item [SRFI-23]
512;;; Stephan Houben, ``Error reporting mechanism,'' SRFI 23, 26 April 2001.@*
513;;; @uref{http://srfi.schemers.org/srfi-23/srfi-23.html}
514;;;
515;;; @item [SRFI-39]
516;;; Marc Feeley, ``Parameter objects,'' SRFI 39, 30 June 2003.@*
517;;; @uref{http://srfi.schemers.org/srfi-39/srfi-39.html}
518;;;
519;;; @item [Testeez]
520;;; Neil W. Van Dyke, ``Testeez: Simple Test Mechanism for Scheme,'' Version
521;;; 0.1.@*
522;;; @uref{http://www.neilvandyke.org/testeez/}
523;;;
524;;; @end table
Note: See TracBrowser for help on using the repository browser.