You are looking at historical revision 32266 of this page. It may differ significantly from its current revision.

Records and Object Orientation

Records are the feature most painfully missed in R5RS. Consequently Chicken supplied define-record in the special-forms unit. It is easy to use, but personally I don't like it because it does too much behind the scene. For example, the following call

(define-record point x y)

creates automatically six procedures

for each slot, x and y,

This is convenient, but since these procedures are never defined explicitly, you might have problems understanding code, where their use is far away from the call to define-record. Moreover, you are missing the flexibility to choose your own names for these procedures, and -- which is more important -- you can't make individual slots read-only.

define-record-type

All these problems are avoided using srfi-9's define-record-type, also supplied by Chicken in the special-forms unit. The following call will do exactly the same as the define-record call above, but now all names are explicit, hence can be chosen by yourself and the modifiers can be omitted at all, thus providing read-only slots.

(define-record-type point
  (make-point x y)
  point?
  (x point-x point-x-set!)
  (y point-y point-y-set!))

define-record-printer

Both define-record and define-record-type can be used in combination with define-record-printer from the special-forms unit, thus allowing records to be printed in a readable form. Without it, a point instance is simply printed #<point>, which is not very descriptive. But having written

(define-record-printer (point pt out)
  (fprintf out "#,(point ~s ~s)" (point-x pt) (point-y pt)))

(make-point 1 2) will print #,(point 1 2) instead of #<point>.

define-reader-ctor

Now you can turn things around and read a point instance written in the form printed above via

(define pt '#,(point 1 2))

provided you have used srfi-10's define-reader-ctor, supplied by Chicken's library unit via

(define-reader-ctor 'point make-point)

The records egg

Up to now, you have used a syntactic interface to points. There is a procedural one as well, provided by the records egg. Now I can reduce the number of identifiers by packaging accessors and modifiers with srfi-17's getter-with-setter, so that set! can work on accessor expressions. But note, that define-record-printer is used a bit different then above, because you must use the name of the record-type, not the record-type-descriptor.

(use records)
(define POINT (make-record-type 'point '(x y)))
(define Point (record-constructor POINT))
(define point? (record-predicate POINT))
(define point-x (getter-with-setter (record-accessor POINT 'x)
                                    (record-mutator POINT 'x)))
(define point-y (getter-with-setter (record-accessor POINT 'y)
                                    (record-mutator POINT 'y)))
(define-record-printer ('point pt out) ; note 'point, not POINT
  (fprintf out "#,(point ~s ~s)" (point-x pt) (point-y pt)))

Now with (define pt (Point 1 2)), pt will print #,(point 1 2), (point-x pt) will print 1 and after (set! (point-x pt) 10) it will print 10.

Henceforth, record-type descriptors will be written all uppercase, and the corresponding constructor starting uppercase.

srfi-99

Chicken's implementation of srfi-99, written by Thomas Chust, combines both interfaces, the syntactic and the procedural one, so that they can be used interchangeably, and it provides its own version of define-record-printer.

This one module comprises srfi-99-variants and srfi-99-records, the latter in turn comprising submodules srfi-99-records-procedural, srfi-99-records-inspection and srfi-99-records-syntactic, the former being an extension to the srfi-99 document. As that document postulates, Chicken's srfi-99 records not only implement type extension in the form of single inheritance (so that, e.g., the record-type-descriptor POINT of a flat point can be extended to a record-type-descriptor POINT-3D of a space point), but also all optional extensions, the srfi-document mentions: opaque, sealed and non-generative records.

And that's not all. Thomas' implementation includes record-properties, which can be attached to record-type-descriptors -- henceforth abbreviated rtd's -- and which can be used to implement single inheritance object orientation.

Type extension

From now on, we assume srfi-99 is used.

Let's start with extending a flat point to a space point, but now with the procderural interface. First flat points.

(define POINT (make-rtd 'point '#((x) (y))))
(define Point (rtd-constructor POINT))
(define point? (rtd-predicate POINT))
(define point-x (rtd-accessor POINT 'x))
(define point-y (rtd-accessor POINT 'y))

Apart from name-changes, you'll notice, that the fields are now referenced in a vector instead of a list and they are parenthesized, meaning they are mutable. The name-changes of srfi-99 with the rtd abbreviations, untypical for Scheme, are caused, not to conflict with R6RS-records. Without these parentheses, they where immutable. If you want, you can be more verbose: (mutable x) would be the same as (x), and (immutable x) the same as x without parentheses. Another change is, that explicit mutators via getter-with-setter are missing; they are automatically provided by the srfi-99 library, so something like (set! (point-x pt) 10) would work as expected.

But the fun begins now, space points. Note the parent: clause.

(define POINT-3D (make-rtd 'point-3d '#((z)) parent: POINT))
(define Point-3d (rtd-constructor POINT-3D))
(define point-3d? (rtd-predicate POINT-3D))
(define point-3d-z (rtd-accessor POINT-3D 'z))

Now, issuing (define p3 (Point-3d 1 2 3)) we can access all fields with point-x, point-y and point-3d-z and can set them in the srfi-17 way with e.g. (set! (point-x p3) 10).

Record properties and object orientation

The above is fine, but there is a serious drawback: The accessors are statically bound. So we had to use names like point-x and point-3d-z to avoid name clashes, forcing the user of these records to remember in which hierarchy-level the accessors were defined; a real problem, if the hierarchy is deep. We would prefer to have them dynamically bound and given them names like x, y and z, the actual routine being looked up by the system. That's exactly what record-properties provide.

First we have to define the record-properties

(define-record-property x)
(define-record-property y)
(define-record-property z)
(define-record-property x-set!)
(define-record-property y-set!)
(define-record-property z-set!)

This defines six procedures of at least one argument, which will eventually be applied to records, which have corresponding procedures bound to its record-type-descriptor. Before this happens, these properties will allways return the default value #f independently of its argument; try this by issuing (x #t) or (x #t #t #t). If you want another value to be returned, you must supply it as a second argument to define-record-property. This second argument is returned via Chicken's constantly procedure. But you should be aware, that symbols as second argument to record-properties are treated specially: inside rtd's they refer to accessors of equally named fields.

To bind properties to record-type-descriptors, you'll need the property: clause of make-rtd. Note, that the six properties above are more or less dynamically bound versions of the statically bound accessors like point-x and point-3d-z. So the latter must be available in make-rtd. Hence we close make-rtd over local variables supplying those accessors. So the two rtd's are defined as follows

(define POINT
  (let (
    (point-x (getter-with-setter
               (lambda (pt)
                 ((rtd-accessor POINT 'x) pt))
               (lambda (pt a)
                 ((rtd-mutator POINT 'x) pt a))))
    (point-y (getter-with-setter
               (lambda (pt)
                 ((rtd-accessor POINT 'y) pt))
               (lambda (pt b)
                 ((rtd-mutator POINT 'y) pt b))))
    )
    (make-rtd 'point '#((x) (y))
              property: x
                        point-x
              property: x-set!
                        (lambda (pt)
                          (lambda (a)
                            (set! (point-x pt) a)))
              property: y
                        point-y
              property: y-set!
                        (lambda (pt)
                          (lambda (b)
                            (set! (point-y pt) b)))
              )))
(define Point (rtd-constructor POINT))
(define point? (rtd-predicate POINT))

(define POINT-3D
  (let (
    (point-3d-z (getter-with-setter
                  (lambda (pt)
                    ((rtd-accessor POINT-3D 'z) pt))
                  (lambda (pt c)
                    ((rtd-mutator POINT-3D 'z) pt c))))
    )
    (make-rtd 'point-3d '#((z))
              parent: POINT
              property: z point-3d-z
              property: z-set! (lambda (pt)
                                 (lambda (c)
                                   (set! (point-3d-z pt) c)))
              )))
(define Point-3d (rtd-constructor POINT-3D))
(define point-3d? (rtd-predicate POINT-3D))

Unfortunately we can't define the local accessors as e.g.

(point-3d-z (rtd-accessor POINT-3D 'z))

which would provide the mutators as well. The reason is, that POINT-3D isn't yet available in the let, but wrapping the accessor in a procedure will work, because when that procedure is invoked, POINT-3D is available. But then we need to supply a mutator for the wrapped accessor, done here in the getter-with-setter call.

Note in passing, that this wrapping of accessors can be avoided, if we package the whole shebang into a letrec*, which would result in

(define POINT-3D
  (letrec* (
    (POINT-3D (make-rtd
                'point-3d '#((z))
                parent: POINT
                property: z 'z
                property: z-set! (lambda (pt)
                                   (lambda (c)
                                     (set! (point-3d-z pt) c)))
              ))
    (point-3d-z (rtd-accessor POINT-3D 'z))
    )
    POINT-3D))

It's a matter of taste, which pattern you prefer.

Now x and friends are dynamically bound. If there where other records with property x bound to its type, always the right accessor would be chosen. To see this, let's enhance the example, so that it's more realistic. In doing this, we'll package the types in modules.

Points revisited

Realistic points should always have numeric fields, and they should be movable! Moreover, they should always be in a valid state. In other words, we would like to have an invariant property, which checks the validity of its state and a move! property.

Well, the invariant property should be available in every object, not only points, and it should not only check the validity of an object but document its record type as well. Hence, it's not a predicate but can be used as such. The checks could be issued before and after every state changing procedure and after the constructor call. For simplicity, this will not be done here.

Since invariant should be available everywhere, we package it in its own module together with other properties, which should be available everywhere, including property-names returning the list of exported properties. This module also contains an abstract type, OBJECT, to which these properties are bound. OBJECT will be the parent of all object types.

(module objects *
  (import scheme
          (only srfi-99
                define-record-property
                make-rtd
                rtd-predicate
                record?
                record-rtd
                rtd-name
                rtd-parent))
(define-record-property invariant "invariant not implemented")
(define-record-property type-name "type-name not implemented")
(define-record-property parent-type-name "parent-type-name not implemented")
(define-record-property property-names "property-names not implemented")

(define OBJECT
        (make-rtd 'object '#()
          property: invariant
                    #t
          property: type-name
                    (lambda (obj)
                      (rtd-name (record-rtd obj)))
          property: parent-type-name
                    (lambda (obj)
                      (rtd-name (rtd-parent (record-rtd obj))))
          property: property-names
                    (lambda (obj)
                      (sort-symbols
                        '(invariant type-name parent-type-name
                                                property-names)))
          ))
(define object? (rtd-predicate OBJECT))

(define (sort-symbols symlist)
  (sort symlist (lambda (x y)
                  (string-ci<=? (symbol->string x)
                                (symbol->string y)))))
) ; objects

To test, that invariant works indeed everywhere, we'll use a fake module using the syntactic interface:

(module foos (FOO Foo foo? invariant)
  (import scheme objects
          (only srfi-99 define-record-type define-record-property))
;;; a different inheritance branch
(define-record-type (FOO parent: OBJECT property: invariant "foo") (Foo) foo?)
) ; foos

Now the implementation of flat points ...

(module points (POINT Point point? x x-set! y y-set! move!)
  (import scheme objects
          (only chicken error getter-with-setter define-reader-ctor)
          (only extras fprintf)
          (only srfi-99 define-record-printer define-record-property
                make-rtd rtd-constructor
                rtd-predicate rtd-accessor rtd-mutator))
  (reexport objects)

;; new properties
(define-record-property move! "move! not implemented")
(define-record-property x "x not implemented")
(define-record-property x-set! "x-set! not implemented")
(define-record-property y "y not implemented")
(define-record-property y-set! "y-set! not implemented")

;;; rtd, denoted all upper case
(define POINT
  (let (
    (%x (getter-with-setter
          (lambda (pt)
            ((rtd-accessor POINT 'x) pt))
          (lambda (pt a)
            (if (number? a)
              ((rtd-mutator POINT 'x) pt a)
              (error 'x-set! "number expected" a)))))
    (%y (getter-with-setter
          (lambda (pt)
            ((rtd-accessor POINT 'y) pt))
          (lambda (pt b)
            (if (number? b)
              ((rtd-mutator POINT 'y) pt b)
              (error 'y-set! "number eypected" b)))))
    )
    (make-rtd 'point '#((x) (y))
              parent: OBJECT
              property: move!
                        (lambda (pt)
                          (lambda (dx dy)
                            (set! (%x pt) (+ (%x pt) dx))
                            (set! (%y pt) (+ (%y pt) dy))))
              property: invariant
                        (lambda (pt)
                          (if (and (number? (%x pt))
                                   (number? (%y pt)))
                            '(and (number? (x pt))
                                  (number? (y pt)))
                            #f))
              property: property-names
                        (lambda (pt)
                          (sort-symbols
                            (append '(move! x x-set! y y-set!)
                                    (property-names pt OBJECT))))
              property: x
                        %x
              property: x-set!
                        (lambda (pt)
                          (lambda (a)
                            (set! (%x pt) a)))
              property: y
                        %y
              property: y-set!
                        (lambda (pt)
                          (lambda (b)
                            (set! (%y pt) b)))
              )))

;; constructor, denoted with leading upper case
(define Point (lambda (a b)
                (if (and (number? a) (number? b))
                  ((rtd-constructor POINT) a b)
                  (error 'Point "two number arguments needed"))))
;; predicate
(define point? (rtd-predicate POINT))

;; printer
(define-record-printer (POINT pt out)
  (fprintf out "#,(point ~s ~s)" (x pt) (y pt))) 

;; reader
(define-reader-ctor 'point Point)

) ; points

... and of space points:

(module points-3d (POINT-3D Point-3d point-3d? z z-set!)
  (import scheme
          (only points POINT move! invariant x x-set! y y-set!)
          (only chicken error getter-with-setter define-reader-ctor)
          (only extras fprintf)
          (only srfi-99 define-record-printer define-record-property
                make-rtd rtd-constructor
                rtd-predicate rtd-accessor rtd-mutator))
  (reexport (except points POINT Point point?))

(define-record-property z "z not implemented")
(define-record-property z-set! "z-set! not implemented")

;;; type extension, aka inheritance
(define POINT-3D
  (let (
    (%z (getter-with-setter
          (lambda (pt)
            ((rtd-accessor POINT-3D 'z) pt))
          (lambda (pt c)
            (if (number? c)
              ((rtd-mutator POINT-3D 'z) pt c)
              (error 'z-set! "number expected" c)))))
    )
    (make-rtd 'point-3d '#((z))
              parent: POINT
              property: move!
                        (lambda (pt)
                          (lambda (dx dy dz)
                            ((move! pt POINT) dx dy)
                            (set! (%z pt)
                                  (+ (%z pt) dz))))
              property: invariant
                        (lambda (pt)
                          (if (and (invariant pt POINT)
                                   (number? (%z pt)))
                            '(and (number? (x pt))
                                  (number? (y pt))
                                  (number? (z pt)))
                            #f))
              property: property-names
                        (lambda (pt)
                          (sort-symbols
                            (append '(z z-set!)
                                    (property-names pt POINT))))
              property: z
                        %z
              property: z-set!
                        (lambda (pt)
                          (lambda (c)
                            (set! (%z pt) c)))
              )))

;; constructor, denoted with leading upper case
(define Point-3d
  (lambda (a b c)
    (if (and (number? a) (number? b) (number? c))
      ((rtd-constructor POINT-3D) a b c)
      (error 'Point-3d "three number arguments needed"))))
;; predicate
(define point-3d? (rtd-predicate POINT-3D))

;; printer
(define-record-printer (POINT-3D pt out)
  (fprintf out "#,(point-3d ~s ~s ~s)" (x pt) (y pt) (z pt))) 

;; reader
(define-reader-ctor 'point-3d Point-3d)

) ; points-3d

Interesting is, how move! and invariant are overridden in the subtpye POINT-3D: Simply add the supertype POINT as a second argument to the property to access the precursor.

Now you can test your objects as well as some inpectors, issuing e.g.

(import foos points points-3d
        (only srfi-99 rtd? record? rtd-name rtd-uid rtd-parent
              rtd-field-names rtd-all-field-names))
(rtd? POINT-3D)
(rtd-name (rtd-parent POINT-3D))
(rtd-field-names POINT-3D)
(rtd-all-field-names POINT-3D)
(rtd-uid POINT)
(rtd-field-names POINT)
(define p3 (Point-3d 1 2 3))
(define p2 (Point -1 -2))
(object? p3)
(record? p2)
(invariant p3)
(invariant p2)
(type-name p2)
(parent-type-name p3)
(define foo (Foo))
(point? foo)
(foo? foo)
(invariant foo)
(point-3d? p3)
(point? p3)
(point-3d? p2)
(x p3)
(y p3)
(z p3)
(x p2)
(y p2)
((move! p3) 10 20 30)
(invariant p3)
(x p3)
(y p3)
(z p3)
((x-set! p3) 11)
((y-set! p3) 22)
((z-set! p3) 33)
(invariant p3)
p3

Last update

Feb 08, 2015

Author

Juergen Lorenz