; *** ob ***
; from Paul Graham "ansi common lisp"
; change log:
; - "class" changed to "klass" (due to a SBCL name collision problem)
; - "slots" changed to "zlot" (due to a SBCL name collision problem)
; low-level tricks

(setf *print-array* nil)
(declaim (inline lookup (setf lookup)))
(declaim (inline run-methods))

; layout
(defmacro parents  (v) `(svref ,v 0))
(defmacro layout   (v) `(the simple-vector (svref ,v 1)))
(defmacro preclist (v) `(svref ,v 2))

(defmacro defprop (name &optional meth?)
  `(progn
     ,(if meth?
	  `(defun ,name (obj &rest args)
	     (run-methods obj ',name args))
	  `(defun ,name (obj &rest args)
	     (declare (ignore args)) ;tjm: we ignore args for non-methods
	     (rget ',name obj nil)))
     (defun (setf ,name) (val obj)
       (setf (lookup ',name obj) val))))
 
(defun run-methods (obj name args)
  (let ((meth (rget name obj nil)))
    (if (not (eq meth :nil))
        (apply meth obj args)
        (error "No ~A method for ~A." name obj))))

(defmacro klass (&optional parents &rest props)
  `(prog1 
       (klass-fn (list ,@parents) ',props)
     ,@(mapcar ; tjm everything is a property
	#'(lambda (x) `(defprop ,x)) props))) 

(defun klass-fn (parents props)
  (let* ((all (union (inherit-props parents) props))
         (obj (make-array (+ (length all) 3)
                          :initial-element :nil)))
    (setf (parents obj)  parents
          (layout obj)   (coerce all 'simple-vector)
          (preclist obj) (precedence obj))
    obj))

(defun inherit-props (klasses)
  (delete-duplicates
   (mapcan #'(lambda (c)
	       (nconc (coerce (layout c) 'list)
		      (inherit-props (parents c))))
	   klasses)))

(defun precedence (obj)
  (labels ((traverse (x)
             (cons x
                   (mapcan #'traverse (parents x)))))
    (delete-duplicates (traverse obj))))

(defun rget (prop obj next?)
  (let ((prec (preclist obj)))
    (if prec
        (dolist (c (if next? (cdr prec) prec) :nil)
          (let ((val (lookup prop c)))
            (unless (eq val :nil) (return val))))
        (let ((val (lookup prop obj)))
          (if (eq val :nil)
              (rget prop (parents obj) nil)
              val)))))

(defun lookup (prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off (svref obj (+ off 3)) :nil)))
 
(defun (setf lookup) (val prop obj)
  (let ((off (position prop (layout obj) :test #'eq)))
    (if off
        (setf (svref obj (+ off 3)) val)
        (error "Can't set ~A of ~A." val obj))))
 
(defmacro defmeth (name obj parms &rest body)
  (let ((gobj (gensym))
	(inst (gensym)))
    `(let ((,gobj ,obj))
       (defprop ,name t)
       (setf (lookup ',name ,gobj)
             (labels ((next (,inst) ;tjm simple way to call "next"
			(funcall (rget ',name ,gobj  t) ,inst)))
               #'(lambda ,parms ,@body))))))

(defun inst0 (parent)
  (let ((obj (copy-seq parent)))
    (setf (parents obj)  parent 
          (preclist obj) nil)
    (fill obj :nil :start 3)
    obj))