present for /prog/

; A prototype based object system
(define (resolve-slot object name)
  (let loop ((queue (list object)))
    (cond
      ((null? queue) #f)
      (((car queue) '_get-slot name) => (lambda (slot) slot))
      (else (loop (append (cdr queue)
                          ((car queue) '_protos)))))))
(define (meta-object)
  (let ((protos '()) (slots (make-hash-table)))
    (define (self message . args)
      (let-syntax ((meta-method
                    (syntax-rules ()
                      ((_ (method-args ...) body ...)
                       (apply (lambda (method-args ...) body ...) args)))))
        (case message
          ((_protos) protos)
          ((_slots) slots)
          ((_get-slot)
           (meta-method (name)
                        (hash-table-get slots name #f)))
          ((_set-slot!)
           (meta-method (name value)
                        (hash-table-put! slots name value)))
          ((_append-proto!)
           (meta-method (proto)
                        (set! protos (cons proto protos))))
          (else (cond
                  ((not (symbol? message))
                   (error "message must be a symbol -- META-OBJECT"
                          message args))
                  ((resolve-slot self message)
                   => (lambda (slot) (apply slot (cons self args))))
                  ; If an object doesn't respond to a message, invoke the "forward"
                  ; method if it has one.
                  ((resolve-slot self 'forward)
                   => (lambda (forward) (apply forward
                                               (append (list self message) args))))
                  (else
                   (error "don't know how to respond -- META-OBJECT"
                          message args)))))))
    self))
(define object
  (let ((self (meta-object)))
    (let-syntax ((define-slot
                   (syntax-rules ()
                     ((_ (name args ...) body ...)
                      (self '_set-slot! 'name (lambda (args ...) body ...))))))
      (define-slot (get-slot self name)
        (resolve-slot self name))
      (define-slot (set-slot! self name value)
        (self '_set-slot! name value))
      (define-slot (append-proto! self proto)
        (self '_append-proto proto))
      (define-slot (protos self)
        (self '_protos))
      (define-slot (slot-names self)
        (hash-table-map (self '_slots) (lambda (key value) key)))
      (define-slot (clone self)
        (let ((new (meta-object)))
          (new '_append-proto! self)
          (when (new 'get-slot 'init)
            (new 'init))
          new)))
    self))
(define-syntax define-method
  (syntax-rules ()
    ((_ class (name args ...) body ...)
     (class 'set-slot! 'name (lambda (args ...) body ...)))))
(define-method object (set-value! self name value)
  (self 'set-slot! name (lambda (self) value)))

ATM Teller Machine