;;; 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