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