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

Last change on this file since 24068 was 24068, checked in by felix winkelmann, 9 years ago

protobj 0.4: fixed unused export, added tests

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