2 ;;; Copyright (c) 2005--2007, by A.J. Rossini <blindglobe@gmail.com>
3 ;;; See COPYRIGHT file for any additional restrictions (BSD license).
4 ;;; Since 1991, ANSI was finally finished. Edited for ANSI Common Lisp.
6 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
9 ;;;; LISP-STAT Object System
12 ;;;; Simple CL implementation of the object system for Lisp-Stat (LSOS)
13 ;;;; as described in Tierney (1990).
15 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
16 ;;;; unrestricted use.
21 ;;;; If your CL's handling of packages is compliant with CLtL, 2nd
22 ;;;; Edition (like Macintosh CL version 2), add the feature :CLtL2
23 ;;;; before loading or compiling this code.
25 ;;;; This implementation does not make use of CLOS. It can coexist
26 ;;;; with CLOS, but there are two name conflicts: slot-value and
27 ;;;; call-next-method. These two symbols are shadowed in the LSOS
28 ;;;; package and must be shadowed in any package that uses LSOS.
29 ;;;; Evaluating the function (lsos::use-lsos) from a package after
30 ;;;; loading this code shadows these two symbols and does a
31 ;;;; use-package for LSOS.
33 ;;;; The :compile-method method uses function-lambda-expression
34 ;;;; defined in CLtL, 2nd Edition. (This method is only needed if
35 ;;;; you want to force compilation of an interpreted method. It is
36 ;;;; not used by the compiler.)
38 ;;;; The efficiency of this code could be improved by low level
39 ;;;; coding of the dispatching functions send, call-method and
40 ;;;; call-next-method to avoid creating an argument list. Other
41 ;;;; efficiency improvements are possible as well, in particular
42 ;;;; by good use of declarations. It may also be possible to build
43 ;;;; a more efficient implementation using the CLOS metaclass
46 ;;;; There are a few minimal tools for experimenting with constraints
47 ;;;; in the code; they are marked by #+:constreinthooks. Sometime
48 ;;;; soon I hope to augment or replace these hooks with a CORAL-like
49 ;;;; constraint system (as used in GARNET).
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
58 (defpackage :lisp-stat-object-system
59 (:nicknames
:ls-objects
:lsos
)
61 (:shadow
:call-method
:call-next-method
:slot-value
)
62 (:export ls-object objectp
*object
* kind-of-p make-object
*message-hook
*
63 *set-slot-hook
* slot-value self send call-next-method call-method
64 defmeth defproto instance-slots proto-name
))
66 (in-package :lisp-stat-object-system
)
69 (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system
))
70 (use-package 'lisp-stat-object-system
))
73 ;;;; Structure Implementation of Lisp-Stat Object System
76 (defvar *object-serial
* 0)
79 (:constructor make-object-structure
) ;; why not make-ls-object?
80 (:print-function print-object-structure
)
81 (:predicate objectp
)) ;; why not ls-object-p?
86 (serial (incf *object-serial
*)))
88 (defun print-object-structure (object stream depth
)
89 (send object
:print stream
))
91 (setf (documentation 'objectp
'function
)
93 Returns T if X is an object, NIL otherwise.")
95 (defvar *object
* (make-object-structure)
96 "*object* is the global root object.")
98 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100 ;;;; Utility Functions
102 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
104 ;;; special variable to hold current value of SELF. Assign to current
105 ;;; object that we are working with. AJR:FIXME:Is this going to cause
106 ;;; issues with concurrency? (need to appropriately handle
110 ;;; FIXME: better as macro? maybe not?
112 (if (not (objectp *self
*))
113 (error "not in a method"))
116 (defun has-duplicates (list)
117 (do ((next list
(rest next
)))
118 ((not (consp next
)) nil
)
119 (if (member (first next
) (rest next
)) (return t
))))
121 (defun assoc-eq (item alist
)
122 "Version of assoc using eq -- should be faster than regular assoc."
123 (declare (inline car eq
))
125 (if (eq (car i
) item
) (return i
))))
127 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129 ;;;; Predicate and Checking Functions
131 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
133 (defun check-non-nil-symbol (x)
134 (unless (and x
(symbolp x
)) (error "bad symbol - ~s" x
)))
136 (defun check-object (x)
137 (if (objectp x
) x
(error "bad object - ~s" x
)))
139 (defun kind-of-p (x y
)
141 Returns T is X and Y are objects and X inherits from Y, NIL otherwise."
142 (if (and (objectp x
) (objectp y
))
143 (if (member y
(ls-object-preclist x
)) t nil
)
146 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
148 ;;;; Precedence List Functions
150 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
152 (defun find-SC (object)
153 "find set of object and ancestors. (diff from this and find-S?)"
154 (copy-list (ls-object-preclist (check-object object
))))
156 (defun find-S (object)
157 "find set of object and ancestors. (diff from this and find-SC?)"
159 (parents (ls-object-parents object
) (cdr parents
)))
160 ((not (consp parents
))
161 (delete-duplicates (cons object result
)))
162 (setf result
(nconc (find-SC (first parents
)) result
))))
164 (defun find-RC (object)
165 "find local precedence ordering."
166 (let ((list (copy-list (ls-object-parents (check-object object
)))))
167 (do ((next list
(rest next
)))
168 ((not (consp next
)) list
)
169 (setf (first next
) (cons object
(first next
)))
170 (setf object
(rest (first next
))))))
173 "find partial precedence ordering."
177 (delete-duplicates result
))
178 (setf result
(nconc result
(find-RC (first S
))))))
180 (defun has-predecessor (x R
)
181 "check if x has a predecessor according to R."
183 (if (and (consp cell
) (eq x
(rest cell
))) (return t
))))
185 (defun find-no-predecessor-list (S R
)
186 "find list of objects in S without predecessors, by R."
189 (unless (has-predecessor x R
) (setf result
(cons x result
))))))
191 (defun child-position (x P
)
192 "find the position of child, if any, of x in P, the list found so
195 (declare (fixnum count
))
197 (if (member x
(ls-object-parents next
)) (return count
))
200 (defun next-object (no-preds P
)
201 "find the next object in the precedence list from objects with no
202 predecessor and current list."
204 ((not (consp no-preds
)) nil
)
205 ((not (consp (rest no-preds
))) (first no-preds
))
209 (declare (fixnum count
))
210 (dolist (x no-preds result
)
211 (let ((tcount (child-position x P
)))
212 (declare (fixnum tcount
))
213 (when (> tcount count
)
215 (setf count tcount
))))))))
218 "Remove object x from S."
222 "Remove all pairs containing x from R. x is assumed to have no
223 predecessors, so only the first position is checked."
224 (delete x R
:key
#'first
))
226 (defun precedence-list (object)
227 "Calculate the object's precedence list."
228 (do* ((S (find-S object
))
234 (setf no-preds
(find-no-predecessor-list S R
))
235 (setf next
(next-object no-preds P
))
236 (if (null next
) (error "inconsistent precedence order"))
237 (setf P
(nconc P
(list next
)))
238 (setf S
(trim-S next S
))
239 (setf R
(trim-R next R
))))
241 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243 ;;;; Object Construction Functions
245 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
247 (defun calculate-preclist (object)
248 "Return the precedence list for the object."
249 (let ((parents (ls-object-parents (check-object object
))))
250 (if (not (consp parents
)) (error "bad parent list - ~s" parents
))
251 (if (consp (rest parents
))
252 (precedence-list object
)
253 (let ((parent (check-object (first parents
))))
254 (cons object
(ls-object-preclist parent
))))))
256 (defun check-parents (parents)
258 ((or (null parents
) (objectp parents
)) parents
)
260 (dolist (x parents
) (check-object x
))
261 (if (has-duplicates parents
)
262 (error "parents may not contain duplicates")))
263 (t (error "bad parents - ~s" parents
))))
265 (defun make-basic-object (parents object
)
266 (check-parents parents
)
268 (if (not (objectp object
)) (setf object
(make-object-structure)))
270 (setf (ls-object-preclist object
) (ls-object-preclist *object
*))
271 (setf (ls-object-parents object
)
272 (cond ((null parents
) (list *object
*))
273 ((objectp parents
) (list parents
))
275 (setf (ls-object-preclist object
) (calculate-preclist object
))
279 (defun make-object (&rest parents
)
280 "Args: (&rest parents)
281 Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is used."
282 (make-basic-object parents NIL
))
284 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286 ;;;; Constraint Hook Functions
288 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
290 (pushnew :constrainthooks
*features
*)
294 (defvar *message-hook
* nil
)
295 (defvar *set-slot-hook
* nil
)
297 (defun check-constraint-hooks (object sym slot
)
298 (let ((hook (if slot
*set-slot-hook
* *message-hook
*)))
301 (let ((*set-slot-hook
* nil
))
302 (funcall hook object sym
))
303 (let ((*message-hook
* nil
))
304 (funcall hook object sym
)))))))
306 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
308 ;;; Slot Access Functions
310 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
312 (defun make-slot-entry (x y
) (cons x y
))
313 (defun slot-entry-p (x) (consp x
))
314 (defun slot-entry-key (x) (first x
))
315 (defun slot-entry-value (x) (rest x
))
316 (defun set-slot-entry-value (x v
) (setf (rest x
) v
))
317 (defsetf slot-entry-value set-slot-entry-value
)
319 (defun find-own-slot (x slot
)
320 (if (objectp x
) (assoc-eq slot
(ls-object-slots x
))))
322 (defun find-slot (x slot
)
324 (let ((preclist (ls-object-preclist x
)))
325 (dolist (object preclist
)
326 (let ((slot-entry (find-own-slot object slot
)))
327 (if slot-entry
(return slot-entry
)))))))
329 (defun add-slot (x slot value
)
331 (check-non-nil-symbol slot
)
332 (let ((slot-entry (find-own-slot x slot
)))
334 (setf (slot-entry-value slot-entry
) value
)
335 (setf (ls-object-slots x
)
336 (cons (make-slot-entry slot value
) (ls-object-slots x
)))))
339 (defun delete-slot (x slot
)
341 (setf (ls-object-slots x
)
342 (delete slot
(ls-object-slots x
) :key
#'slot-entry-key
)))
344 (defun get-slot-value (x slot
&optional no-err
)
346 (let ((slot-entry (find-slot x slot
)))
347 (if (slot-entry-p slot-entry
)
348 (slot-entry-value slot-entry
)
349 (unless no-err
(error "no slot named ~s in this object" slot
)))))
351 (defun set-slot-value (x slot value
)
353 (let ((slot-entry (find-own-slot x slot
)))
355 ((slot-entry-p slot-entry
)
356 (set-slot-entry-value slot-entry value
)
357 #+:constrainthooks
(check-constraint-hooks x slot t
))
359 (if (find-slot x slot
)
360 (error "object does not own slot ~s" slot
)
361 (error "no slot named ~s in this object" slot
))))))
363 (defun slot-value (slot)
365 Must be used in a method. Returns the value of current objects slot
367 (get-slot-value (get-self) slot
))
369 (defun slot-value-setf (slot value
)
370 (set-slot-value (get-self) slot value
))
372 (defsetf slot-value slot-value-setf
)
374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376 ;;;; Method Access Functions;
378 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
380 (defun make-method-entry (x y
) (cons x y
))
381 (defun method-entry-p (x) (consp x
))
382 (defun method-entry-key (x) (first x
))
383 (defun method-entry-method (x) (rest x
))
384 (defun set-method-entry-method (x v
) (setf (rest x
) v
))
385 (defsetf method-entry-method set-method-entry-method
)
387 ;(defun find-own-method (x selector)
388 ; (if (objectp x) (assoc selector (ls-object-methods x))))
389 (defun find-own-method (x selector
)
390 (if (objectp x
) (assoc-eq selector
(ls-object-methods x
))))
392 (defun find-lsos-method (x selector
)
394 (let ((preclist (ls-object-preclist x
)))
395 (dolist (object preclist
)
396 (let ((method-entry (find-own-method object selector
)))
397 (if method-entry
(return method-entry
)))))))
399 (defun add-lsos-method (x selector value
)
401 (check-non-nil-symbol selector
)
402 (let ((method-entry (find-own-method x selector
)))
404 (setf (method-entry-method method-entry
) value
)
405 (setf (ls-object-methods x
)
406 (cons (make-method-entry selector value
) (ls-object-methods x
)))))
409 (defun delete-method (x selector
)
411 (setf (ls-object-methods x
)
412 (delete selector
(ls-object-methods x
) :key
#'method-entry-key
)))
414 (defun get-message-method (x selector
&optional no-err
)
416 (let ((method-entry (find-lsos-method x selector
)))
417 (if (method-entry-p method-entry
)
418 (method-entry-method method-entry
)
419 (unless no-err
(error "no method for selector ~s" selector
)))))
421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
423 ;;;; Message Sending Functions
425 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
427 (defvar *current-preclist
* nil
)
428 (defvar *current-selector
* nil
)
430 (defun sendmsg (object selector preclist args
)
431 (let ((method-entry nil
)
434 ;; look for the message in the precedence list
436 (setf method-entry
(find-own-method (first preclist
) selector
))
437 (if (or method-entry
(not (consp preclist
))) (return))
438 (setf preclist
(rest preclist
)))
440 ((null method-entry
) (error "no method for selector ~s" selector
))
441 ((not (method-entry-p method-entry
)) (error "bad method entry"))
442 (t (setf method
(method-entry-method method-entry
))))
445 (let ((*current-preclist
* preclist
)
446 (*current-selector
* selector
)
448 (multiple-value-prog1
449 (apply method object args
)
450 #+:constrainthooks
(check-constraint-hooks object selector nil
)))))
452 ;;;; built-in send function
453 (defun send (object selector
&rest args
)
454 "Args: (object selector &rest args)
455 Applies first method for SELECTOR found in OBJECT's precedence list to
457 (sendmsg object selector
(ls-object-preclist object
) args
))
459 ;;;; call-next-method - call inherited version of current method
460 (defun call-next-method (&rest args
)
462 Funcalls next method for current selector and precedence list. Can only be
464 (sendmsg *self
* *current-selector
* (rest *current-preclist
*) args
))
466 ;;;; call-method - call method belonging to another object on current object
468 ;; ugly cruft, need better solution for SBCL packagelocks
469 ;; #+sbcl(declare (sb-ext:disable-package-locks ls-objects:call-method))
471 (defun call-method (object selector
&rest args
)
472 "Args (object selector &rest args)
473 Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in
475 (sendmsg *self
* selector
(ls-object-preclist object
) args
))
477 ;; #+sbcl(declare (sb-ext:enable-package-locks ls-objects:call-method))
479 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
481 ;;;; Object Documentation Functions
483 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
485 (defun find-documentation (x sym add
)
487 (let ((doc (find-own-slot x
'documentation
)))
488 (if (and (null doc
) add
) (add-slot x
'documentation nil
))
489 (if (slot-entry-p doc
) (assoc sym
(slot-entry-value doc
))))))
491 (defun add-documentation (x sym value
)
493 (check-non-nil-symbol sym
)
494 (let ((doc-entry (find-documentation x sym t
)))
496 ((not (null doc-entry
))
497 (setf (rest doc-entry
) value
))
501 (cons (cons sym value
)
502 (get-slot-value x
'documentation
))))))
505 (defun get-documentation (x sym
)
507 (dolist (object (ls-object-preclist x
))
508 ;; (let ((doc-entry (find-documentation x sym nil))) ;; shouldn't object be here somewhere?
509 (let ((doc-entry (find-documentation object sym nil
))) ;; FIXME: verify
510 (if doc-entry
(return (rest doc-entry
))))))
512 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
516 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
518 (defmacro defmeth
(object name arglist first
&rest body
)
519 "Syntax: (defmeth object name lambda-list [doc] {form}*)
520 OBJECT must evaluate to an existing object. Installs a method for NAME in
521 the value of OBJECT and installs DOC in OBJECTS's documentation."
522 (if (and body
(stringp first
))
524 (add-lsos-method ,object
,name
525 #'(lambda (self ,@arglist
) (block ,name
,@body
)))
526 (add-documentation ,object
,name
,first
)
529 (add-lsos-method ,object
,name
530 #'(lambda (self ,@arglist
) (block ,name
,first
,@body
)))
533 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
535 ;;;; Prototype Construction Functions and Macros
537 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
539 (defun find-instance-slots (x slots
)
540 (let ((result (nreverse (delete-duplicates (copy-list slots
)))))
541 (dolist (parent (ls-object-parents x
) (nreverse result
))
542 (dolist (slot (get-slot-value parent
'instance-slots
))
543 (pushnew slot result
)))))
545 (defun get-initial-slot-value (object slot
)
546 (let ((entry (find-slot object slot
)))
547 (if (slot-entry-p entry
) (slot-entry-value entry
))))
549 (defun make-prototype (object name ivars cvars doc set
)
550 (setf ivars
(find-instance-slots object ivars
))
551 (add-slot object
'instance-slots ivars
)
552 (add-slot object
'proto-name name
)
555 (add-slot object slot
(get-initial-slot-value object slot
)))
558 (add-slot object slot nil
))
560 (if (and doc
(stringp doc
))
561 (add-documentation object
'proto doc
))
562 (if set
(setf (symbol-value name
) object
)))
564 ;; FIXME: name needs to be defvar'd somewhere?! CL compilers don't like it otherwise.
565 ;; FIXME: above is not true. SBCL doesn't like it, but CMUCL likes it. Need to see what CLISP sez.
566 ;; almost creating a new variable -- is it a macro-expansion vs. other issue?
567 (defmacro defproto
(name &optional ivars cvars parents doc
)
568 "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
569 Makes a new object prototype with instance variables IVARS, 'class'
570 variables CVARS and parents PARENT. PARENT can be a single object or
571 a list of objects. IVARS and CVARS must be lists."
572 (let ((obsym (gensym))
576 (let* ((,namesym
',name
)
578 (,obsym
(make-basic-object (if (listp ,parsym
)
580 (list ,parsym
)) ;; should this be ,@parsym ?
582 (make-prototype ,obsym
,namesym
,ivars
,cvars
,doc t
)
587 ;; , => turn on evaluation again (not macro substitution)
589 ;; ' => regular quote (not special in this context).
594 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
596 ;;;; Initialize the Root Object
598 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
600 (setf (ls-object-preclist *object
*) (list *object
*))
601 (add-slot *object
* 'instance-slots nil
)
602 (add-slot *object
* 'proto-name
'*object
*)
603 (add-slot *object
* 'documentation nil
) ; AJR - for SBCL compiler
604 ; issues about macro with
607 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
609 ;;;; *OBJECT* Methods
611 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
613 (defmeth *object
* :isnew
(&rest args
)
614 "Method args: (&rest args)
615 Checks ARGS for keyword arguments matching slots and uses them to
618 (dolist (slot-entry (ls-object-slots self
))
619 (let* ((slot (slot-entry-key slot-entry
))
620 (key (intern (symbol-name slot
) (find-package 'keyword
)))
621 (val (slot-value slot
))
622 (new-val (getf args key val
)))
623 (unless (eq val new-val
) (setf (slot-value slot
) new-val
)))))
626 (defmeth *object
* :has-slot
(slot &key own
)
627 "Method args: (slot &optional own)
628 Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
629 only checks the object; otherwise check the entire precedence list."
630 (let ((entry (if own
(find-own-slot self slot
) (find-slot self slot
))))
633 (defmeth *object
* :add-slot
(slot &optional value
)
634 "Method args: (slot &optional value)
635 Installs slot SLOT in object, if it does not already exist, and
636 sets its value to VLAUE."
637 (add-slot self slot value
)
640 (defmeth *object
* :delete-slot
(slot)
642 Deletes slot SLOT from object if it exists."
643 (delete-slot self slot
)
646 (defmeth *object
* :own-slots
()
648 Returns list of names of slots owned by object."
649 (mapcar #'slot-entry-key
(ls-object-slots self
)))
651 (defmeth *object
* :has-method
(selector &key own
)
652 "Method args: (selector &optional own)
653 Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
654 only checks the object; otherwise check the entire precedence list."
656 (find-own-method self selector
)
657 (find-lsos-method self selector
))))
660 (defmeth *object
* :add-method
(selector method
)
661 "Method args: (selector method)
662 Installs METHOD for SELECTOR in object."
663 (add-lsos-method self selector method
)
666 (defmeth *object
* :delete-method
(selector)
667 "Method args: (selector)
668 Deletes method for SELECTOR in object if it exists."
669 (delete-method self selector
)
672 (defmeth *object
* :get-method
(selector)
673 "Method args: (selector)
674 Returns method for SELECTOR symbol from object's precedence list."
675 (get-message-method self selector
))
677 (defmeth *object
* :own-methods
()
679 Returns copy of selectors for methods owned by object."
680 (mapcar #'method-entry-key
(ls-object-methods self
)))
682 (defmeth *object
* :parents
()
684 Returns copy of parents list."
685 (copy-list (ls-object-parents self
)))
687 (defmeth *object
* :precedence-list
()
689 Returns copy of the precedence list."
690 (copy-list (ls-object-preclist self
)))
692 (defmeth *object
* :show
(&optional
(stream t
))
694 Prints object's internal data."
695 (format stream
"Slots = ~s~%" (ls-object-slots self
))
696 (format stream
"Methods = ~s~%" (ls-object-methods self
))
697 (format stream
"Parents = ~s~%" (ls-object-parents self
))
698 (format stream
"Precedence List = ~s~%" (ls-object-preclist self
))
701 (defmeth *object
* :reparent
(&rest parents
)
702 "Method args: (&rest parents)
703 Changes precedence list to correspond to PARENTS. Does not change descendants."
704 (make-basic-object parents self
))
706 (defmeth *object
* :make-prototype
(name &optional ivars
)
707 (make-prototype self name ivars nil nil nil
)
710 (defmeth *object
* :internal-doc
(sym &optional new
)
711 "Method args (topic &optional value)
712 Retrieves or installs documentation for topic."
713 (if new
(add-documentation self sym new
))
714 (get-documentation self sym
))
716 (defmeth *object
* :new
(&rest args
)
717 "Method args: (&rest args)
718 Creates new object using self as prototype."
719 (let* ((object (make-object self
)))
720 (if (slot-value 'instance-slots
)
721 (dolist (s (slot-value 'instance-slots
))
722 (send object
:add-slot s
(slot-value s
))))
723 (apply #'send object
:isnew args
)
726 (defmeth *object
* :retype
(proto &rest args
)
727 "Method args: (proto &rest args)
728 Changes object to inherit directly from prototype PROTO. PROTO
729 must be a prototype and SELF must not be one."
730 (if (send self
:has-slot
'instance-slots
:own t
)
731 (error "can't retype a prototype"))
732 (if (not (send proto
:has-slot
'instance-slots
:own t
))
733 (error "not a prototype - ~a" proto
))
734 (send self
:reparent proto
)
735 (dolist (s (send proto
:slot-value
'instance-slots
))
736 (send self
:add-slot s
(slot-value s
)))
737 (apply #'send self
:isnew args
)
740 (defmeth *object
* :print
(&optional
(stream *standard-output
*))
741 "Method args: (&optional (stream *standard-output*))
742 Default object printing method."
744 ((send self
:has-slot
'proto-name
)
746 "#<Object: ~D, prototype = ~A>"
747 (ls-object-serial self
)
748 (slot-value 'proto-name
)))
749 (t (format stream
"#<Object: ~D>" (ls-object-serial self
)))))
751 (defmeth *object
* :slot-value
(sym &optional
(val nil set
))
752 "Method args: (sym &optional val)
753 Sets and retrieves value of slot named SYM. Sugnals an error if slot
755 (if set
(setf (slot-value sym
) val
))
758 (defmeth *object
* :slot-names
()
760 Returns list of slots available to the object."
762 (mapcar #'(lambda (x) (send x
:own-slots
))
763 (send self
:precedence-list
))))
765 (defmeth *object
* :method-selectors
()
767 Returns list of method selectors available to object."
769 (mapcar #'(lambda (x) (send x
:own-methods
))
770 (send self
:precedence-list
))))
773 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
775 ;;;; Object Help Methods
777 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
779 (defmeth *object
* :doc-topics
()
781 Returns all topics with documentation for this object."
787 (if (send x
:has-slot
'documentation
:own t
)
788 (send x
:slot-value
(quote documentation
))))
789 (send self
:precedence-list
))))))
791 (defmeth *object
* :documentation
(topic &optional
(val nil set
))
792 "Method args: (topic &optional val)
793 Retrieves or sets object documentation for topic."
794 (if set
(send self
:internal-doc topic val
))
795 (let ((val (dolist (i (send self
:precedence-list
))
796 (let ((val (send i
:internal-doc topic
)))
797 (if val
(return val
))))))
800 (defmeth *object
* :delete-documentation
(topic)
801 "Method args: (topic)
802 Deletes object documentation for TOPIC."
803 (setf (slot-value 'documentation
)
804 ;;(remove :title nil :test #'(lambda (x y) (eql x (first y)))) ;; original
805 (remove topic
(send self
:documentation
) :test
#'(lambda (x y
) (eql x
(first y
))))) ;; AJR:PROBLEM?
808 (defmeth *object
* :help
(&optional topic
)
809 "Method args: (&optional topic)
810 Prints help message for TOPIC, or genreal help if TOPIC is NIL."
812 (let ((doc (send self
:documentation topic
)))
814 (doc (princ topic
) (terpri) (princ doc
) (terpri))
815 (t (format t
"Sorry, no help available on ~a~%" topic
))))
816 (let ((topics (stable-sort (copy-seq (send self
:doc-topics
))
818 (string-lessp (string x
) (string y
)))))
819 (proto-doc (send self
:documentation
'proto
)))
820 (if (send self
:has-slot
'proto-name
)
821 (format t
"~s~%" (slot-value 'proto-name
)))
822 (when proto-doc
(princ proto-doc
) (terpri))
823 (format t
"Help is available on the following:~%~%")
824 (dolist (i topics
) (format t
"~s " i
))
828 (defmeth *object
* :compile-method
(name)
830 Compiles method NAME unless it is already compiled. The object must
832 (unless (send self
:has-method name
)
833 (error "No ~s method in this object" name
))
834 (unless (send self
:has-method name
:own t
)
835 (error "Object does not own ~s method" name
))
836 (let ((fun (send self
:get-method name
)))
837 (unless (compiled-function-p fun
)
838 (multiple-value-bind (form env
) (function-lambda-expression fun
)
841 "method may have been defined in non-null environment"))
842 (send self
:add-method name
(compile nil form
))))))