From c6e575eb58e84224970d52186d280cc0a5e24e3e Mon Sep 17 00:00:00 2001
From: AJ Rossini <blindglobe@gmail.com>
Date: Wed, 12 Dec 2007 17:02:20 +0100
Subject: [PATCH] more name changes, initial class

---
 lsobjects.lsp | 45 +++++++++++++++++++++++++--------------------
 1 file changed, 25 insertions(+), 20 deletions(-)

diff --git a/lsobjects.lsp b/lsobjects.lsp
index 1276aeb..d4c87e1 100644
--- a/lsobjects.lsp
+++ b/lsobjects.lsp
@@ -63,7 +63,7 @@
 (defpackage :lisp-stat-object-system
  (:nicknames :ls-objects :lsos :proto-objects)
  (:use :common-lisp)
- (:export proto-object proto-objectp *proto-object*
+ (:export proto-object proto-object-p *proto-object*
 	  kind-of-p make-proto-object *message-hook*
 	  *set-slot-hook* proto-slot-value self send
 	  call-next-proto-method call-proto-method
@@ -73,30 +73,35 @@
 (in-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.
+;;; (prototype object system).
 
 (defvar *proto-object-serial* 0)
 
 (defstruct (proto-object
 	     (:constructor make-proto-object-structure)
 	     (:print-function print-proto-object-structure)
-	     (:predicate proto-objectp))  ;; why not ls-object-p?
+	     ;;(:predicate proto-object-p)
+	     )
   slots
   methods 
   parents 
   preclist ;; precedence list
   (serial (incf *proto-object-serial*)))
 
+(defclass proto-object
+    ((slots )
+     (methods ) 
+     (parents  )
+     (preclist  );; precedence list
+     (serial (incf *proto-object-serial*)))
+  )
+
+
 (defun print-proto-object-structure (object stream depth)
   (declare (ignore depth))
   (send object :print stream))
 
-(setf (documentation 'proto-objectp 'function)
+(setf (documentation 'proto-object-p 'function)
       "Args: (x)
 Returns T if X is an object, NIL otherwise.")
 
@@ -118,7 +123,7 @@ Assign to current object that we are working with.")
 
 (defun get-self ()
   "FIXME?  better as macro?."
-  (if (not (proto-objectp *self*))
+  (if (not (proto-object-p *self*))
       (error "not in a method"))
   *self*)
 
@@ -146,12 +151,12 @@ This should be simpler, right?"
 
 (defun check-object (x)
   "Returns self if true, throws an error otherwise."
-  (if (proto-objectp x) x (error "bad object - ~s" x)))
+  (if (proto-object-p 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 (proto-objectp x) (proto-objectp y))
+  (if (and (proto-object-p x) (proto-object-p y))
       (if (member y (proto-object-preclist x)) t nil)
       nil))
 
@@ -268,7 +273,7 @@ predecessors, so only the first position is checked."
 (defun check-parents (parents)
   "Ensure valid parents: They must be null, object, or consp without duplicates."
   (cond
-   ((or (null parents) (proto-objectp parents)) parents)
+   ((or (null parents) (proto-object-p parents)) parents)
    ((consp parents)
     (dolist (parent parents) (check-object parent))
     (if (has-duplicates parents)
@@ -286,12 +291,12 @@ otherwise, use parents"
 
   (check-parents parents)
   
-  (if (not (proto-objectp object)) (setf object (make-proto-object-structure)))
+  (if (not (proto-object-p object)) (setf object (make-proto-object-structure)))
 
   (setf (proto-object-preclist object) (proto-object-preclist *proto-object*))
   (setf (proto-object-parents object)
         (cond ((null parents) (list *proto-object*))
-              ((proto-objectp parents) (list parents))
+              ((proto-object-p parents) (list parents))
               (t parents)))
   (setf (proto-object-preclist object) (calculate-preclist object))
   
@@ -339,10 +344,10 @@ Returns a new object with parents PARENTS. If PARENTS is NIL,
 (defsetf slot-entry-value set-slot-entry-value)
 
 (defun find-own-slot (x slot)
-  (if (proto-objectp x) (assoc-eq slot (proto-object-slots x))))
+  (if (proto-object-p x) (assoc-eq slot (proto-object-slots x))))
 
 (defun find-slot (x slot)
-  (if (proto-objectp x)
+  (if (proto-object-p x)
     (let ((preclist (proto-object-preclist x)))
       (dolist (object preclist)
         (let ((slot-entry (find-own-slot object slot)))
@@ -407,10 +412,10 @@ named SLOT."
 (defsetf method-entry-method set-method-entry-method)
 
 (defun find-own-method (x selector)
-  (if (proto-objectp x) (assoc-eq selector (proto-object-methods x)))) ;; prev was assoc not assoc-eq
+  (if (proto-object-p x) (assoc-eq selector (proto-object-methods x)))) ;; prev was assoc not assoc-eq
 
 (defun find-lsos-method (x selector)
-  (if (proto-objectp x)
+  (if (proto-object-p x)
     (let ((preclist (proto-object-preclist x)))
       (dolist (object preclist)
         (let ((method-entry (find-own-method object selector)))
@@ -498,7 +503,7 @@ Call method belonging to another object on current object."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (defun find-documentation (x sym add)
-  (if (proto-objectp x)
+  (if (proto-object-p 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))))))
-- 
2.11.4.GIT