From 4b47ea7adfd137cdf03e7d02ffbabf30ac59d202 Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Mon, 31 Dec 2007 18:27:48 +0100 Subject: [PATCH] Moving Proto to CLOS structure to simplify some of the dispatch. Partial fix. --- lsobjects.lsp | 142 +++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 87 insertions(+), 55 deletions(-) diff --git a/lsobjects.lsp b/lsobjects.lsp index d4c87e1..ff7f45e 100644 --- a/lsobjects.lsp +++ b/lsobjects.lsp @@ -77,49 +77,82 @@ (defvar *proto-object-serial* 0) -(defstruct (proto-object - (:constructor make-proto-object-structure) - (:print-function print-proto-object-structure) - ;;(: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)) +;; (defstruct (proto-object +;; (:constructor make-proto-object-structure) +;; (:print-function print-proto-object-structure) +;; (:predicate proto-object-p) +;; ) +;; slots +;; methods +;; parents +;; preclist precedence list +;; (serial (incf *proto-object-serial*))) + +(defclass proto-object () + ((slots + :initform (list) + :type list + :accessor proto-object-slots + ) + (methods + :initform (list) + :type list + :accessor proto-object-methods + ) + (parents + :initform (list) + :type list + :accessor proto-object-parents + ) + (preclist ;; precedence list + :initform (list) + :type list + :accessor proto-object-preclist + :documentation "precedence list." + ) + (serial + :initform (incf *proto-object-serial*) + :type integer + :documentation "Similar idea to serial number." + ) + (self2 + :initform nil + :accessor proto-self + :documentation "can we embed the global within the class structure?" + ) + )) + +;; We denote default-ish proto-object variable names by po or po?. + +(defvar *proto-object* (make-instance 'proto-object) + "*proto-object* is the global root object.") -(setf (documentation 'proto-object-p 'function) +(defun proto-object-p (x) "Args: (x) -Returns T if X is an object, NIL otherwise.") +Returns T if X is an object, NIL otherwise. Do we really need this?" + (typep x 'proto-object)) -(defvar *proto-object* (make-proto-object-structure) - "*proto-object* is the global root object.") +(defun print-proto-object-structure (po stream depth) + (declare (ignore depth)) + (send po :print stream)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; Utilities -;;;; +;;; +;;; Utilities +;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; + ;;; AJR:FIXME:Is this going to cause issues with concurrency/threading? ;;; (need to appropriately handle interrupts). (defvar *self* nil "special variable to hold current value of SELF. -Assign to current object that we are working with.") +Assign to current object that we are working with. Local to proto package. +Currently working to embed within the object structure rather than a global.") + +;; The waz that self works is that we try to make sure that we set +;; *self* upon message entry and unset at message exit. This is a +;; good strategy provided that concurrency is not in play. (defun get-self () "FIXME? better as macro?." @@ -149,15 +182,15 @@ This should be simpler, right?" (defun check-non-nil-symbol (x) (unless (and x (symbolp x)) (error "bad symbol - ~s" x))) -(defun check-object (x) +(defun check-object (po) "Returns self if true, throws an error otherwise." - (if (proto-object-p x) x (error "bad object - ~s" x))) + (if (proto-object-p po) po (error "bad object - ~s" x))) -(defun kind-of-p (x y) +(defun kind-of-p (pox poy) "Args: (x y) Returns T if X and Y are objects and X inherits from Y, NIL otherwise." - (if (and (proto-object-p x) (proto-object-p y)) - (if (member y (proto-object-preclist x)) t nil) + (if (and (proto-object-p pox) (proto-object-p poy)) + (if (member poy (proto-object-preclist pox)) t nil) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -166,16 +199,16 @@ Returns T if X and Y are objects and X inherits from Y, NIL otherwise." ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun find-SC (object) - "find set of object and ancestors. (diff from this and find-S?)" - (copy-list (proto-object-preclist (check-object object)))) +(defun find-SC (po) + "Return a copy of the complete precedence list for po." + (copy-list (proto-object-preclist (check-object po)))) -(defun find-S (object) - "find set of object and ancestors. (diff from this and find-SC?)" +(defun find-S (po) + "return a reverse-sorted, duplicate-free list of parent objects." (do ((result nil) - (parents (proto-object-parents object) (cdr parents))) + (parents (proto-object-parents (check-object po)) (cdr parents))) ((not (consp parents)) - (delete-duplicates (cons object result))) + (delete-duplicates (cons po result))) (setf result (nconc (find-SC (first parents)) result)))) (defun find-RC (object) @@ -238,7 +271,7 @@ predecessor and current list." (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)) + (delete x R :key #'first)) (defun precedence-list (object) "Calculate the object's precedence list." @@ -256,9 +289,9 @@ predecessors, so only the first position is checked." (setf R (trim-R next R)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;; -;;;; Object Construction Functions -;;;; +;;; +;;; Object Construction Functions +;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun calculate-preclist (object) @@ -290,16 +323,15 @@ if parents is a single object, use it (encapsulate as list) otherwise, use parents" (check-parents parents) - - (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) + (if (not (proto-object-p object)) + (setf object (make-instance + 'proto-object + :preclist (proto-object-preclist *proto-object*) + :parents (cond ((null parents) (list *proto-object*)) ((proto-object-p parents) (list parents)) - (t parents))) + (t parents))))) (setf (proto-object-preclist object) (calculate-preclist object)) - object) (defun make-object (&rest parents) -- 2.11.4.GIT