3.14.1 Terms

Object

Any Scheme data object.

Instance

An instance of the OO system; an object.

Operation

A method.

Notes:

The object system supports multiple inheritance. An instance can inherit from 0 or more ancestors. In the case of multiple inherited operations with the same identity, the operation used is that from the first ancestor which contains it (in the ancestor let). An operation may be applied to any Scheme data object—not just instances. As code which creates instances is just code, there are no classes and no meta-anything. Method dispatch is by a procedure call a la CLOS rather than by send syntax a la Smalltalk.

Disclaimer:

There are a number of optimizations which can be made. This implementation is expository (although performance should be quite reasonable). See the L&FP paper for some suggestions.

3.14.2 Interface

Syntax: define-operation (opname self arg …) default-body ¶

Defines a default behavior for data objects which don’t handle the operation opname. The default behavior (for an empty default-body) is to generate an error.

Syntax: define-predicate opname? ¶

Defines a predicate opname?, usually used for determining the type of an object, such that (opname? object) returns #t if object has an operation opname? and #f otherwise.

Syntax: object ((name self arg …) body) … ¶

Returns an object (an instance of the object system) with operations. Invoking (name object arg …) executes the body of the object with self bound to object and with argument(s) arg….

Syntax: object-with-ancestors ((ancestor1 init1) …) operation … ¶

A let-like form of object for multiple inheritance. It returns an object inheriting the behaviour of ancestor1 etc. An operation will be invoked in an ancestor if the object itself does not provide such a method. In the case of multiple inherited operations with the same identity, the operation used is the one found in the first ancestor in the ancestor list.

Syntax: operate-as component operation self arg … ¶

Used in an operation definition (of self) to invoke the operation in an ancestor component but maintain the object’s identity. Also known as “send-to-super”.

Procedure: print obj port ¶

A default print operation is provided which is just (format port obj) (see Format (version 3.1)) for non-instances and prints obj preceded by ‘#<INSTANCE>’ for instances.

Function: size obj ¶

The default method returns the number of elements in obj if it is a vector, string or list, 2 for a pair, 1 for a character and by default id an error otherwise. Objects such as collections (see Collections) may override the default in an obvious way.

3.14.3 Setters

Setters implement generalized locations for objects associated with some sort of mutable state. A getter operation retrieves a value from a generalized location and the corresponding setter operation stores a value into the location. Only the getter is named – the setter is specified by a procedure call as below. (Dylan uses special syntax.) Typically, but not necessarily, getters are access operations to extract values from Yasos objects (see Yasos). Several setters are predefined, corresponding to getters car, cdr, string-ref and vector-ref e.g., (setter car) is equivalent to set-car!.

This implementation of setters is similar to that in Dylan(TM) (Dylan: An object-oriented dynamic language, Apple Computer Eastern Research and Technology). Common LISP provides similar facilities through setf.

Function: setter getter ¶

Returns the setter for the procedure getter. E.g., since string-ref is the getter corresponding to a setter which is actually string-set!:

(define foo "foo")
((setter string-ref) foo 0 #\F) ; set element 0 of foo
foo ⇒ "Foo"

Syntax: set place new-value ¶

If place is a variable name, set is equivalent to set!. Otherwise, place must have the form of a procedure call, where the procedure name refers to a getter and the call indicates an accessible generalized location, i.e., the call would return a value. The return value of set is usually unspecified unless used with a setter whose definition guarantees to return a useful value.

(set (string-ref foo 2) #\O)  ; generalized location with getter
foo ⇒ "FoO"
(set foo "foo")               ; like set!
foo ⇒ "foo"

Procedure: add-setter getter setter ¶

Add procedures getter and setter to the (inaccessible) list of valid setter/getter pairs. setter implements the store operation corresponding to the getter access operation for the relevant state. The return value is unspecified.

Procedure: remove-setter-for getter ¶

Removes the setter corresponding to the specified getter from the list of valid setters. The return value is unspecified.

Syntax: define-access-operation getter-name ¶

Shorthand for a Yasos define-operation defining an operation getter-name that objects may support to return the value of some mutable state. The default operation is to signal an error. The return value is unspecified.

3.14.4 Examples

;;; These definitions for PRINT and SIZE are
;;; already supplied by
(require 'yasos)

(define-operation (print obj port)
  (format port
          (if (instance? obj) "#<instance>" "~s")
          obj))

(define-operation (size obj)
  (cond
   ((vector? obj) (vector-length obj))
   ((list?   obj) (length obj))
   ((pair?   obj) 2)
   ((string? obj) (string-length obj))
   ((char?   obj) 1)
   (else
    (slib:error "Operation not supported: size" obj))))

(define-predicate cell?)
(define-operation (fetch obj))
(define-operation (store! obj newValue))

(define (make-cell value)
  (object
   ((cell? self) #t)
   ((fetch self) value)
   ((store! self newValue)
    (set! value newValue)
    newValue)
   ((size self) 1)
   ((print self port)
    (format port "#<Cell: ~s>" (fetch self)))))

(define-operation (discard obj value)
  (format #t "Discarding ~s~%" value))

(define (make-filtered-cell value filter)
  (object-with-ancestors
   ((cell (make-cell value)))
   ((store! self newValue)
   (if (filter newValue)
       (store! cell newValue)
       (discard self newValue)))))

(define-predicate array?)
(define-operation (array-ref array index))
(define-operation (array-set! array index value))

(define (make-array num-slots)
  (let ((anArray (make-vector num-slots)))
    (object
     ((array? self) #t)
     ((size self) num-slots)
     ((array-ref self index)
      (vector-ref  anArray index))
     ((array-set! self index newValue)
      (vector-set! anArray index newValue))
     ((print self port)
      (format port "#<Array ~s>" (size self))))))

(define-operation (position obj))
(define-operation (discarded-value obj))

(define (make-cell-with-history value filter size)
  (let ((pos 0) (most-recent-discard #f))
    (object-with-ancestors
     ((cell (make-filtered-call value filter))
      (sequence (make-array size)))
     ((array? self) #f)
     ((position self) pos)
     ((store! self newValue)
      (operate-as cell store! self newValue)
      (array-set! self pos newValue)
      (set! pos (+ pos 1)))
     ((discard self value)
      (set! most-recent-discard value))
     ((discarded-value self) most-recent-discard)
     ((print self port)
      (format port "#<Cell-with-history ~s>"
              (fetch self))))))

(define-access-operation fetch)
(add-setter fetch store!)
(define foo (make-cell 1))
(print foo #f)
⇒ "#<Cell: 1>"
(set (fetch foo) 2)
⇒
(print foo #f)
⇒ "#<Cell: 2>"
(fetch foo)
⇒ 2