From 20952ae41bbec7114818064f739a90c0df36f5a5 Mon Sep 17 00:00:00 2001 From: AJ Rossini Date: Sat, 8 Dec 2007 18:08:38 +0100 Subject: [PATCH] Making the prototype system generic. --- lsobjects.lsp | 217 ++++++++++++++++++++++++++++++---------------------------- 1 file changed, 111 insertions(+), 106 deletions(-) diff --git a/lsobjects.lsp b/lsobjects.lsp index 442d9af..c4ede65 100644 --- a/lsobjects.lsp +++ b/lsobjects.lsp @@ -60,7 +60,8 @@ (:nicknames :ls-objects :lsos) (:use :common-lisp) (:shadow :call-method :call-next-method :slot-value) - (:export ls-object objectp *object* kind-of-p make-object *message-hook* + (:export proto-object proto-objectp *proto-object* + kind-of-p make-proto-object *message-hook* *set-slot-hook* slot-value self send call-next-method call-method defmeth defproto defproto2 instance-slots proto-name)) @@ -80,28 +81,28 @@ ;; interpretation is made for this. Call it the prototype object ;; system, and possibly be done with it then. -(defvar *object-serial* 0) +(defvar *proto-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? +(defstruct (proto-object + (:constructor make-proto-object-structure) + (:print-function print-proto-object-structure) + (:predicate proto-objectp)) ;; why not ls-object-p? slots methods parents preclist ;; precedence list - (serial (incf *object-serial*))) + (serial (incf *proto-object-serial*))) -(defun print-object-structure (object stream depth) +(defun print-proto-object-structure (object stream depth) (declare (ignore depth)) (send object :print stream)) -(setf (documentation 'objectp 'function) +(setf (documentation 'proto-objectp 'function) "Args: (x) Returns T if X is an object, NIL otherwise.") -(defvar *object* (make-object-structure) - "*object* is the global root object.") +(defvar *proto-object* (make-proto-object-structure) + "*proto-object* is the global root object.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; @@ -118,7 +119,7 @@ Assign to current object that we are working with.") (defun get-self () "FIXME? better as macro?." - (if (not (objectp *self*)) + (if (not (proto-objectp *self*)) (error "not in a method")) *self*) @@ -146,13 +147,13 @@ This should be simpler, right?" (defun check-object (x) "Returns self if true, throws an error otherwise." - (if (objectp x) x (error "bad object - ~s" x))) + (if (proto-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) + (if (and (proto-objectp x) (proto-objectp y)) + (if (member y (proto-object-preclist x)) t nil) nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -163,19 +164,19 @@ 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 (ls-object-preclist (check-object object)))) + (copy-list (proto-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))) + (parents (proto-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))))) + (let ((list (copy-list (proto-object-parents (check-object object))))) (do ((next list (rest next))) ((not (consp next)) list) (setf (first next) (cons object (first next))) @@ -206,7 +207,7 @@ far." (let ((count 0)) (declare (fixnum count)) (dolist (next P -1) - (if (member x (ls-object-parents next)) (return count)) + (if (member x (proto-object-parents next)) (return count)) (incf count)))) (defun next-object (no-preds P) @@ -258,19 +259,19 @@ predecessors, so only the first position is checked." (defun calculate-preclist (object) "Return the precedence list for the object." - (let ((parents (ls-object-parents (check-object object)))) + (let ((parents (proto-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)))))) + (cons object (proto-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) + ((or (null parents) (proto-objectp parents)) parents) ((consp parents) - (dolist (x parents) (check-object x)) + (dolist (parent parents) (check-object parent)) (if (has-duplicates parents) (error "parents may not contain duplicates"))) (t (error "bad parents - ~s" parents)))) @@ -286,20 +287,21 @@ otherwise, use parents" (check-parents parents) - (if (not (objectp object)) (setf object (make-object-structure))) + (if (not (proto-objectp object)) (setf object (make-proto-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)) + (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)) (t parents))) - (setf (ls-object-preclist object) (calculate-preclist object)) + (setf (proto-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." +Returns a new object with parents PARENTS. If PARENTS is NIL, +(list *PROTO-OBJECT*) is used." (make-basic-object parents NIL)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -338,11 +340,11 @@ Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is (defsetf slot-entry-value set-slot-entry-value) (defun find-own-slot (x slot) - (if (objectp x) (assoc-eq slot (ls-object-slots x)))) + (if (proto-objectp x) (assoc-eq slot (proto-object-slots x)))) (defun find-slot (x slot) - (if (objectp x) - (let ((preclist (ls-object-preclist x))) + (if (proto-objectp x) + (let ((preclist (proto-object-preclist x))) (dolist (object preclist) (let ((slot-entry (find-own-slot object slot))) (if slot-entry (return slot-entry))))))) @@ -353,14 +355,14 @@ Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is (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))))) + (setf (proto-object-slots x) + (cons (make-slot-entry slot value) (proto-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))) + (setf (proto-object-slots x) + (delete slot (proto-object-slots x) :key #'slot-entry-key))) (defun get-slot-value (x slot &optional no-err) (check-object x) @@ -406,11 +408,11 @@ named SLOT." (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 + (if (proto-objectp x) (assoc-eq selector (proto-object-methods x)))) ;; prev was assoc not assoc-eq (defun find-lsos-method (x selector) - (if (objectp x) - (let ((preclist (ls-object-preclist x))) + (if (proto-objectp x) + (let ((preclist (proto-object-preclist x))) (dolist (object preclist) (let ((method-entry (find-own-method object selector))) (if method-entry (return method-entry))))))) @@ -422,14 +424,14 @@ named SLOT." (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))))) + (setf (proto-object-methods x) + (cons (make-method-entry selector value) (proto-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))) + (setf (proto-object-methods x) + (delete selector (proto-object-methods x) :key #'method-entry-key))) (defun get-message-method (x selector &optional no-err) (check-object x) @@ -474,7 +476,7 @@ named SLOT." "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)) + (sendmsg object selector (proto-object-preclist object) args)) ;;;; call-next-method - call inherited version of current method (defun call-next-method (&rest args) @@ -488,7 +490,7 @@ used in a method." 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)) + (sendmsg *self* selector (proto-object-preclist object) args)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -497,7 +499,7 @@ Call method belonging to another object on current object." ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun find-documentation (x sym add) - (if (objectp x) + (if (proto-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)))))) @@ -518,7 +520,7 @@ Call method belonging to another object on current object." (defun get-documentation (x sym) (check-object x) - (dolist (object (ls-object-preclist x)) + (dolist (object (proto-object-preclist x)) (let ((doc-entry (find-documentation object sym nil))) ;; FIXME: verify (if doc-entry (return (rest doc-entry)))))) @@ -553,7 +555,7 @@ RETURNS: method-name." (defun find-instance-slots (x slots) (let ((result (nreverse (delete-duplicates (copy-list slots))))) - (dolist (parent (ls-object-parents x) (nreverse result)) + (dolist (parent (proto-object-parents x) (nreverse result)) (dolist (slot (get-slot-value parent 'instance-slots)) (pushnew slot result))))) @@ -576,7 +578,7 @@ RETURNS: method-name." (defmacro defproto (name &optional ivars cvars parents doc) -"Syntax (defproto name &optional ivars cvars (parent *object*) doc) +"Syntax (defproto name &optional ivars cvars (parent *proto-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." @@ -648,27 +650,30 @@ a list of objects. IVARS and CVARS must be lists." ; (t ; `(values (intern ,(symstuff l)))))))) -(defmacro defproto2 (name &optional ivars cvars parents doc) - "Syntax (defproto name &optional ivars cvars (parent *object*) doc) +(defmacro defproto2 (name &optional ivars cvars parents doc force) + "Syntax (defproto name &optional ivars cvars (parent *proto-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)) +a list of objects. IVARS and CVARS must be lists. DOC should be a +string." + (if (and (boundp name) + (not force)) + (error "Force T to rebind a prototype object.") + (let ((obsym (gensym)) (parsym (gensym))) `(progn - (let* ((,namesym ,name) - (,parsym ,parents) + (defvar ,name (list) ,doc) + (let* ((,parsym ,parents) (,obsym (make-basic-object - (if (listp ,parsym) - ,parsym - (list ,@parsym)) ;; should this be ,@parsym ? - nil))) + (if (listp ,parsym) + ,parsym + (list ,@parsym)) ;; should this be ,@parsym ? + nil))) (make-prototype ,obsym ,name ,ivars ,cvars ,doc t) ,name))))) +;; (macro-expand-1 (defproto2 *mytest*)) + ;; recall: ;; , => turn on evaluation again (not macro substitution) ;; ` => template comes (use , to undo template and restore eval @@ -681,25 +686,25 @@ a list of objects. IVARS and CVARS must be lists." ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(setf (ls-object-preclist *object*) (list *object*)) -(add-slot *object* 'instance-slots nil) -(add-slot *object* 'proto-name '*object*) -(add-slot *object* 'documentation nil) ; AJR - for SBCL compiler +(setf (proto-object-preclist *proto-object*) (list *proto-object*)) +(add-slot *proto-object* 'instance-slots nil) +(add-slot *proto-object* 'proto-name '*proto-object*) +(add-slot *proto-object* 'documentation nil) ; AJR - for SBCL compiler ; issues about macro with ; unknown slot ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; *OBJECT* Methods +;;; *PROTO-OBJECT* Methods ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmeth *object* :isnew (&rest args) +(defmeth *proto-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)) + (dolist (slot-entry (proto-object-slots self)) (let* ((slot (slot-entry-key slot-entry)) (key (intern (symbol-name slot) (find-package 'keyword))) (val (slot-value slot)) @@ -707,32 +712,32 @@ initialize slots." (unless (eq val new-val) (setf (slot-value slot) new-val))))) self) -(defmeth *object* :has-slot (slot &key own) +(defmeth *proto-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) +(defmeth *proto-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) +(defmeth *proto-object* :delete-slot (slot) "Method args: (slot) Deletes slot SLOT from object if it exists." (delete-slot self slot) nil) -(defmeth *object* :own-slots () +(defmeth *proto-object* :own-slots () "Method args: () Returns list of names of slots owned by object." - (mapcar #'slot-entry-key (ls-object-slots self))) + (mapcar #'slot-entry-key (proto-object-slots self))) -(defmeth *object* :has-method (selector &key own) +(defmeth *proto-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." @@ -741,63 +746,63 @@ only checks the object; otherwise check the entire precedence list." (find-lsos-method self selector)))) (if entry t nil))) -(defmeth *object* :add-method (selector method) +(defmeth *proto-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) +(defmeth *proto-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) +(defmeth *proto-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 () +(defmeth *proto-object* :own-methods () "Method args () Returns copy of selectors for methods owned by object." - (mapcar #'method-entry-key (ls-object-methods self))) + (mapcar #'method-entry-key (proto-object-methods self))) -(defmeth *object* :parents () +(defmeth *proto-object* :parents () "Method args: () Returns copy of parents list." - (copy-list (ls-object-parents self))) + (copy-list (proto-object-parents self))) -(defmeth *object* :precedence-list () +(defmeth *proto-object* :precedence-list () "Method args: () Returns copy of the precedence list." - (copy-list (ls-object-preclist self))) + (copy-list (proto-object-preclist self))) -(defmeth *object* :show (&optional (stream t)) +(defmeth *proto-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)) + (format stream "Slots = ~s~%" (proto-object-slots self)) + (format stream "Methods = ~s~%" (proto-object-methods self)) + (format stream "Parents = ~s~%" (proto-object-parents self)) + (format stream "Precedence List = ~s~%" (proto-object-preclist self)) nil) -(defmeth *object* :reparent (&rest parents) +(defmeth *proto-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) +(defmeth *proto-object* :make-prototype (name &optional ivars) (make-prototype self name ivars nil nil nil) self) -(defmeth *object* :internal-doc (sym &optional new) +(defmeth *proto-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) +(defmeth *proto-object* :new (&rest args) "Method args: (&rest args) Creates new object using self as prototype." (let* ((object (make-object self))) @@ -807,7 +812,7 @@ Creates new object using self as prototype." (apply #'send object :isnew args) object)) -(defmeth *object* :retype (proto &rest args) +(defmeth *proto-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." @@ -821,32 +826,32 @@ must be a prototype and SELF must not be one." (apply #'send self :isnew args) self) -(defmeth *object* :print (&optional (stream *standard-output*)) +(defmeth *proto-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 "#" - (ls-object-serial self) + (proto-object-serial self) (slot-value 'proto-name))) - (t (format stream "#" (ls-object-serial self))))) + (t (format stream "#" (proto-object-serial self))))) -(defmeth *object* :slot-value (sym &optional (val nil set)) +(defmeth *proto-object* :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." (if set (setf (slot-value sym) val)) (slot-value sym)) -(defmeth *object* :slot-names () +(defmeth *proto-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 () +(defmeth *proto-object* :method-selectors () "Method args: () Returns list of method selectors available to object." (apply #'append @@ -860,7 +865,7 @@ Returns list of method selectors available to object." ;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmeth *object* :doc-topics () +(defmeth *proto-object* :doc-topics () "Method args: () Returns all topics with documentation for this object." (remove-duplicates @@ -872,7 +877,7 @@ Returns all topics with documentation for this object." (send x :slot-value (quote documentation)))) (send self :precedence-list)))))) -(defmeth *object* :documentation (topic &optional (val nil set)) +(defmeth *proto-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)) @@ -881,7 +886,7 @@ Retrieves or sets object documentation for topic." (if val (return val)))))) val)) -(defmeth *object* :delete-documentation (topic) +(defmeth *proto-object* :delete-documentation (topic) "Method args: (topic) Deletes object documentation for TOPIC." (setf (slot-value 'documentation) @@ -889,7 +894,7 @@ Deletes object documentation for TOPIC." (remove topic (send self :documentation) :test #'(lambda (x y) (eql x (first y))))) ;; AJR:PROBLEM? nil) -(defmeth *object* :help (&optional topic) +(defmeth *proto-object* :help (&optional topic) "Method args: (&optional topic) Prints help message for TOPIC, or genreal help if TOPIC is NIL." (if topic @@ -909,7 +914,7 @@ Prints help message for TOPIC, or genreal help if TOPIC is NIL." (terpri))) (values)) -(defmeth *object* :compile-method (name) +(defmeth *proto-object* :compile-method (name) "Method args: (name) Compiles method NAME unless it is already compiled. The object must own the method." -- 2.11.4.GIT