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

Last change on this file since 32518 was 32518, checked in by juergen, 5 years ago

juergen-lorenz and records-and-oop updated

File size: 30.2 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 special-forms unit. 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.
50rect-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 special-forms unit, 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 library unit 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 records egg.  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
118Chicken'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,
127Chicken'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
210define-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 childs. 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 error define-reader-ctor)
347          (only extras 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 error define-reader-ctor)
464          (only extras 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
518RECT 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 inpectors, 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 error)
617          (only data-structures constantly)
618          (only srfi-99
619                define-record-property
620                make-rtd
621                rtd-predicate
622                record?
623                record-rtd
624                rtd-name
625                rtd-parent
626                define-variant-type
627                variant-case))
629(define-record-property handle) ; the only property
631;; message constructors
632(define-variant-type OBJECT-MESSAGE object-message?
633  (invariant)
634  (messages))
636(define OBJECT
637  (make-rtd 'object '#()
638            #:property handle
639            (lambda (obj)
640              (lambda (msg)
641                (if (object-message? msg)
642                  (variant-case OBJECT-MESSAGE msg
643                    ((invariant) #t)
644                    ((messages) '((#:OBJECT (invariant) (messages)))))
645                  ;do nothing (enabling broadcasts)
646                  )))))
648(define object? (rtd-predicate OBJECT))
650) ; objects
653Note, how the messages are defined and set apart. Besides the message
654type and predicate two parameterless constructors, invariant and
655messages, are defined and exported by the module. The exported handle
656property then inspects -- using variant-case -- the message constructors
657in sequence and invokes the code of the first matching one, after having
658checked, that msg is indeed of tye OBJECT-MESSAGE, invoking the else
659clause otherwise. Here, the else clause does nothing on purpose: Message
660handling can be used for broadcasting. Hence, if a message is not
661understood, nothing happens.
663Here, these constructors are parameterless, but as we'll see in the
664sequel, variant-case not only serves as a discriminator, but also as an
665accessor to the constructors' arguments, without need to define accessor
668Here's the new version of the rects module:
670<enscript highlight=scheme>
671(module rects (RECT Rect rect? RECT-MESSAGE rect-message? x x! y y! w w!
672               h h! move! scale! area)
673  (import scheme objects
674          (only chicken error void define-reader-ctor)
675          (only data-structures constantly)
676          (only extras fprintf)
677          (only srfi-99 define-record-printer define-record-property
678                define-variant-type variant-case
679                make-rtd rtd-constructor rtd-predicate rtd-accessor))
680  (reexport objects)
682;; new messages
683(define-variant-type RECT-MESSAGE rect-message?
684  (x)
685  (x! arg)
686  (y)
687  (y! arg)
688  (w)
689  (w! arg)
690  (h)
691  (h! arg)
692  (move! dx dy)
693  (scale! s)
694  (area))
696;;; message-handler
697(define (rect-handler obj)
698  (lambda (msg)
699    (cond
700      ((rect-message? msg)
701       (variant-case RECT-MESSAGE msg
702         ((x) (%x obj))
703         ((x! arg) (set! (%x obj) arg))
704         ((y) (%y obj))
705         ((y! arg) (set! (%y obj) arg))
706         ((w) (%w obj))
707         ((w! arg) (set! (%w obj) arg))
708         ((h) (%h obj))
709         ((h! arg) (set! (%h obj) arg))
710         ((move! dx dy)
711          (set! (%x obj) (+ (%x obj) dx))
712          (set! (%y obj) (+ (%y obj) dy)))
713         ((scale! s)
714          (set! (%w obj) (* (%w obj) s))
715          (set! (%h obj) (* (%h obj) s)))
716         ((area) (* (%w obj) (%h obj)))))
717      ((object-message? msg)
718       (variant-case OBJECT-MESSAGE msg
719        ((invariant)
720         (if (and (number? (%x obj)) (number? (%y obj))
721                  (number? (%w obj)) (number? (%h obj))
722                  (>= (%w obj) 0) (>= (%h obj) 0))
723           '(and (number? (%x obj)) (number? (%y obj))
724                 (number? (%w obj)) (number? (%h obj))
725                 (>= (%w obj) 0) (>= (%h obj) 0))
726           #f))
727         ((messages)
728          (cons '(#:RECT (x) (x! arg) (y) (y! arg) (w) (w! arg)
729                         (h) (h!  arg) (move! dx dy) (scale! s) (area))
730                ((handle obj OBJECT) (messages))))))
731      (else
732        ((handle obj OBJECT) msg)))))
734;;; rtd, denoted all upper case
735(define RECT
736  (make-rtd 'rect '#((mutable x) (mutable y) (mutable w) (mutable h))
737            #:parent OBJECT
738            #:property handle rect-handler
739            ))
741;; constructor, denoted with leading upper case
742(define (Rect a b c d)
743  (let ((result ((rtd-constructor RECT) a b c d)))
744    (if ((handle result) (invariant))
745      result
746      (error 'Rect "invariant broken"))))
748;; predicate
749(define (rect? arg)
750  (and ((rtd-predicate RECT) arg)
751       ((handle arg) (invariant))))
753;; printer
754(define-record-printer (RECT rt out)
755  (fprintf out "#,(rect ~s ~s ~s ~s)"
756                ((handle rt) (x)) ((handle rt) (y))
757                ((handle rt) (w)) ((handle rt) (h))))
759;; reader
760(define-reader-ctor 'rect Rect)
763(define %x (rtd-accessor RECT 'x))
764(define %y (rtd-accessor RECT 'y))
765(define %w (rtd-accessor RECT 'w))
766(define %h (rtd-accessor RECT 'h))
768) ; rects
771The interesting thing here is, that of course, the handler can be
772defined outside of the record RECT and only be referenced inside.
773The variant-record RECT-MESSAGE does only define the new messages,
774whereas RECT's handler accepts messages of OBJECT-MESSAGE as well,
775they are imported with rects.
777Now the message-sending-version of the squares module.
779<enscript highlight=scheme>
780(module squares (SQUARE SQUARE-MESSAGE Square square? square-message? l l!)
781  (import scheme rects ;objects
782          (only chicken error define-reader-ctor)
783          (only data-structures constantly)
784          (only extras fprintf)
785          (only srfi-99 define-record-printer define-record-property
786                define-variant-type variant-case
787                make-rtd rtd-constructor rtd-predicate rtd-accessor))
788  (reexport rects)
790;; new messages
791(define-variant-type SQUARE-MESSAGE square-message?
792  (l)
793  (l! arg))
795(define (square-handler obj)
796  (lambda (msg)
797    (cond
798      ((square-message? msg)
799       (variant-case SQUARE-MESSAGE msg
800         ((l) ((handle obj) (w)))
801         ((l! arg)
802          ((handle obj) (w! arg))
803          ((handle obj) (h! arg)))))
804      ((object-message? msg)
805       (variant-case OBJECT-MESSAGE msg
806        ((invariant)
807         (if (and ((handle obj RECT) (invariant))
808                  (= ((handle obj) (w)) ((handle obj) (h))))
809           '(and ((handle obj RECT) (invariant))
810                 (= ((handle obj) (w)) ((handle obj) (h))))
811           #f))
812        ((messages)
813         (cons '(#:SQUARE (l) (l! arg))
814                 ((handle obj RECT) (messages))))))
815      (else
816       ((handle obj RECT) msg)))))
818;;;; type extension, aka inheritance
819(define SQUARE
820  (make-rtd 'square '#()
821            #:parent RECT
822            #:property handle square-handler))
824(define (Square x y l)
825  (let ((result ((rtd-constructor SQUARE) x y l l)))
826    (if ((handle result) (invariant))
827      result
828      (error 'Square "invariant broken"))))
830(define (square? arg)
831  (and ((rtd-predicate SQUARE) arg)
832       ((handle arg) (invariant))))
834;; printer
835(define-record-printer (SQUARE rt out)
836  (fprintf out "#,(square ~s ~s ~s)" ((handle rt) (x))
837                                     ((handle rt) (y))
838                                     ((handle rt) (l))))
840;; reader
841(define-reader-ctor 'square Square)
843) ; squares
846To show the usage of this oop message-sending pattern compared to the
847above method-property pattern, simply do the following
849<enscript highlight=scheme>
850(define sq (Square 0 0 1))
851(define rt (Rect 0 0 10 20)
852(for-each (lambda (x) ((handle x) (l! 5))) (list sq rt))
855No error occurs! Instead , only sq has changed, but rt is untouched:
856RECT can't handle the (l! 5) message and hence ignores it.  This is
857exactly the behaviour you want when broadcasing a message. There is no
858easy way to do the same with methods.
860==== The datatype egg
862Above, messages are defined with define-variant-type and processed with
863variant-case from the srfi-99 library. That's not the only possibility.
864You can use define-datatype and cases from the datatype egg instead, an
865implementation of the equally named routines from the classic
866Friedman, Wand, Haynes, Essentials of programming languages.
867We will not rewrite our modules objects, rects and squares in this
868terminology, but simply note the differences in syntax and semantics.
870Whereas the constructors in define-variant-type are written as normal
871Scheme procedures, e.g. (move! dx dy), define-datatype constructors
872specify argument type predicates, or, more general, preconditions:
873(move! (dx number?) (dy number?)). In other words, type tests are done
874automatically. This saves a lot of work. Moreover, by redefining a
875constructor in a module, the preconditions can be intensified by
876additional predicates, which is in accordance with the "is a"
877relationship of inheritance.
879The cases construct of the datatype egg differs from variant-case above
880insofar, as they are not written as procedure calls. Instead of
881((move! dx dy) ...) one writes (move! (dx dy) ...). This underlines the
882fact, that the variants play different roles. They serve not only as
883constructors, but as discriminators and accessors as well ...
885=== Epilogue
887We've seen, that srfi-99 records provide all the means to implement OOP,
888especially in Thomas Chust's implementation. We've also described two
889patterns to do that, methods and messages. Which pattern you prefer, is
890on your own. Both have advantages and drawbacks. Methods are more
891tightly coupled with records, messages are more flexible, in particular,
892they allow broadcasts. In connection with define-datatype, they provide
893automatic precondition tests, where preconditions can even be
896It should be noted, that Chicken Scheme supplies a lot of eggs with
897other implementations of OOP. One, based on datatype and message passing
898as described above, is supplied in the datatypes egg (note the plural).
899The most complete one, however, is coops, which is similar to Common
900Lisp's CLOS.
901This diversity demonstrates the power of the simple minimalist Scheme language ...
903== Last update
905Jun 25, 2015
907== Author
909[[/users/juergen-lorenz|Juergen Lorenz]]
Note: See TracBrowser for help on using the repository browser.