module/slib/object.scm

   1 ;;; "object.scm" Macroless Object System
   2 ;;;From: whumeniu@datap.ca (Wade Humeniuk)
   3
   4 ;;;Date:  February 15, 1994
   5
   6 ;; Object Construction:
   7 ;;       0           1          2             3              4
   8 ;; #(object-tag get-method make-method! unmake-method! get-all-methods)
   9
  10 (define object:tag "object")
  11
  12 ;;; This might be better done using COMLIST:DELETE-IF.
  13 (define (object:removeq obj alist)
  14   (if (null? alist)
  15       alist
  16       (if (eq? (caar alist) obj)
  17           (cdr alist)
  18           (cons (car alist) (object:removeq obj (cdr alist))))))
  19
  20 (define (get-all-methods obj)
  21   (if (object? obj)
  22       ((vector-ref obj 4))
  23       (slib:error "Cannot get methods on non-object: " obj)))
  24
  25 (define (object? obj)
  26   (and (vector? obj)
  27        (eq? object:tag (vector-ref obj 0))))
  28
  29 (define (make-method! obj generic-method method)
  30   (if (object? obj)
  31       (if (procedure? method)
  32           (begin
  33             ((vector-ref obj 2) generic-method method)
  34             method)
  35           (slib:error "Method must be a procedure: " method))
  36       (slib:error "Cannot make method on non-object: " obj)))
  37
  38 (define (get-method obj generic-method)
  39   (if (object? obj)
  40       ((vector-ref obj 1) generic-method)
  41       (slib:error "Cannot get method on non-object: " obj)))
  42
  43 (define (unmake-method! obj generic-method)
  44   (if (object? obj)
  45       ((vector-ref obj 3) generic-method)
  46       (slib:error "Cannot unmake method on non-object: " obj)))
  47
  48 (define (make-predicate! obj generic-predicate)
  49   (if (object? obj)
  50       ((vector-ref obj 2) generic-predicate (lambda (self) #t))
  51       (slib:error "Cannot make predicate on non-object: " obj)))
  52
  53 (define (make-generic-method . exception-procedure)
  54   (define generic-method
  55     (lambda (obj . operands)
  56       (if (object? obj)
  57           (let ((object-method ((vector-ref obj 1) generic-method)))
  58             (if object-method
  59                 (apply object-method (cons obj operands))
  60                 (slib:error "Method not supported: " obj)))
  61           (apply exception-procedure (cons obj operands)))))
  62
  63   (if (not (null? exception-procedure))
  64       (if (procedure? (car exception-procedure))
  65           (set! exception-procedure (car exception-procedure))
  66           (slib:error "Exception Handler Not Procedure:"))
  67       (set! exception-procedure
  68             (lambda (obj . params)
  69               (slib:error "Operation not supported: " obj))))
  70   generic-method)
  71
  72 (define (make-generic-predicate)
  73   (define generic-predicate
  74     (lambda (obj)
  75       (if (object? obj)
  76           (if ((vector-ref obj 1) generic-predicate)
  77               #t
  78               #f)
  79           #f)))
  80   generic-predicate)
  81
  82 (define (make-object . ancestors)
  83   (define method-list
  84     (apply append (map (lambda (obj) (get-all-methods obj)) ancestors)))
  85   (define (make-method! generic-method method)
  86     (set! method-list (cons (cons generic-method method) method-list))
  87     method)
  88   (define (unmake-method! generic-method)
  89     (set! method-list (object:removeq generic-method method-list))
  90     #t)
  91   (define (all-methods) method-list)
  92   (define (get-method generic-method)
  93     (let ((method-def (assq generic-method method-list)))
  94       (if method-def (cdr method-def) #f)))
  95   (vector object:tag get-method make-method! unmake-method! all-methods))
  96
  97