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