SMOS

smos.scm

;;;; smos.scm
;;;; Still Macroless Object System.
;;;; This code is still in the public domain.
;;;; No warrany. In fact, I guarantee that even looking at this code will break your shit, leaving you destitute and homeless.

;;;; 0.0.3
;;;; Define object? and make-object in a lexical scope containing object-tag as YASOS does.

;;;; 0.0.2
;;;; Broke out vector stuff, in case obj's structure changes later.
;;;; Somewhat YASOS-ify ancestor handling. Ancestors are now stored in a vector.
;;;; (make-method! self some-method (lambda (self) (operate-as self a-number-in-ancestors-vector some-other-method)))

;;;; 0.0.1
;;;; Initial copy of MOS.

;;;; Object Construction:
;;;;       0           1          2             3              4             5         6
;;;; #(object-tag get-method make-method! unmake-method! get-all-methods ancestors operate-as)

;;;; Original header: ----------------------------------------------------
;;; "object.scm" Macroless Object System
;;; Author: Wade Humeniuk <humeniuw@cadvision.com>
;;;
;;; This code is in the public domain.

;;;Date:  February 15, 1994

;; Object Construction:
;;       0           1          2             3              4
;; #(object-tag get-method make-method! unmake-method! get-all-methods)
;;;; ---------------------------------------------------------------------

(define (obj:tag obj)
  (vector-ref obj 0))
(define (obj:get-methods obj)
  (vector-ref obj 1))
(define (obj:make-method! obj)
  (vector-ref obj 2))
(define (obj:unmake-method! obj)
  (vector-ref obj 3))
(define (obj:get-all-methods obj)
  (vector-ref obj 4))
(define (obj:ancestors obj)
  (vector-ref obj 5))
(define (obj:operate-as obj)
  (vector-ref obj 6))

;; Clobbered in let below
(define object? #f)
(define make-object #f)

(let ((object-tag "object"))
  (define (is-obj? obj)
    (and (vector? obj)
         (eq? object-tag (obj:tag obj))))
  (define (local-make-object . ancestor-list)
    (define method-list (list))
    (define ancestors (list->vector (cons 'ancestors ancestor-list)))
    (define num-ancestors (length ancestor-list)) ; I can't seem to (vector-length ancestors) here.
    (define (operate-as obj-num method)
      (method (vector-ref ancestors obj-num)))
    (define (make-method! generic-method method)
      (set! method-list (cons (cons generic-method method) method-list))
      method)
    (define (unmake-method! generic-method)
      (set! method-list (object:removeq generic-method method-list))
      #t)
    (define (methods) method-list)
    (define (get-method generic-method)
      (let ((method-def (assq generic-method method-list)))
        (if method-def
            (cdr method-def)
            (let loop ((current-ancestor 1))
              (if (> current-ancestor num-ancestors)
                  #f
                  (let ((method-def ((obj:get-methods (vector-ref ancestors current-ancestor)) generic-method)))
                    (if method-def
                        method-def
                        (loop (+ 1 current-ancestor)))))))))
    (vector object-tag get-method make-method! unmake-method! methods ancestors operate-as))
  (set! object? is-obj?)
  (set! make-object local-make-object))

;;; This might be better done using COMLIST:DELETE-IF.
(define (object:removeq obj alist)
  (if (null? alist)
      alist
      (if (eq? (caar alist) obj)
          (cdr alist)
          (cons (car alist) (object:removeq obj (cdr alist))))))

(define (operate-as obj ancestor-number method)
  (if (object? obj)
      ((obj:operate-as obj) ancestor-number method)
      (error "Cannot access ancestors of non-object: " obj)))

(define (get-all-methods obj)
  (if (object? obj)
      (obj:get-all-methods obj)
      (error "Cannot get methods on non-object: " obj)))

(define (make-method! obj generic-method method)
  (if (object? obj)
      (if (procedure? method)
          (begin
            ((obj:make-method! obj) generic-method method)
            method)
          (error "Method must be a procedure: " method))
      (error "Cannot make method on non-object: " obj)))

(define (get-method obj generic-method)
  (if (object? obj)
      ((obj:get-methods obj) generic-method)
      (error "Cannot get method on non-object: " obj)))

(define (unmake-method! obj generic-method)
  (if (object? obj)
      ((obj:unmake-method! obj) generic-method)
      (error "Cannot unmake method on non-object: " obj)))

(define (make-predicate! obj generic-predicate)
  (if (object? obj)
      ((obj:make-method! obj) generic-predicate (lambda (self) #t))
      (error "Cannot make predicate on non-object: " obj)))

(define (make-generic-method . exception-procedure)
  (define generic-method
    (lambda (obj . operands)
      (if (object? obj)
          (let ((object-method ((obj:get-methods obj) generic-method)))
            (if object-method
                (apply object-method (cons obj operands))
                (error "Method not supported: " obj)))
          (apply exception-procedure (cons obj operands)))))

  (if (not (null? exception-procedure))
      (if (procedure? (car exception-procedure))
          (set! exception-procedure (car exception-procedure))
          (error "Exception Handler Not Procedure:"))
      (set! exception-procedure
            (lambda (obj . params)
              (error "Operation not supported: " obj))))
  generic-method)

(define (make-generic-predicate)
  (define generic-predicate
    (lambda (obj)
      (if (object? obj)
          (if ((obj:get-methods obj) generic-predicate)
              #t
              #f)
          #f)))
  generic-predicate)

;; Samples:

;; SMOS/MOS:
;;
;; > (define name (make-generic-method))
;; > (define job (make-generic-method))
;; > (define (person n)
;;     (define self (make-object))
;;     (make-method! self name (lambda (self) n))
;;     self)
;; > (map name (list (person 'bob) (person 'ashley) (person 'george)))
;; (bob ashley george)
;; > (define (worker n j)
;;     (define self (make-object (person n)))
;;     (make-method! self job (lambda (self) j))
;;     self)
;; > (map name (list (worker 'bob 'mechanic) (worker 'ashley 'pilot) (worker 'george 'loanshark)))
;; (bob ashley george)
;; > (map job (list (worker 'bob 'mechanic) (worker 'ashley 'pilot) (worker 'george 'loanshark)))
;; (mechanic pilot loanshark)
;; >

;; SMOS operate-as:
;;
;; > (define name (make-generic-method))
;; > (define is (make-generic-method))
;; > (define job (make-generic-method))
;; > (define really (make-generic-method))
;; >  (define (person n)
;;     (define self (make-object))
;;     (make-method! self name (lambda (self) n))
;;     (make-method! self is (lambda (self) 'person))
;;     self)
;; >  (define (employee n j)
;;     (define self (make-object (person n)))
;;     (make-method! self job (lambda (self) j))
;;     (make-method! self is (lambda (self) 'slave))
;;     (make-method! self really (lambda (self) (operate-as self 1 is)))
;;     self)
;; > (name (employee 'bob 'mechanic))
;; bob
;; > (is (employee 'bob 'mechanic))
;; slave
;; > (really (employee 'bob 'mechanic))
;; person