objects.scm

(import (scheme base)
        (scheme write))

(define *update-methods* (list '*update-methods*))

(define-record-type <method> (make-method predicate action) method?
  (predicate method-predicate)
  (action method-action))

(define (make-generic name)
  (let ((methods '()))
    (lambda args
      (if (and (pair? args) (eq? (car args) *update-methods*))
          (begin
            (set! methods ((cadr args) methods))
            methods)
        (apply-applicable-method name methods args)))))

(define (apply-applicable-method name methods args)
  (cond ((null? methods) (error "No applicable method" name args))
        ((apply (method-predicate (car methods)) args)
         (apply (method-action (car methods)) args))
        (else (apply-applicable-method name (cdr methods) args))))

(define (add-method! generic method)
  (generic *update-methods*
           (lambda (methods)
             (cons method methods))))

(define (get-methods generic)
  (generic *update-methods*
           (lambda (methods)
             methods)))

(define show (make-generic 'show))

(add-method! show (make-method
                   (lambda (x) (number? x))
                   (lambda (x) (display "I am number ") (display x) (newline))))

(add-method! show (make-method
                   (lambda (x) (string? x))
                   (lambda (x) (display "I am the string ") (write x) (newline))))