slot-value to proto-slot-value, within all names.

[CommonLispStat.git] / src / objsys / lsobjects.lsp

;;; -*- mode: lisp -*-
;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
;;; See COPYRIGHT file for any additional restrictions (BSD license).
;;; Since 1991, ANSI was finally finished.  Edited for ANSI Common Lisp. 

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                    LISP-STAT Object System
;;;;
;;;;
;;;; Simple CL implementation of the object system for Lisp-Stat (LSOS)
;;;; as described in Tierney (1990). 
;;;; 
;;;; Copyright (c) 1991--, by Luke Tierney. Permission is granted for
;;;; unrestricted use.
;;;;
;;;;
;;;; NOTES:
;;;;
;;;;    If your CL's handling of packages is compliant with CLtL, 2nd 
;;;;    Edition (like Macintosh CL version 2), add the feature :CLtL2
;;;;    before loading or compiling this code.
;;;;
;;;;    This implementation does not make use of CLOS. It can coexist
;;;;    with CLOS, but there are two name conflicts: slot-value and
;;;;    call-next-method. 
;;;;    FIXED-ME: SLOT-VALUE now becomes PROTO-SLOT-VALUE...
;;;;    These two symbols are shadowed in the LSOS
;;;;    package and must be shadowed in any package that uses LSOS.
;;;;    Evaluating the function (lsos::use-lsos) from a package after
;;;;    loading this code shadows these two symbols and does a
;;;;    use-package for LSOS.
;;;;
;;;;    The :compile-method method uses function-lambda-expression
;;;;    defined in CLtL, 2nd Edition. (This method is only needed if
;;;;    you want to force compilation of an interpreted method. It is
;;;;    not used by the compiler.)
;;;;
;;;;    The efficiency of this code could be improved by low level 
;;;;    coding of the dispatching functions send, call-method and
;;;;    call-next-method to avoid creating an argument list. Other
;;;;    efficiency improvements are possible as well, in particular 
;;;;    by good use of declarations. It may also be possible to build
;;;;    a more efficient implementation using the CLOS metaclass
;;;;    protocol.
;;;;
;;;;    There are a few minimal tools for experimenting with constraints
;;;;    in the code; they are marked by #+:constreinthooks. Sometime
;;;;    soon I hope to augment or replace these hooks with a CORAL-like
;;;;    constraint system (as used in GARNET).
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :lisp-stat-object-system)

(defun use-lsos ()
  "Formerly set up to import lisp-stat-object-system into current package."
  (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
  (use-package 'lisp-stat-object-system))

;;; Structure Implementation of Lisp-Stat Object System

;; We might consider a global rewrite if it doesn't seem to break
;; anything.  In particular, the real name ought to be
;; proto-sys-object or similar so that we can ensure that the right
;; interpretation is made for this.   Call it the prototype object
;; system, and possibly be done with it then.

(defvar *object-serial* 0)

(defstruct (ls-object
             (:constructor make-object-structure) ;; why not make-ls-object? 
             (:print-function print-object-structure)
             (:predicate objectp))  ;; why not ls-object-p?
  slots
  methods 
  parents 
  preclist ;; precedence list
  (serial (incf *object-serial*)))

(defun print-object-structure (object stream depth)
  (declare (ignore depth))
  (send object :print stream))
;;; The following is probably more useful than the above...
(defmethod print-object ((object ls-object) stream)
  (send object :print stream))

(setf (documentation 'objectp 'function)
      "Args: (x)
Returns T if X is an object, NIL otherwise.")

(defvar *object* (make-object-structure)
  "*object* is the global root object.")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                          Utilities
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; AJR:FIXME:Is this going to cause issues with
;;; concurrency/threading? 
;;; (need to appropriately handle interrupts).   Could change this to 
;;; a stack or list that could handle modifications and interrupts
;;; in-line.
(defvar *self* nil
  "special variable holding current value of SELF.
Assigned with current object being worked on.")

(defun get-self ()
  "Return object we are operating on, otherwise throw error."
  (if (not (objectp *self*))
      (error "Error: no method focused on."))
  *self*)

(defun has-duplicates (list)
  "predicate: takes a list, and returns true if duplicates.  
This should be simpler, right?"
  (do ((next list (rest next)))
      ((not (consp next)) nil)
    (if (member (first next) (rest next)) (return t))))

(defun assoc-eq (item alist)
  "Version of assoc using eq -- should be faster than regular assoc."
  (declare (inline car eq))
  (dolist (i alist)
    (if (eq (car i) item) (return i))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;               Predicates for Consistency Checking
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun check-non-nil-symbol (x)
  (unless (and x (symbolp x)) (error "bad symbol - ~s" x)))

(defun check-object (x)
  "Returns self if true, throws an error otherwise."
  (if (objectp x) x (error "bad object - ~s" x)))

(defun kind-of-p (x y)
  "Args: (x y)

Returns T if X and Y are objects and X inherits from Y, NIL otherwise."

  (if (and (objectp x) (objectp y))
      (if (member y (ls-object-preclist x)) t nil)
      nil))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                     Precedence List Functions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun find-SC (object)
  "find set of object and ancestors. (diff from this and find-S?)"
  (copy-list (ls-object-preclist (check-object object))))

(defun find-S (object)
  "find set of object and ancestors. (diff from this and find-SC?)"
  (do ((result nil)
       (parents (ls-object-parents object) (cdr parents)))
      ((not (consp parents)) 
       (delete-duplicates (cons object result)))
    (setf result (nconc (find-SC (first parents)) result))))

(defun find-RC (object)
  "find local precedence ordering."
  (let ((list (copy-list (ls-object-parents (check-object object)))))
    (do ((next list (rest next)))
        ((not (consp next)) list)
      (setf (first  next) (cons object (first next)))
      (setf object (rest (first next))))))

(defun find-R (S)
  "find partial precedence ordering."
  (do ((result nil)
       (S S (rest S)))
      ((not (consp S)) 
       (delete-duplicates result))
    (setf result (nconc result (find-RC (first S))))))

(defun has-predecessor (x R)
  "check if x has a predecessor according to R."
  (dolist (cell R nil)
    (if (and (consp cell) (eq x (rest cell))) (return t))))

(defun find-no-predecessor-list (S R)
  "find list of objects in S without predecessors, by R."
  (let ((result nil))
    (dolist (x S result)
      (unless (has-predecessor x R) (setf result (cons x result))))))

(defun child-position (x P)
"find the position of child, if any, of x in P, the list found so
far." 
  (let ((count 0))
    (declare (fixnum count))
    (dolist (next P -1)
      (if (member x (ls-object-parents next)) (return count))
      (incf count))))

(defun next-object (no-preds P)
"find the next object in the precedence list from objects with no
predecessor and current list."
  (cond
   ((not (consp no-preds)) nil)
   ((not (consp (rest no-preds))) (first no-preds))
   (t
    (let ((count -1)
          (result nil))
      (declare (fixnum count))
      (dolist (x no-preds result)
        (let ((tcount (child-position x P)))
          (declare (fixnum tcount))
          (when (> tcount count)
            (setf result x)
            (setf count tcount))))))))

(defun trim-S (x S)
  "Remove object x from S."
  (delete x S))

(defun trim-R (x R) 
  "Remove all pairs containing x from R. x is assumed to have no
predecessors, so only the first position is checked."
(delete x R :key #'first))

(defun precedence-list (object)
  "Calculate the object's precedence list."
  (do* ((S (find-S object))
        (R (find-R S))
        (P nil)
        (no-preds nil)
        (next nil))
       ((not (consp S)) P)
    (setf no-preds (find-no-predecessor-list S R))
    (setf next (next-object no-preds P))
    (if (null next) (error "inconsistent precedence order"))
    (setf P (nconc P (list next)))
    (setf S (trim-S next S))
    (setf R (trim-R next R))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                 Object Construction Functions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun calculate-preclist (object)
  "Return the precedence list for the object."
  (let ((parents (ls-object-parents (check-object object))))
    (if (not (consp parents)) (error "bad parent list - ~s" parents))
    (if (consp (rest parents)) 
        (precedence-list object)
        (let ((parent (check-object (first parents))))
          (cons object (ls-object-preclist parent))))))

(defun check-parents (parents)
  "Ensure valid parents: They must be null, object, or consp without duplicates."
  (cond
   ((or (null parents) (objectp parents)) parents)
   ((consp parents)
    (dolist (x parents) (check-object x))
    (if (has-duplicates parents)
        (error "parents may not contain duplicates")))
   (t (error "bad parents - ~s" parents))))

(defun make-basic-object (parents object)
  "Creates a basic object for the prototype system by ensuring that it
can be placed into the storage heirarchy.   
If object is not initialized, instantiate the structure.  
Place into parental structure.
If parents is null, use root *object*,
if parents is a single object, use it (encapsulate as list)
otherwise, use parents"

  (check-parents parents)
  
  (if (not (objectp object)) (setf object (make-object-structure)))

  (setf (ls-object-preclist object) (ls-object-preclist *object*))
  (setf (ls-object-parents object)
        (cond ((null parents) (list *object*))
              ((objectp parents) (list parents))
              (t parents)))
  (setf (ls-object-preclist object) (calculate-preclist object))
  
  object)

(defun make-object (&rest parents)
  "Args: (&rest parents)
Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is used." 
  (make-basic-object parents NIL))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                   Constraint Hook Functions
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(pushnew :constrainthooks *features*)

#+:constrainthooks
(progn
  (defvar *message-hook* nil)
  (defvar *set-slot-hook* nil)

  (defun check-constraint-hooks (object sym slot)
    (let ((hook (if slot *set-slot-hook* *message-hook*)))
      (if hook
          (if slot
              (let ((*set-slot-hook* nil))
                (funcall hook object sym))
              (let ((*message-hook* nil))
                (funcall hook object sym)))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                     Slot Access Functions
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-slot-entry (x y) (cons x y))
(defun slot-entry-p (x) (consp x))
(defun slot-entry-key (x) (first x))
(defun slot-entry-value (x) (rest x))
(defun set-slot-entry-value (x v) (setf (rest x) v))
(defsetf slot-entry-value set-slot-entry-value)

(defun find-own-slot (x slot)
  (if (objectp x) (assoc-eq slot (ls-object-slots x))))

(defun find-slot (x slot)
  (if (objectp x)
    (let ((preclist (ls-object-preclist x)))
      (dolist (object preclist)
        (let ((slot-entry (find-own-slot object slot)))
          (if slot-entry (return slot-entry)))))))

(defun add-slot (x slot value)
  (check-object x)
  (check-non-nil-symbol slot)
  (let ((slot-entry (find-own-slot x slot)))
    (if slot-entry 
      (setf (slot-entry-value slot-entry) value)
      (setf (ls-object-slots x)
            (cons (make-slot-entry slot value) (ls-object-slots x)))))
  nil)

(defun delete-slot (x slot)
  (check-object x)
  (setf (ls-object-slots x)
        (delete slot (ls-object-slots x) :key #'slot-entry-key)))

(defun get-proto-slot-value (x slot &optional no-err)  
  (check-object x)
  (let ((slot-entry (find-slot x slot)))
    (if (slot-entry-p slot-entry)
      (slot-entry-value slot-entry)
      (unless no-err (error "no slot named ~s in this object" slot)))))

(defun set-proto-slot-value (x slot value)
  (check-object x)
  (let ((slot-entry (find-own-slot x slot)))
    (cond
     ((slot-entry-p slot-entry)
      (set-slot-entry-value slot-entry value)
      #+:constrainthooks (check-constraint-hooks x slot t))
     (t
      (if (find-slot x slot) ;; either way we error...?
        (error "object does not own slot ~s" slot)
        (error "no slot named ~s in this object" slot))))))

;;; FIXME: THIS WAS EVIL -- renamed SLOT-VALUE to PROTO-SLOT-VALUE, so
;;; that we can do CLOS simultaneously.
(defun proto-slot-value (slot)
"Args: (slot)

Must be used in a method. Returns the value of current objects slot
named SLOT.
EVIL -- it conflicts with CLOS object slots."
  (get-proto-slot-value (get-self) slot))

(defun proto-slot-value-setf (slot value)
  (set-proto-slot-value (get-self) slot value))

(defsetf proto-slot-value proto-slot-value-setf)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                   Method Access Functions;
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun make-method-entry (x y) (cons x y))
(defun method-entry-p (x) (consp x))
(defun method-entry-key (x) (first x))
(defun method-entry-method (x) (rest x))
(defun set-method-entry-method (x v) (setf (rest x) v))
(defsetf method-entry-method set-method-entry-method)

(defun find-own-method (x selector)
  (if (objectp x) (assoc-eq selector (ls-object-methods x)))) ;; prev was assoc not assoc-eq

(defun find-lsos-method (x selector)
  (if (objectp x)
    (let ((preclist (ls-object-preclist x)))
      (dolist (object preclist)
        (let ((method-entry (find-own-method object selector)))
          (if method-entry (return method-entry)))))))

(defun add-lsos-method (x selector value)
  "x = object; selector = name of method; value = form computing the method."
  (check-object x)
  (check-non-nil-symbol selector)
  (let ((method-entry (find-own-method x selector)))
    (if method-entry 
      (setf (method-entry-method method-entry) value)
      (setf (ls-object-methods x)
            (cons (make-method-entry selector value) (ls-object-methods x)))))
  nil)

(defun delete-method (x selector)
  (check-object x)
  (setf (ls-object-methods x)
        (delete selector (ls-object-methods x) :key #'method-entry-key)))

(defun get-message-method (x selector &optional no-err)  
  (check-object x)
  (let ((method-entry (find-lsos-method x selector)))
    (if (method-entry-p method-entry)
      (method-entry-method method-entry)
      (unless no-err (error "no method for selector ~s" selector)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                   Message Sending Functions
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *current-preclist* nil)
(defvar *current-selector* nil)

(defun sendmsg (object selector preclist args)
  (let ((method-entry nil)
        (method nil))

    ;; look for the message in the precedence list
    (loop
      (setf method-entry (find-own-method (first preclist) selector))
      (if (or method-entry (not (consp preclist))) (return))
      (setf preclist (rest preclist)))
    (cond 
     ((null method-entry) (error "no method for selector ~s" selector))
     ((not (method-entry-p method-entry)) (error "bad method entry"))
     (t (setf method (method-entry-method method-entry))))
   
    ;; invoke the method
    (let ((*current-preclist* preclist)
          (*current-selector* selector)
          (*self* object))
      (multiple-value-prog1
        (apply method object args)
        #+:constrainthooks (check-constraint-hooks object selector nil)))))

;;;; built-in send function
(defun send (object selector &rest args)
"Args: (object selector &rest args)
Applies first method for SELECTOR found in OBJECT's precedence list to
OBJECT and ARGS."
  (sendmsg object selector (ls-object-preclist object) args))

;;;FIXME: Need to include a "setter" for "send".



;;;; call-next-method - call inherited version of current method
(defun call-next-method (&rest args)
"Args (&rest args)
Funcalls next method for current selector and precedence list. Can only be
used in a method."
  (sendmsg *self* *current-selector* (rest *current-preclist*) args))
         
(defun call-method (object selector &rest args)
"Args (object selector &rest args)
Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in 
a method.
Call method belonging to another object on current object."
  (sendmsg *self* selector (ls-object-preclist object) args))
  
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                  Object Documentation
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun find-documentation (x sym add)
  (if (objectp x)
    (let ((doc (find-own-slot x 'documentation)))
      (if (and (null doc) add) (add-slot x 'documentation nil))
      (if (slot-entry-p doc) (assoc sym (slot-entry-value doc))))))

(defun add-documentation (x sym value)
  (check-object x)
  (check-non-nil-symbol sym)
  (let ((doc-entry (find-documentation x sym t)))
    (cond
     ((not (null doc-entry))
      (setf (rest doc-entry) value))
     (t
      (set-proto-slot-value x 
                      'documentation
                      (cons (cons sym value)
                            (get-proto-slot-value x 'documentation))))))
  nil)

(defun get-documentation (x sym)
  (check-object x)
  (dolist (object (ls-object-preclist x))
    (let ((doc-entry (find-documentation object sym nil))) ;; FIXME: verify
      (if doc-entry (return (rest doc-entry))))))

;;;;
;;;;                         DEFMETH Macro
;;;;

(defmacro defmeth (object name arglist first &rest body)
  "Syntax: (defmeth object method-name lambda-list [doc] {form}*)
OBJECT must evaluate to an existing object. Installs a method for NAME in
the value of OBJECT and installs DOC in OBJECTS's documentation.
RETURNS: method-name."
  ;; (declare (ignorable self))  ;; compiler hint that it isn't always used.
  (if (and body (stringp first)) 
    `(progn ;; first=docstring + body
       (add-lsos-method ,object ,name
                 #'(lambda (self ,@arglist) (block ,name ,@body)))
       (add-documentation ,object ,name ,first)
       ,name)
    `(progn ;; first=code + body
       (add-lsos-method ,object ,name
                   #'(lambda (self ,@arglist) (block ,name ,first ,@body)))
       ,name)))

;;;
;;;             Prototype Construction
;;;

(defun find-instance-slots (x slots)
  (let ((result (nreverse (delete-duplicates (copy-list slots)))))
    (dolist (parent (ls-object-parents x) (nreverse result))
      (dolist (slot (get-proto-slot-value parent 'instance-slots))
        (pushnew slot result)))))

(defun get-initial-proto-slot-value (object slot)
  (let ((entry (find-slot object slot)))
    (if (slot-entry-p entry) (slot-entry-value entry))))

(defun make-prototype (object name ivars cvars doc set)
  (setf ivars (find-instance-slots object ivars))
  (add-slot object 'instance-slots ivars)
  (add-slot object 'proto-name name)
  (dolist (slot ivars)
    (add-slot object slot (get-initial-proto-slot-value object slot)))
  (dolist (slot cvars)
    (add-slot object slot nil))
    
  (if (and doc (stringp doc))
    (add-documentation object 'proto doc))
  (if set (setf (symbol-value name) object)))


(defmacro defproto (name &optional ivars cvars parents doc)
  "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
Makes a new object prototype with instantiated/set variables IVARS,
'class' variables CVARS (class or 'cleared'??)) and parents
PARENT. PARENT can be a single object or a list of objects. IVARS and
CVARS must be lists."
  (let ((obsym (gensym))
        (namesym (gensym))
        (parsym (gensym)))
    `(progn
       (let* ((,namesym ',name)
              (,parsym ,parents)
              (,obsym (make-basic-object (if (listp ,parsym) 
                                             ,parsym 
                                             (list ,parsym)) ;; should this be ,@parsym ? 
                                         nil)))
         (make-prototype ,obsym ,namesym ,ivars ,cvars ,doc t)
         ,namesym))))


;; Infrastructure for new defproto from Common-Lisp Cookbook!  Thanks!

;(defmacro odd-define (name buildargs)
;   `(progn (defun ,(build-symbol make-a- (:< name)) 
;                                 ,buildargs
;              (vector ,(length buildargs) ',name ,@buildargs))
;           (defun ,(build-symbol test-whether- (:< name)) (x)
;              (and (vectorp x) (eq (aref x 1) ',name))
;           (defun ,(build-symbol (:< name) -copy) (x) 
;              ...)
;           (defun ,(build-symbol (:< name) -deactivate) (x) 
;              ...))))

;(defmacro for (listspec exp)
;   (cond ((and (= (length listspec) 3)
;               (symbolp (car listspec))
;               (eq (cadr listspec) ':in))
;          `(mapcar (lambda (,(car listspec))
;                      ,exp)
;                   ,(caddr listspec)))
;         (t (error "Ill-formed: ~s" `(for ,listspec ,exp)))))

;(defmacro symstuff (l)
;   `(concatenate 'string
;      ,@(for (x :in l)
;           (cond ((stringp x)
;                  `',x)
;                 ((atom x)
;                  `',(format nil "~a" x))
;                 ((eq (car x) ':<)
;                  `(format nil "~a" ,(cadr x)))
;                 ((eq (car x) ':++)
;                  `(format nil "~a" (incf ,(cadr x))))
;                 (t
;                  `(format nil "~a" ,x))))))

;(defmacro build-symbol (&rest l)
;   (let ((p (find-if (lambda (x)
;                      (and (consp x)
;                           (eq (car x) ':package)))
;                     l)))
;     (cond (p
;           (setq l (remove p l))))
;     (let ((pkg (cond ((eq (cadr p) 'nil)
;                      nil)
;                     (t `(find-package ',(cadr p))))))
;       (cond (p
;             (cond (pkg
;                    `(values (intern ,(symstuff l) ,pkg)))
;                   (t
;                    `(make-symbol ,(symstuff l)))))
;            (t
;             `(values (intern ,(symstuff l))))))))

(defmacro defproto2 (name &optional ivars cvars parents doc)
  "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
Makes a new object prototype with instance variables IVARS, 'class'
variables CVARS and parents PARENT. PARENT can be a single object or
a list of objects. IVARS and CVARS must be lists."
  (if (boundp name)
      (error "can not rebind a prototype object yet")
      (let ((namesym (gensym))
            (obsym (gensym))
            (parsym (gensym)))
        `(progn 
          (let* ((,namesym ,name)
                 (,parsym ,parents)
                 (,obsym (make-basic-object
                         (if (listp ,parsym) 
                             ,parsym 
                             (list ,@parsym)) ;; should this be ,@parsym ? 
                         nil)))
            (make-prototype ,obsym ,name ,ivars ,cvars ,doc t)
            ,name)))))

;; recall: 
;; , => turn on evaluation again (not macro substitution)
;; ` => template comes (use , to undo template and restore eval
;; ' => regular quote (not special in this context), 'ted => (quote ted)


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                   Initialize the Root Object
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setf (ls-object-preclist *object*) (list *object*))
(add-slot *object* 'instance-slots nil)
(add-slot *object* 'proto-name '*object*)
(add-slot *object* 'documentation nil)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;;                       *OBJECT* Methods
;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth *object* :nop (&rest args)
"Method args: ()

Do a NOP.  Used to quiet compiler warnings."
  (format nil "NOP"))

(defmeth *object* :isnew (&rest args)
"Method args: (&rest args)
Checks ARGS for keyword arguments matching slots and uses them to
initialize slots."
  (if args
    (dolist (slot-entry (ls-object-slots self))
      (let* ((slot (slot-entry-key slot-entry))
             (key (intern (symbol-name slot) (find-package 'keyword)))
             (val (proto-slot-value slot))
             (new-val (getf args key val)))
        (unless (eq val new-val) (setf (proto-slot-value slot) new-val)))))
  self)

(defmeth *object* :has-slot (slot &key own)
"Method args: (slot &optional own)
Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
only checks the object; otherwise check the entire precedence list."
  (let ((entry (if own (find-own-slot self slot) (find-slot self slot))))
    (if entry t nil)))

(defmeth *object* :add-slot (slot &optional value)
"Method args: (slot &optional value)
Installs slot SLOT in object, if it does not already exist, and
sets its value to VLAUE."
  (add-slot self slot value)
  value)

(defmeth *object* :delete-slot (slot)
"Method args: (slot)
Deletes slot SLOT from object if it exists."
  (delete-slot self slot)
  nil)

(defmeth *object* :own-slots ()
"Method args: ()
Returns list of names of slots owned by object."
  (mapcar #'slot-entry-key (ls-object-slots self)))

(defmeth *object* :has-method (selector &key own)
"Method args: (selector &optional own)
Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
only checks the object; otherwise check the entire precedence list."
  (let ((entry (if own 
                 (find-own-method self selector) 
                 (find-lsos-method self selector))))
    (if entry t nil)))

(defmeth *object* :add-method (selector method)
"Method args: (selector method)
Installs METHOD for SELECTOR in object."
  (add-lsos-method self selector method)
  nil)

(defmeth *object* :delete-method (selector)
"Method args: (selector)
Deletes method for SELECTOR in object if it exists."
  (delete-method self selector)
  nil)

(defmeth *object* :get-method (selector)
"Method args: (selector)
Returns method for SELECTOR symbol from object's precedence list."
  (get-message-method self selector))

(defmeth *object* :own-methods ()
"Method args ()
Returns copy of selectors for methods owned by object."
  (mapcar #'method-entry-key (ls-object-methods self)))

(defmeth *object* :parents ()
"Method args: ()
Returns copy of parents list."
  (copy-list (ls-object-parents self)))

(defmeth *object* :precedence-list ()
"Method args: ()
Returns copy of the precedence list."
  (copy-list (ls-object-preclist self)))

(defmeth *object* :show (&optional (stream t))
"Method Args: ()
Prints object's internal data."
  (format stream "Slots = ~s~%" (ls-object-slots self))
  (format stream "Methods = ~s~%" (ls-object-methods self))
  (format stream "Parents = ~s~%" (ls-object-parents self))
  (format stream "Precedence List  = ~s~%" (ls-object-preclist self))
  nil)

(defmeth *object* :reparent (&rest parents)
"Method args: (&rest parents)
Changes precedence list to correspond to PARENTS. Does not change descendants."
  (make-basic-object parents self))

(defmeth *object* :make-prototype (name &optional ivars)
  (make-prototype self name ivars nil nil nil)
  self)

(defmeth *object* :internal-doc (sym &optional new)
"Method args (topic &optional value)
Retrieves or installs documentation for topic."
  (if new (add-documentation self sym new))
  (get-documentation self sym))

(defmeth *object* :new (&rest args)
"Method args: (&rest args)
Creates new object using self as prototype."
  (let* ((object (make-object self)))
    (if (proto-slot-value 'instance-slots)
        (dolist (s (proto-slot-value 'instance-slots))
                (send object :add-slot s (proto-slot-value s))))
    (apply #'send object :isnew args)
    object))

(defmeth *object* :retype (proto &rest args)
"Method args: (proto &rest args)
Changes object to inherit directly from prototype PROTO. PROTO
must be a prototype and SELF must not be one."
  (if (send self :has-slot 'instance-slots :own t) 
      (error "can't retype a prototype"))
  (if (not (send proto :has-slot 'instance-slots :own t))
      (error "not a prototype - ~a" proto))
  (send self :reparent proto)
  (dolist (s (send proto :proto-slot-value 'instance-slots))
    (send self :add-slot s (proto-slot-value s)))
  (apply #'send self :isnew args)
  self)

(defmeth *object* :print (&optional (stream *standard-output*))
"Method args: (&optional (stream *standard-output*))
Default object printing method."
  (cond
    ((send self :has-slot 'proto-name) 
     (format stream
             "#<Object: ~D, prototype = ~A>"
             (ls-object-serial self)
             (proto-slot-value 'proto-name)))
    (t (format stream "#<Object: ~D>" (ls-object-serial self)))))

(defmeth *object* :proto-slot-value (sym &optional (val nil set))
"Method args: (sym &optional val)

Sets and retrieves value of slot named SYM. Signals an error if slot
does not exist."
    (send self :nop)
    (if set (setf (proto-slot-value sym) val))
    (proto-slot-value sym))

(defmeth *object* :slot-names () 
"Method args: ()
Returns list of slots available to the object."
  (apply #'append 
         (mapcar #'(lambda (x) (send x :own-slots))
                 (send self :precedence-list))))

(defmeth *object* :method-selectors ()
"Method args: ()
Returns list of method selectors available to object."
  (apply #'append
         (mapcar #'(lambda (x) (send x :own-methods))
                 (send self :precedence-list))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;                      Object Help Methods
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defmeth *object* :doc-topics ()
"Method args: ()
Returns all topics with documentation for this object."
  (remove-duplicates 
   (mapcar #'car 
           (apply #'append 
                  (mapcar 
                   #'(lambda (x) 
                       (if (send x :has-slot 'documentation :own t)
                           (send x :proto-slot-value (quote documentation))))
                   (send self :precedence-list))))))

(defmeth *object* :documentation (topic &optional (val nil set))
"Method args: (topic &optional val)
Retrieves or sets object documentation for topic."
  (if set (send self :internal-doc topic val))
  (let ((val (dolist (i (send self :precedence-list))
                     (let ((val (send i :internal-doc topic))) 
                       (if val (return val))))))
    val))

(defmeth *object* :delete-documentation (topic)
"Method args: (topic)
Deletes object documentation for TOPIC."
  (setf (proto-slot-value 'documentation)
        ;;(remove :title nil :test #'(lambda (x y) (eql x (first y)))) ;; original
        (remove topic (send self :documentation) :test #'(lambda (x y) (eql x (first y))))) ;; AJR:PROBLEM?
  nil)

(defmeth *object* :help (&optional topic)
"Method args: (&optional topic)
Prints help message for TOPIC, or genreal help if TOPIC is NIL."
  (if topic 
      (let ((doc (send self :documentation topic)))
        (cond 
          (doc (princ topic) (terpri) (princ doc) (terpri))
          (t (format t "Sorry, no help available on ~a~%" topic))))
      (let ((topics (stable-sort (copy-seq (send self :doc-topics))
                                 #'(lambda (x y)
                                     (string-lessp (string x) (string y)))))
            (proto-doc (send self :documentation 'proto)))
        (if (send self :has-slot 'proto-name)
            (format t "~s~%" (proto-slot-value 'proto-name)))
        (when proto-doc (princ proto-doc) (terpri))
        (format t "Help is available on the following:~%~%")
        (dolist (i topics) (format t "~s " i))
        (terpri)))
  (values))

(defmeth *object* :compile-method (name)
"Method args: (name)
Compiles method NAME unless it is already compiled. The object must
own the method."
  (unless (send self :has-method name)
          (error "No ~s method in this object" name))
  (unless (send self :has-method name :own t)
          (error "Object does not own ~s method" name))
  (let ((fun (send self :get-method name)))
    (unless (compiled-function-p fun)
            (multiple-value-bind (form env) (function-lambda-expression fun)
                 (if env 
                     (error 
                      "method may have been defined in non-null environment"))
                 (send self :add-method name (compile nil form))))))