source: project/wiki/records-and-oop @ 40244

Last change on this file since 40244 was 40244, checked in by Mario Domenech Goulart, 3 months ago

records-and-oop: update to CHICKEN 5, add some markup

File size: 30.7 KB
3== Records and Object Orientation
5Records are the feature most painfully missed in R5RS. Consequently
6Chicken supplied define-record in the special-forms unit. It is easy to
7use, but personally I don't like it because it does too much behind the
8scene. For example, the following call
10<enscript highlight=scheme>
11(define-record rect x y w h)
14creates automatically ten procedures
16* a constructor, {{make-rect}}
17* a predicate, {{rect?}}
19for each slot, {{x}}, {{y}}, {{w}}, {{h}}
21* an accessor {{rect-x}}, {{rect-y}}, {{rect-w}}, {{rect-h}}
22* and a mutator {{rect-x-set!}}, {{rect-y-set!}}, {{rect-w-set!}}, {{rect-h-set!}}
24This is convenient, but since these procedures are never defined
25explicitly, you might have problems understanding code, where their use
26is far away from the call to {{define-record}}. Moreover, you are missing
27the flexibility to choose your own names for these procedures, and --
28which is more important -- you can't make individual slots read-only.
30=== define-record-type
32All these problems are avoided using srfi-9's {{define-record-type}}, also
33supplied by CHICKEN in the {{chicken.base}} module. The following call will
34do exactly the same as the {{define-record}} call above, but now all names
35are explicit, hence can be chosen by yourself and the modifiers can be
36omitted at all, thus providing read-only slots.
38<enscript highlight=scheme>
39(define-record-type rect
40  (make-rect x y w h)
41  rect?
42  (x rect-x rect-x-set!)
43  (y rect-y rect-y-set!)
44  (w rect-w rect-w-set!)
45  (h rect-h rect-h-set!)
49You can also save some procedure identifiers by replacing e.g.
50{{rect-x-set!}} with {{(setter rect-x)}}. Then you can mutate the {{x}} slot in the
51srfi-17 way by {{(set! (rect-x rt) new-slot)}}.
53=== define-record-printer
55Both {{define-record}} and {{define-record-type}} can be used in combination
56with {{define-record-printer}} from the {{chicken.base}} module, thus allowing
57records to be printed in a readable form. Without it, a {{rect}} instance
58is simply printed {{#<rect>}}, which is not very descriptive. But having
61<enscript highlight=scheme>
62(define-record-printer (rect rt out)
63  (fprintf out "#,(rect ~s ~s ~s ~s)"
64  (rect-x rt) (rect-y rt) (rect-w rt) (rect-h rt)))
67{{(make-rect 0 0 1 2)}} will print {{#,(rect 0 0 1 2)}} instead of {{#<rect>}}.
69=== define-reader-ctor
71Now you can turn things around and read a {{rect}} instance written in the
72form printed above via
74  (define rt '#,(rect 0 0 1 2))
76provided you have used srfi-10's {{define-reader-ctor}}, supplied by
77CHICKEN's {{}} module via
79  (define-reader-ctor 'rect make-rect)
81=== The records egg
83Up to now, you have used a syntactic interface to {{rects}}. There is a
84procedural one as well, provided by the [[/eggref/5/records egg|records]].  Now I can reduce
85the number of identifiers by packaging accessors and modifiers with
86srfi-17's {{getter-with-setter}}, so that {{set!}} can work on accessor
87expressions.  But note that {{define-record-printer}} is used a bit
88different then above, because you must use the name of the record-type,
89not the record-type-descriptor.
91<enscript highlight=scheme>
92(use records)
93(define RECT (make-record-type 'rect '(x y w h)))
94(define Rect (record-constructor RECT))
95(define rect? (record-predicate RECT))
96(define rect-x (getter-with-setter (record-accessor RECT 'x)
97                                   (record-mutator RECT 'x)))
98(define rect-y (getter-with-setter (record-accessor RECT 'y)
99                                   (record-mutator RECT 'y)))
100(define rect-w (getter-with-setter (record-accessor RECT 'w)
101                                   (record-mutator RECT 'w)))
102(define rect-h (getter-with-setter (record-accessor RECT 'h)
103                                   (record-mutator RECT 'h)))
104(define-record-printer ('rect rt out) ; note 'rect, not RECT
105  (fprintf out "#,(rect ~s ~s ~s ~s)"
106    (rect-x rt) (rect-y rt) (rect-w rt) (rect-h rt)))
109Now with {{(define rt (Rect 0 0 1 2))}}, {{rt}} will print {{#,(rect 0 0 1 2)}},
110{{(rect-x rt)}} will print {{0}} and after {{(set! (rect-x rt) 10)}} it will print
113Henceforth, record-type descriptors will be written all uppercase, and
114the corresponding constructor starting uppercase.
116=== srfi-99
118CHICKENS's implementation of srfi-99, written by Thomas Chust, combines
119both interfaces, the syntactic and the procedural one, so that they can
120be used interchangeably, and it provides its own version of
123This one module comprises srfi-99-variants and srfi-99-records, the
124latter in turn comprising submodules srfi-99-records-procedural,
125srfi-99-records-inspection and srfi-99-records-syntactic, the former
126being an extension to the srfi-99 document. As that document postulates,
127CHICKENS's srfi-99 records not only implement type extension in the form
128of single inheritance, but also all optional extensions, the srfi-document
129mentions: opaque, sealed and non-generative records.
131And that's not all. Thomas' implementation includes record-properties,
132which can be attached to record-type-descriptors -- henceforth
133abbreviated rtd's -- and which can be used to implement single
134inheritance object orientation.
137==== Type extension
139From now on, we assume srfi-99 is used.
141Let's start with specializing a rectangle to a square in
142the procedural interface. First rects.
144<enscript highlight=scheme>
145(define RECT (make-rtd 'rect
146               '#((mutable x) (mutable y) (mutable w) (mutable h))))
147(define Rect (rtd-constructor RECT))
148(define rect? (rtd-predicate RECT))
149(define rect-x (rtd-accessor RECT 'x))
150(define rect-y (rtd-accessor RECT 'y))
151(define rect-w (rtd-accessor RECT 'w))
152(define rect-h (rtd-accessor RECT 'h))
155Apart from name-changes, you'll notice, that the fields are now
156referenced in a vector instead of a list and they are tagged as mutable.
157Alternatively, you could have tagged them with immutable. Short forms of,
158e.g. {{(mutable x)}} or {{(immutable y)}} are accepted as well, namely {{(x)}} or {{y}}
159respectively, but I strongly recommend, not to use them: It's all to
160easy to write {{x}} when you mean {{(x)}} and later wonder, why a setter doesn't
161work, although you have explicitly supplied a correct one.
162Another change is, that explicit mutators via {{getter-with-setter}} are
163missing; they are automatically provided by the srfi-99 library, so
164something like {{(set!  (rect-x rt) 10)}} would work as expected, provided
165the field x is tagged as mutable.
166The name-changes of srfi-99 with the rtd abbreviations, untypical for
167Scheme, are caused not to conflict with R6RS-records.
169But the fun begins now, specializing rects to squares.
171<enscript highlight=scheme>
172(define SQUARE (make-rtd 'square '#() #:parent RECT))
173(define (Square x y l)
174  ((rtd-constructor SQUARE) x y l l))
175(define (square? rt)
176  (and ((rtd-predicate SQUARE) rt) (= (rect-w rt) (rect-h rt))))
179Note, that the slot vector is empty. There are no new slots. But the
180constructor and the predicate need to be corrected to reflect the
181spezialization. A raw {{rtd-constructor}} of a child rtd accepts the
182parent's and the child's slots in this order as arguments.
184Now, every square is a rectangle, but not every rectangle a square!
185Note, that albeit the rtd SQUARE doesn't provide any accessors, they are
186inherited from rtd RECT. But the names {{rect-x}} etc. are a bit foreign to
187a square. That's where dynamic binding and object orientation comes into
188the play ...
190==== Record properties and object orientation
192The above is fine, but there is a serious drawback: The accessors are
193statically bound. So we had to prefix the slot-names with the {{rtd-name}}
194to avoid name clashes, forcing the user of these records to remember in
195which hierarchy-level the accessors were defined; a real problem, if the
196hierarchy is deep.  We would prefer to have them dynamically bound and
197given them names like {{x}}, {{y}}, {{w}} and {{h}}, the actual routine being looked up
198by the system.  That's exactly what record-properties provide.
200First we have to define, for each method to be implemented, in
201particular for the slots, record-properties, e.g.
202{{(define-record-property x)}}/
204This defines procedures of at least one argument, which will eventually
205be applied to records, which have corresponding procedures bound to its
206record-type-descriptor. Before this happens, these properties will
207allways return the default value {{#f}} independently of its argument; try
208this by issuing {{(x #t)}} or {{(x #t #t #t)}}. If you want another value to be
209returned, you must supply it as a second argument to
210{{define-record-property}}. This second argument is returned via CHICKEN's
211constantly procedure.  But you should be aware, that symbols as second
212argument to {{record-properties}} are treated specially: inside rtd's they
213refer to accessors of equally named fields.
215To bind properties to record-type-descriptors, you'll use the {{#:property}}
216clause of {{make-rtd}}. Note, that after their implementation in the rtd,
217the properties will be more or less dynamically bound versions of the
218statically bound accessors like {{rect-x}} and the corresponding mutators.
219The accessors are simply referenced by their names as a symbol, while
220the mutators must be curried.
222<enscript highlight=scheme>
223(define-record-property x)
224(define-record-property y)
225(define-record-property w)
226(define-record-property h)
227(define-record-property x!)
228(define-record-property y!)
229(define-record-property w!)
230(define-record-property h!)
232(define RECT
233  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
234            #:property x 'x
235            #:property x!
236            (lambda (rt)
237              (lambda (a)
238                (set! (x rt) a)))
239            #:property y 'y
240            #:property y!
241            (lambda (rt)
242              (lambda (b)
243                (set! (y rt) b)))
244            #:property w 'w
245            #:property w!
246            (lambda (rt)
247              (lambda (b)
248                (set! (w rt) b)))
249            #:property h 'h
250            #:property h!
251            (lambda (rt)
252              (lambda (b)
253                (set! (h rt) b)))
254            ))
255(define Rect (rtd-constructor RECT))
256(define rect? (rtd-predicate RECT))
258;; now squares as speciealized rects
259(define-record-property l)
260(define-record-property l!)
262(define SQUARE
263  (make-rtd 'square '#()
264            #:parent RECT
265            #:property l w
266            #:property l!
267            (lambda (rt)
268               (lambda (c)
269                (set! (w rt) c)
270                (set! (h rt) c)))
271            ))
273(define (Square x y l)
274  ((rtd-constructor SQUARE) x y l l))
276(define (square? rt)
277  (and ((rtd-predicate SQUARE) rt) (= (rect-w rt) (rect-h rt))))
280Now {{x}}, {{x!}} and friends are dynamically bound. They are called like {{(x rt)}}
281and {{((x! rt) a)}}. If there where other records with properties {{x}} and {{x!}}
282bound to its type, always the right accessor or mutator would be chosen.
283To see this, let's enhance the example, so that it's more realistic. In
284doing this, we'll package the types in modules.
286==== Rects revisited
288Realistic rects should always have numeric fields, and they should be
289movable and scalable. An area method would be nice as well.  Moreover,
290they should always be in a valid state. In other words, we would like to
291have an invariant property, which checks the validity of an object's
292state, automatic documentation and properties {{move!}}, {{scale!}} and {{area}}.
294Since invariant and automatic documentation should be available
295everywhere, we package corresponding properties in an abstract base
296type, OBJECT, to be overridden in any of its children. Abstract types
297don't have constructors.
299<enscript highlight=scheme>
300(module objects *
301  (import scheme
302          (only data-structures sort)
303          (only srfi-99
304                define-record-property
305                make-rtd
306                rtd-predicate
307                record?))
309(define-record-property invariant)
310(define-record-property property-names)
312(define OBJECT
313        (make-rtd 'object '#()
314          #:property invariant #t
315          #:property property-names
316          (lambda (obj)
317            (sort-symbols
318              '(invariant property-names)))
319          ))
320(define object? (rtd-predicate OBJECT))
322(define (sort-symbols symlist)
323  (sort symlist (lambda (x y)
324                  (string-ci<=? (symbol->string x)
325                                (symbol->string y)))))
326) ; objects
329To test, that invariant works indeed everywhere, we'll use a fake
330module using the syntactic interface:
332<enscript highlight=scheme>
333(module foos (FOO Foo foo? invariant)
334  (import scheme objects
335          (only srfi-99 define-record-type define-record-property))
336;;; a different inheritance branch
337(define-record-type (FOO #:parent OBJECT #:property invariant "foo") (Foo) foo?)
338) ; foos
341Now the implementation of rectangles ...
343<enscript highlight=scheme>
344(module rects (RECT Rect rect? x x! y y! w w! h h! move! scale! area)
345  (import scheme objects
346          (only (chicken base) error define-reader-ctor)
347          (only (chicken format) fprintf)
348          (only srfi-99 define-record-printer define-record-property
349                make-rtd rtd-constructor rtd-predicate))
350  (reexport objects)
352;; new properties
353(define-record-property x)
354(define-record-property x!)
355(define-record-property y)
356(define-record-property y!)
357(define-record-property w)
358(define-record-property w!)
359(define-record-property h)
360(define-record-property h!)
361(define-record-property area)
362(define-record-property move!)
363(define-record-property scale!)
365;;; rtd, denoted all upper case
366(define RECT
367  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
368            #:parent OBJECT
369            #:property invariant
370            (lambda (rt)
371              (if (and (number? (x rt))
372                       (number? (y rt))
373                       (number? (w rt))
374                       (number? (h rt))
375                       (>= (w rt) 0)
376                       (>= (h rt) 0))
377                '(and (number? (x rt))
378                      (number? (y rt))
379                      (number? (w rt))
380                      (number? (h rt))
381                      (>= (w rt) 0)
382                      (>= (h rt) 0))
383                #f))
384            #:property property-names
385            (lambda (rt)
386              (sort-symbols
387                (append '(area scale! move! x x! y y! w w! h h!)
388                        (property-names rt OBJECT))))
389            #:property area
390            (lambda (rt) (* (w rt) (h rt)))
391            #:property move!
392            (lambda (rt)
393              (lambda (dx dy)
394                ((x! rt) (+ (x rt) dx))
395                ((y! rt) (+ (y rt) dy))))
396            #:property scale!
397            (lambda (rt)
398              (lambda (s)
399                (cond
400                  ((and (number? s) (>= s 0))
401                   ((w! rt) (* s (w rt)))
402                   ((h! rt) (* s (h rt))))
403                  (else
404                    (error 'scale! "positive number expected" s)))))
405            #:property x 'x
406            #:property x!
407            (lambda (rt)
408              (lambda (a)
409                (if (number? a)
410                  (set! (x rt) a)
411                  (error 'x! "number expected" a))))
412            #:property y 'y
413            #:property y!
414            (lambda (rt)
415              (lambda (b)
416                (if (number? b)
417                  (set! (y rt) b)
418                  (error 'y! "number eypected" b))))
419            #:property w 'w
420            #:property w!
421            (lambda (rt)
422              (lambda (a)
423                (if (number? a)
424                  (set! (w rt) a)
425                  (error 'w! "number expected" a))))
426            #:property h 'h
427            #:property h!
428            (lambda (rt)
429              (lambda (a)
430                (if (number? a)
431                  (set! (h rt) a)
432                  (error 'h! "number expected" a))))
433            ))
435;; constructor, denoted with leading upper case
436(define (Rect a b c d)
437  (let ((result ((rtd-constructor RECT) a b c d)))
438    (if (invariant result)
439      result
440      (error 'Rect "invariant broken"))))
441;; predicate
442(define (rect? arg)
443  (and ((rtd-predicate RECT) arg)
444       (if (invariant arg) #t #f)))
446;; printer
447(define-record-printer (RECT rt out)
448  (fprintf out "#,(rect ~s ~s ~s ~s)"
449               (x rt) (y rt) (w rt) (h rt)))
451;; reader
452(define-reader-ctor 'rect Rect)
454) ; rects
457... and of squares:
459<enscript highlight=scheme>
460(module squares (SQUARE Square square? l l!)
461  (import scheme
462          rects
463          (only (chicken base) error define-reader-ctor)
464          (only (chicken format) fprintf)
465          (only srfi-99 define-record-printer define-record-property
466                make-rtd rtd-constructor rtd-predicate))
467  (reexport rects)
469(define-record-property l)
470(define-record-property l!)
472;;; type extension, aka inheritance
473(define SQUARE
474  (make-rtd 'square '#()
475            #:parent RECT
476            #:property invariant
477            (lambda (rt)
478              (if (and (invariant rt RECT)
479                       (= (w rt) (h rt)))
480                '(and (invariant rt RECT)
481                      (= (w rt) (h rt)))
482                #f))
483            #:property property-names
484            (lambda (rt)
485              (sort-symbols
486                (append '(l l!)
487                        (property-names rt RECT))))
488            #:property l w
489            #:property l!
490            (lambda (rt)
491              (lambda (c)
492                (set! (w rt) c)
493                (set! (h rt) c)))
494            ))
496;; constructor, denoted with leading upper case
497(define (Square x y l)
498  (let ((result ((rtd-constructor SQUARE) x y l l)))
499    (if (invariant result)
500      result
501      (error 'Square "invariant broken"))))
502;; predicate
503(define (square? arg)
504  (and ((rtd-predicate SQUARE) arg)
505       (invariant arg)))
506;; printer
507(define-record-printer (SQUARE rt out)
508  (fprintf out "#,(square ~s ~s ~s)" (x rt) (y rt) (l rt)))
510;; reader
511(define-reader-ctor 'square Square)
513) ; squares
516Interesting is, how invariant and property-names are overridden in the
517subtpye {{SQUARE}}. To access the parent versions, simply add the supertype
518{{RECT}} as a second argument to the property.
519Another interesting point is the constructor {{Square}}. You can't simply
520call {{(Rect x y l l)}}. This would create a {{RECT}}, not a {{SQUARE}}. But the
521latter has four slots, not three. So you must call
522{{((rtd-constructor SQUARE) x y l l)}} and check the invariant. Note in
523passing that child constructors always expect the parent slots before the
524child slots. The latter don't exist in the present case.
525Note also, that property {{l}} is simply equivalent to property {{w}}, but {{l!}}
526isn't equivalent to {{w!}}.
527And last, but not least, properties {{move!}}, {{scale!}} and area needn't be
528redefined in {{SQUARE}}, the parent versions do the job.
530Now you can test your objects as well as some inspectors, issuing e.g.
532<enscript highlight=scheme>
533(import foos squares
534        (only srfi-99 rtd? record? rtd-name rtd-uid rtd-parent
535              rtd-field-names rtd-all-field-names))
536(rtd? SQUARE)
537(rtd-name (rtd-parent SQUARE))
538(rtd-field-names SQUARE)
539(rtd-all-field-names SQUARE)
540(rtd-uid RECT)
541(rtd-field-names RECT)
542(define sq (Square 1 2 3))
543(define rt (Rect 0 0 1 2))
544(object? sq)
545(record? rt)
546(invariant sq)
547(invariant rt)
548(type-name rt)
549(parent-type-name sq)
550(define foo (Foo))
551(rect? foo)
552(foo? foo)
553(invariant foo)
554(square? sq)
555(rect? sq)
556(square? rt)
557(x sq)
558(y sq)
559(l sq)
560(x rt)
561(y rt)
562(w rt)
563(h rt)
564((move! sq) 10 20)
565(invariant sq)
566(x sq)
567(y sq)
568(l sq)
569((x! sq) 0)
570((y! sq) 0)
571((l! sq) 5)
572(invariant sq)
577==== Variant records and object orientation
579Above, we've implemented methods as record-properties, Thomas Chust's
580extension to srfi-99 records. This way, the record alone encapsulates
581data and properties. But there is another pattern to implement object
582orientation with srfi-99 records, taking the message-sending metaphor
583literally. In this pattern, the record has only one record-property, a
584message handler, which accepts messages as arguments and discriminates
585between them according to their type. And messages can conveniently be
586implemented as variant records, another of Thomas' extensions to srfi-99
589In this pattern, instead of calling the property move! as above,
591{{((move! sq) 10 20)}},
593a {{move!}} message is send to {{sq}}'s only property, its handler, as follows
595{{((handle sq) (move! 10 20))}}
597Whereas in the method-properties pattern, encapsulation is achieved by
598the record, in the message-sending pattern, the module does the
599encapsulation job. This means, equally named methods are discriminated
600by the record instance, equally named messages need to be renamed or
603In essence, variant records supply two macros,
605* {{define-variant-type}}
606* {{variant-case}}
608the former defining a series of constructors, the latter discriminating
609between them in a case like fashion. Our old friends, objects, rects
610and squares can now be implemented as follows.
612<enscript highlight=scheme>
613;; abstract root object
614(module objects (OBJECT handle OBJECT-MESSAGE object-message? invariant messages)
615  (import scheme
616          (only (chicken base) constantly error)
617          (only srfi-99
618                define-record-property
619                make-rtd
620                rtd-predicate
621                record?
622                record-rtd
623                rtd-name
624                rtd-parent
625                define-variant-type
626                variant-case))
628(define-record-property handle) ; the only property
630;; message constructors
631(define-variant-type OBJECT-MESSAGE object-message?
632  (invariant)
633  (messages))
635(define OBJECT
636  (make-rtd 'object '#()
637            #:property handle
638            (lambda (obj)
639              (lambda (msg)
640                (if (object-message? msg)
641                  (variant-case OBJECT-MESSAGE msg
642                    ((invariant) #t)
643                    ((messages) '((#:OBJECT (invariant) (messages)))))
644                  ;do nothing (enabling broadcasts)
645                  )))))
647(define object? (rtd-predicate OBJECT))
649) ; objects
652Note, how the messages are defined and set apart. Besides the message
653type and predicate two parameterless constructors, invariant and
654messages, are defined and exported by the module. The exported handle
655property then inspects -- using variant-case -- the message constructors
656in sequence and invokes the code of the first matching one, after having
657checked, that {{msg}} is indeed of type {{OBJECT-MESSAGE}}, invoking the else
658clause otherwise. Here, the else clause does nothing on purpose: Message
659handling can be used for broadcasting. Hence, if a message is not
660understood, nothing happens.
662Here, these constructors are parameterless, but as we'll see in the
663sequel, variant-case not only serves as a discriminator, but also as an
664accessor to the constructors' arguments, without need to define accessor
667Here's the new version of the {{rects}} module:
669<enscript highlight=scheme>
670(module rects (RECT Rect rect? RECT-MESSAGE rect-message? x x! y y! w w!
671               h h! move! scale! area)
672  (import scheme objects
673          (only (chicken base) constantly error void define-reader-ctor)
674          (only (chicken format) fprintf)
675          (only srfi-99 define-record-printer define-record-property
676                define-variant-type variant-case
677                make-rtd rtd-constructor rtd-predicate rtd-accessor))
678  (reexport objects)
680;; new messages
681(define-variant-type RECT-MESSAGE rect-message?
682  (x)
683  (x! arg)
684  (y)
685  (y! arg)
686  (w)
687  (w! arg)
688  (h)
689  (h! arg)
690  (move! dx dy)
691  (scale! s)
692  (area))
694;;; message-handler
695(define (rect-handler obj)
696  (lambda (msg)
697    (cond
698      ((rect-message? msg)
699       (variant-case RECT-MESSAGE msg
700         ((x) (%x obj))
701         ((x! arg) (set! (%x obj) arg))
702         ((y) (%y obj))
703         ((y! arg) (set! (%y obj) arg))
704         ((w) (%w obj))
705         ((w! arg) (set! (%w obj) arg))
706         ((h) (%h obj))
707         ((h! arg) (set! (%h obj) arg))
708         ((move! dx dy)
709          (set! (%x obj) (+ (%x obj) dx))
710          (set! (%y obj) (+ (%y obj) dy)))
711         ((scale! s)
712          (set! (%w obj) (* (%w obj) s))
713          (set! (%h obj) (* (%h obj) s)))
714         ((area) (* (%w obj) (%h obj)))))
715      ((object-message? msg)
716       (variant-case OBJECT-MESSAGE msg
717        ((invariant)
718         (if (and (number? (%x obj)) (number? (%y obj))
719                  (number? (%w obj)) (number? (%h obj))
720                  (>= (%w obj) 0) (>= (%h obj) 0))
721           '(and (number? (%x obj)) (number? (%y obj))
722                 (number? (%w obj)) (number? (%h obj))
723                 (>= (%w obj) 0) (>= (%h obj) 0))
724           #f))
725         ((messages)
726          (cons '(#:RECT (x) (x! arg) (y) (y! arg) (w) (w! arg)
727                         (h) (h!  arg) (move! dx dy) (scale! s) (area))
728                ((handle obj OBJECT) (messages))))))
729      (else
730        ((handle obj OBJECT) msg)))))
732;;; rtd, denoted all upper case
733(define RECT
734  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
735            #:parent OBJECT
736            #:property handle rect-handler
737            ))
739;; constructor, denoted with leading upper case
740(define (Rect a b c d)
741  (let ((result ((rtd-constructor RECT) a b c d)))
742    (if ((handle result) (invariant))
743      result
744      (error 'Rect "invariant broken"))))
746;; predicate
747(define (rect? arg)
748  (and ((rtd-predicate RECT) arg)
749       ((handle arg) (invariant))))
751;; printer
752(define-record-printer (RECT rt out)
753  (fprintf out "#,(rect ~s ~s ~s ~s)"
754                ((handle rt) (x)) ((handle rt) (y))
755                ((handle rt) (w)) ((handle rt) (h))))
757;; reader
758(define-reader-ctor 'rect Rect)
761(define %x (rtd-accessor RECT 'x))
762(define %y (rtd-accessor RECT 'y))
763(define %w (rtd-accessor RECT 'w))
764(define %h (rtd-accessor RECT 'h))
766) ; rects
769The interesting thing here is, that of course, the handler can be
770defined outside of the record {{RECT}} and only be referenced inside.
771The variant-record {{RECT-MESSAGE}} does only define the new messages,
772whereas {{RECT}}'s handler accepts messages of {{OBJECT-MESSAGE}} as well,
773they are imported with rects.
775Now the message-sending-version of the squares module.
777<enscript highlight=scheme>
778(module squares (SQUARE SQUARE-MESSAGE Square square? square-message? l l!)
779  (import scheme rects ;objects
780          (only (chicken base) constantly error define-reader-ctor)
781          (only (chicken format) fprintf)
782          (only srfi-99 define-record-printer define-record-property
783                define-variant-type variant-case
784                make-rtd rtd-constructor rtd-predicate rtd-accessor))
785  (reexport rects)
787;; new messages
788(define-variant-type SQUARE-MESSAGE square-message?
789  (l)
790  (l! arg))
792(define (square-handler obj)
793  (lambda (msg)
794    (cond
795      ((square-message? msg)
796       (variant-case SQUARE-MESSAGE msg
797         ((l) ((handle obj) (w)))
798         ((l! arg)
799          ((handle obj) (w! arg))
800          ((handle obj) (h! arg)))))
801      ((object-message? msg)
802       (variant-case OBJECT-MESSAGE msg
803        ((invariant)
804         (if (and ((handle obj RECT) (invariant))
805                  (= ((handle obj) (w)) ((handle obj) (h))))
806           '(and ((handle obj RECT) (invariant))
807                 (= ((handle obj) (w)) ((handle obj) (h))))
808           #f))
809        ((messages)
810         (cons '(#:SQUARE (l) (l! arg))
811                 ((handle obj RECT) (messages))))))
812      (else
813       ((handle obj RECT) msg)))))
815;;;; type extension, aka inheritance
816(define SQUARE
817  (make-rtd 'square '#()
818            #:parent RECT
819            #:property handle square-handler))
821(define (Square x y l)
822  (let ((result ((rtd-constructor SQUARE) x y l l)))
823    (if ((handle result) (invariant))
824      result
825      (error 'Square "invariant broken"))))
827(define (square? arg)
828  (and ((rtd-predicate SQUARE) arg)
829       ((handle arg) (invariant))))
831;; printer
832(define-record-printer (SQUARE rt out)
833  (fprintf out "#,(square ~s ~s ~s)" ((handle rt) (x))
834                                     ((handle rt) (y))
835                                     ((handle rt) (l))))
837;; reader
838(define-reader-ctor 'square Square)
840) ; squares
843To show the usage of this oop message-sending pattern compared to the
844above method-property pattern, simply do the following
846<enscript highlight=scheme>
847(define sq (Square 0 0 1))
848(define rt (Rect 0 0 10 20)
849(for-each (lambda (x) ((handle x) (l! 5))) (list sq rt))
852No error occurs! Instead, only {{sq}} has changed, but {{rt}} is untouched:
853{{RECT}} can't handle the {{(l! 5)}} message and hence ignores it.  This is
854exactly the behaviour you want when broadcasting a message. There is no
855easy way to do the same with methods.
857==== The datatype egg
859Above, messages are defined with {{define-variant-type}} and processed with
860variant-case from the srfi-99 library. That's not the only possibility.
861You can use {{define-datatype}} and cases from the datatype egg instead, an
862implementation of the equally named routines from the classic
863Friedman, Wand, Haynes, Essentials of programming languages.
864We will not rewrite our modules objects, rects and squares in this
865terminology, but simply note the differences in syntax and semantics.
867Whereas the constructors in {{define-variant-type}} are written as normal
868Scheme procedures, e.g. {{(move! dx dy)}}, define-datatype constructors
869specify argument type predicates, or, more general, preconditions:
870{{(move! (dx number?) (dy number?))}}. In other words, type tests are done
871automatically. This saves a lot of work. Moreover, by redefining a
872constructor in a module, the preconditions can be intensified by
873additional predicates, which is in accordance with the "is a"
874relationship of inheritance.
876The cases construct of the datatype egg differs from variant-case above
877insofar, as they are not written as procedure calls. Instead of
878{{((move! dx dy) ...)}} one writes {{(move! (dx dy) ...)}}. This underlines the
879fact, that the variants play different roles. They serve not only as
880constructors, but as discriminators and accessors as well ...
882=== Epilogue
884We've seen, that srfi-99 records provide all the means to implement OOP,
885especially in Thomas Chust's implementation. We've also described two
886patterns to do that, methods and messages. Which pattern you prefer, is
887on your own. Both have advantages and drawbacks. Methods are more
888tightly coupled with records, messages are more flexible, in particular,
889they allow broadcasts. In connection with define-datatype, they provide
890automatic precondition tests, where preconditions can even be
893It should be noted, that Chicken Scheme supplies a lot of eggs with
894other implementations of OOP. One, based on datatype and message passing
895as described above, is supplied in the datatypes egg (note the plural).
896The most complete one, however, is coops, which is similar to Common
897Lisp's CLOS.
898This diversity demonstrates the power of the simple minimalist Scheme language ...
900== Last update
902Jun 25, 2015
904== Author
906[[/users/juergen-lorenz|Juergen Lorenz]]
Note: See TracBrowser for help on using the repository browser.