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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
57 (defpackage :lisp-stat-object-system
58 (:nicknames
:ls-objects
:lsos
)
60 (:shadow
:call-method
:call-next-method
:slot-value
)
61 (:export ls-object objectp
*object
* kind-of-p make-object
*message-hook
*
62 *set-slot-hook
* slot-value self send call-next-method call-method
63 defmeth defproto instance-slots proto-name
))
65 (in-package :lisp-stat-object-system
)
68 "Formerly set up to import lisp-stat-object-system into current package."
69 (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system
))
70 (use-package 'lisp-stat-object-system
))
72 ;;; Structure Implementation of Lisp-Stat Object System
74 (defvar *object-serial
* 0)
77 (:constructor make-object-structure
) ;; why not make-ls-object?
78 (:print-function print-object-structure
)
79 (:predicate objectp
)) ;; why not ls-object-p?
84 (serial (incf *object-serial
*)))
86 (defun print-object-structure (object stream depth
)
87 (if nil
(princ "~a : ~a : ~a" object stream depth
)) ;warning avoidance
88 (send object
:print stream
))
90 (setf (documentation 'objectp
'function
)
92 Returns T if X is an object, NIL otherwise.")
94 (defvar *object
* (make-object-structure)
95 "*object* is the global root object.")
97 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
99 ;;;; Utility Functions
101 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
103 ;;; special variable to hold current value of SELF. Assign to current
104 ;;; object that we are working with. AJR:FIXME:Is this going to cause
105 ;;; issues with concurrency? (need to appropriately handle
109 ;;; FIXME: better as macro? maybe not?
111 (if (not (objectp *self
*))
112 (error "not in a method"))
115 (defun has-duplicates (list)
116 (do ((next list
(rest next
)))
117 ((not (consp next
)) nil
)
118 (if (member (first next
) (rest next
)) (return t
))))
120 (defun assoc-eq (item alist
)
121 "Version of assoc using eq -- should be faster than regular assoc."
122 (declare (inline car eq
))
124 (if (eq (car i
) item
) (return i
))))
126 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
128 ;;;; Predicate and Checking Functions
130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
132 (defun check-non-nil-symbol (x)
133 (unless (and x
(symbolp x
)) (error "bad symbol - ~s" x
)))
135 (defun check-object (x)
136 (if (objectp x
) x
(error "bad object - ~s" x
)))
138 (defun kind-of-p (x y
)
140 Returns T is X and Y are objects and X inherits from Y, NIL otherwise."
141 (if (and (objectp x
) (objectp y
))
142 (if (member y
(ls-object-preclist x
)) t nil
)
145 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
147 ;;;; Precedence List Functions
149 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
151 (defun find-SC (object)
152 "find set of object and ancestors. (diff from this and find-S?)"
153 (copy-list (ls-object-preclist (check-object object
))))
155 (defun find-S (object)
156 "find set of object and ancestors. (diff from this and find-SC?)"
158 (parents (ls-object-parents object
) (cdr parents
)))
159 ((not (consp parents
))
160 (delete-duplicates (cons object result
)))
161 (setf result
(nconc (find-SC (first parents
)) result
))))
163 (defun find-RC (object)
164 "find local precedence ordering."
165 (let ((list (copy-list (ls-object-parents (check-object object
)))))
166 (do ((next list
(rest next
)))
167 ((not (consp next
)) list
)
168 (setf (first next
) (cons object
(first next
)))
169 (setf object
(rest (first next
))))))
172 "find partial precedence ordering."
176 (delete-duplicates result
))
177 (setf result
(nconc result
(find-RC (first S
))))))
179 (defun has-predecessor (x R
)
180 "check if x has a predecessor according to R."
182 (if (and (consp cell
) (eq x
(rest cell
))) (return t
))))
184 (defun find-no-predecessor-list (S R
)
185 "find list of objects in S without predecessors, by R."
188 (unless (has-predecessor x R
) (setf result
(cons x result
))))))
190 (defun child-position (x P
)
191 "find the position of child, if any, of x in P, the list found so
194 (declare (fixnum count
))
196 (if (member x
(ls-object-parents next
)) (return count
))
199 (defun next-object (no-preds P
)
200 "find the next object in the precedence list from objects with no
201 predecessor and current list."
203 ((not (consp no-preds
)) nil
)
204 ((not (consp (rest no-preds
))) (first no-preds
))
208 (declare (fixnum count
))
209 (dolist (x no-preds result
)
210 (let ((tcount (child-position x P
)))
211 (declare (fixnum tcount
))
212 (when (> tcount count
)
214 (setf count tcount
))))))))
217 "Remove object x from S."
221 "Remove all pairs containing x from R. x is assumed to have no
222 predecessors, so only the first position is checked."
223 (delete x R
:key
#'first
))
225 (defun precedence-list (object)
226 "Calculate the object's precedence list."
227 (do* ((S (find-S object
))
233 (setf no-preds
(find-no-predecessor-list S R
))
234 (setf next
(next-object no-preds P
))
235 (if (null next
) (error "inconsistent precedence order"))
236 (setf P
(nconc P
(list next
)))
237 (setf S
(trim-S next S
))
238 (setf R
(trim-R next R
))))
240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
242 ;;;; Object Construction Functions
244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
246 (defun calculate-preclist (object)
247 "Return the precedence list for the object."
248 (let ((parents (ls-object-parents (check-object object
))))
249 (if (not (consp parents
)) (error "bad parent list - ~s" parents
))
250 (if (consp (rest parents
))
251 (precedence-list object
)
252 (let ((parent (check-object (first parents
))))
253 (cons object
(ls-object-preclist parent
))))))
255 (defun check-parents (parents)
257 ((or (null parents
) (objectp parents
)) parents
)
259 (dolist (x parents
) (check-object x
))
260 (if (has-duplicates parents
)
261 (error "parents may not contain duplicates")))
262 (t (error "bad parents - ~s" parents
))))
264 (defun make-basic-object (parents object
)
265 (check-parents parents
)
267 (if (not (objectp object
)) (setf object
(make-object-structure)))
269 (setf (ls-object-preclist object
) (ls-object-preclist *object
*))
270 (setf (ls-object-parents object
)
271 (cond ((null parents
) (list *object
*))
272 ((objectp parents
) (list parents
))
274 (setf (ls-object-preclist object
) (calculate-preclist object
))
278 (defun make-object (&rest parents
)
279 "Args: (&rest parents)
280 Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is used."
281 (make-basic-object parents NIL
))
283 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
285 ;;;; Constraint Hook Functions
287 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
289 (pushnew :constrainthooks
*features
*)
293 (defvar *message-hook
* nil
)
294 (defvar *set-slot-hook
* nil
)
296 (defun check-constraint-hooks (object sym slot
)
297 (let ((hook (if slot
*set-slot-hook
* *message-hook
*)))
300 (let ((*set-slot-hook
* nil
))
301 (funcall hook object sym
))
302 (let ((*message-hook
* nil
))
303 (funcall hook object sym
)))))))
305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
307 ;;; Slot Access Functions
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
311 (defun make-slot-entry (x y
) (cons x y
))
312 (defun slot-entry-p (x) (consp x
))
313 (defun slot-entry-key (x) (first x
))
314 (defun slot-entry-value (x) (rest x
))
315 (defun set-slot-entry-value (x v
) (setf (rest x
) v
))
316 (defsetf slot-entry-value set-slot-entry-value
)
318 (defun find-own-slot (x slot
)
319 (if (objectp x
) (assoc-eq slot
(ls-object-slots x
))))
321 (defun find-slot (x slot
)
323 (let ((preclist (ls-object-preclist x
)))
324 (dolist (object preclist
)
325 (let ((slot-entry (find-own-slot object slot
)))
326 (if slot-entry
(return slot-entry
)))))))
328 (defun add-slot (x slot value
)
330 (check-non-nil-symbol slot
)
331 (let ((slot-entry (find-own-slot x slot
)))
333 (setf (slot-entry-value slot-entry
) value
)
334 (setf (ls-object-slots x
)
335 (cons (make-slot-entry slot value
) (ls-object-slots x
)))))
338 (defun delete-slot (x slot
)
340 (setf (ls-object-slots x
)
341 (delete slot
(ls-object-slots x
) :key
#'slot-entry-key
)))
343 (defun get-slot-value (x slot
&optional no-err
)
345 (let ((slot-entry (find-slot x slot
)))
346 (if (slot-entry-p slot-entry
)
347 (slot-entry-value slot-entry
)
348 (unless no-err
(error "no slot named ~s in this object" slot
)))))
350 (defun set-slot-value (x slot value
)
352 (let ((slot-entry (find-own-slot x slot
)))
354 ((slot-entry-p slot-entry
)
355 (set-slot-entry-value slot-entry value
)
356 #+:constrainthooks
(check-constraint-hooks x slot t
))
358 (if (find-slot x slot
)
359 (error "object does not own slot ~s" slot
)
360 (error "no slot named ~s in this object" slot
))))))
362 (defun slot-value (slot)
364 Must be used in a method. Returns the value of current objects slot
366 (get-slot-value (get-self) slot
))
368 (defun slot-value-setf (slot value
)
369 (set-slot-value (get-self) slot value
))
371 (defsetf slot-value slot-value-setf
)
373 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
375 ;;;; Method Access Functions;
377 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
379 (defun make-method-entry (x y
) (cons x y
))
380 (defun method-entry-p (x) (consp x
))
381 (defun method-entry-key (x) (first x
))
382 (defun method-entry-method (x) (rest x
))
383 (defun set-method-entry-method (x v
) (setf (rest x
) v
))
384 (defsetf method-entry-method set-method-entry-method
)
386 ;(defun find-own-method (x selector)
387 ; (if (objectp x) (assoc selector (ls-object-methods x))))
388 (defun find-own-method (x selector
)
389 (if (objectp x
) (assoc-eq selector
(ls-object-methods x
))))
391 (defun find-lsos-method (x selector
)
393 (let ((preclist (ls-object-preclist x
)))
394 (dolist (object preclist
)
395 (let ((method-entry (find-own-method object selector
)))
396 (if method-entry
(return method-entry
)))))))
398 (defun add-lsos-method (x selector value
)
399 "x = object; selector = name of method; value = method."
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 method-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 RETURNS: method-name."
523 (if (and body
(stringp first
))
525 (add-lsos-method ,object
,name
526 #'(lambda (self ,@arglist
) (block ,name
,@body
)))
527 (add-documentation ,object
,name
,first
)
530 (add-lsos-method ,object
,name
531 #'(lambda (self ,@arglist
) (block ,name
,first
,@body
)))
534 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
536 ;;;; Prototype Construction Functions and Macros
538 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
540 (defun find-instance-slots (x slots
)
541 (let ((result (nreverse (delete-duplicates (copy-list slots
)))))
542 (dolist (parent (ls-object-parents x
) (nreverse result
))
543 (dolist (slot (get-slot-value parent
'instance-slots
))
544 (pushnew slot result
)))))
546 (defun get-initial-slot-value (object slot
)
547 (let ((entry (find-slot object slot
)))
548 (if (slot-entry-p entry
) (slot-entry-value entry
))))
550 (defun make-prototype (object name ivars cvars doc set
)
551 (setf ivars
(find-instance-slots object ivars
))
552 (add-slot object
'instance-slots ivars
)
553 (add-slot object
'proto-name name
)
556 (add-slot object slot
(get-initial-slot-value object slot
)))
559 (add-slot object slot nil
))
561 (if (and doc
(stringp doc
))
562 (add-documentation object
'proto doc
))
563 (if set
(setf (symbol-value name
) object
)))
565 ;; FIXME: name needs to be defvar'd somewhere?! CL compilers don't like it otherwise.
566 ;; FIXME: above is not true. SBCL doesn't like it, but CMUCL likes it. Need to see what CLISP sez.
567 ;; almost creating a new variable -- is it a macro-expansion vs. other issue?
568 (defmacro defproto
(name &optional ivars cvars parents doc
)
569 "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
570 Makes a new object prototype with instance variables IVARS, 'class'
571 variables CVARS and parents PARENT. PARENT can be a single object or
572 a list of objects. IVARS and CVARS must be lists."
573 (let ((obsym (gensym))
577 (let* ((,namesym
',name
)
579 (,obsym
(make-basic-object (if (listp ,parsym
)
581 (list ,parsym
)) ;; should this be ,@parsym ?
583 (make-prototype ,obsym
,namesym
,ivars
,cvars
,doc t
)
588 ;; , => turn on evaluation again (not macro substitution)
590 ;; ' => regular quote (not special in this context).
595 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
597 ;;;; Initialize the Root Object
599 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
601 (setf (ls-object-preclist *object
*) (list *object
*))
602 (add-slot *object
* 'instance-slots nil
)
603 (add-slot *object
* 'proto-name
'*object
*)
604 (add-slot *object
* 'documentation nil
) ; AJR - for SBCL compiler
605 ; issues about macro with
608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
610 ;;;; *OBJECT* Methods
612 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
614 (defmeth *object
* :isnew
(&rest args
)
615 "Method args: (&rest args)
616 Checks ARGS for keyword arguments matching slots and uses them to
619 (dolist (slot-entry (ls-object-slots self
))
620 (let* ((slot (slot-entry-key slot-entry
))
621 (key (intern (symbol-name slot
) (find-package 'keyword
)))
622 (val (slot-value slot
))
623 (new-val (getf args key val
)))
624 (unless (eq val new-val
) (setf (slot-value slot
) new-val
)))))
627 (defmeth *object
* :has-slot
(slot &key own
)
628 "Method args: (slot &optional own)
629 Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
630 only checks the object; otherwise check the entire precedence list."
631 (let ((entry (if own
(find-own-slot self slot
) (find-slot self slot
))))
634 (defmeth *object
* :add-slot
(slot &optional value
)
635 "Method args: (slot &optional value)
636 Installs slot SLOT in object, if it does not already exist, and
637 sets its value to VLAUE."
638 (add-slot self slot value
)
641 (defmeth *object
* :delete-slot
(slot)
643 Deletes slot SLOT from object if it exists."
644 (delete-slot self slot
)
647 (defmeth *object
* :own-slots
()
649 Returns list of names of slots owned by object."
650 (mapcar #'slot-entry-key
(ls-object-slots self
)))
652 (defmeth *object
* :has-method
(selector &key own
)
653 "Method args: (selector &optional own)
654 Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
655 only checks the object; otherwise check the entire precedence list."
657 (find-own-method self selector
)
658 (find-lsos-method self selector
))))
661 (defmeth *object
* :add-method
(selector method
)
662 "Method args: (selector method)
663 Installs METHOD for SELECTOR in object."
664 (add-lsos-method self selector method
)
667 (defmeth *object
* :delete-method
(selector)
668 "Method args: (selector)
669 Deletes method for SELECTOR in object if it exists."
670 (delete-method self selector
)
673 (defmeth *object
* :get-method
(selector)
674 "Method args: (selector)
675 Returns method for SELECTOR symbol from object's precedence list."
676 (get-message-method self selector
))
678 (defmeth *object
* :own-methods
()
680 Returns copy of selectors for methods owned by object."
681 (mapcar #'method-entry-key
(ls-object-methods self
)))
683 (defmeth *object
* :parents
()
685 Returns copy of parents list."
686 (copy-list (ls-object-parents self
)))
688 (defmeth *object
* :precedence-list
()
690 Returns copy of the precedence list."
691 (copy-list (ls-object-preclist self
)))
693 (defmeth *object
* :show
(&optional
(stream t
))
695 Prints object's internal data."
696 (format stream
"Slots = ~s~%" (ls-object-slots self
))
697 (format stream
"Methods = ~s~%" (ls-object-methods self
))
698 (format stream
"Parents = ~s~%" (ls-object-parents self
))
699 (format stream
"Precedence List = ~s~%" (ls-object-preclist self
))
702 (defmeth *object
* :reparent
(&rest parents
)
703 "Method args: (&rest parents)
704 Changes precedence list to correspond to PARENTS. Does not change descendants."
705 (make-basic-object parents self
))
707 (defmeth *object
* :make-prototype
(name &optional ivars
)
708 (make-prototype self name ivars nil nil nil
)
711 (defmeth *object
* :internal-doc
(sym &optional new
)
712 "Method args (topic &optional value)
713 Retrieves or installs documentation for topic."
714 (if new
(add-documentation self sym new
))
715 (get-documentation self sym
))
717 (defmeth *object
* :new
(&rest args
)
718 "Method args: (&rest args)
719 Creates new object using self as prototype."
720 (let* ((object (make-object self
)))
721 (if (slot-value 'instance-slots
)
722 (dolist (s (slot-value 'instance-slots
))
723 (send object
:add-slot s
(slot-value s
))))
724 (apply #'send object
:isnew args
)
727 (defmeth *object
* :retype
(proto &rest args
)
728 "Method args: (proto &rest args)
729 Changes object to inherit directly from prototype PROTO. PROTO
730 must be a prototype and SELF must not be one."
731 (if (send self
:has-slot
'instance-slots
:own t
)
732 (error "can't retype a prototype"))
733 (if (not (send proto
:has-slot
'instance-slots
:own t
))
734 (error "not a prototype - ~a" proto
))
735 (send self
:reparent proto
)
736 (dolist (s (send proto
:slot-value
'instance-slots
))
737 (send self
:add-slot s
(slot-value s
)))
738 (apply #'send self
:isnew args
)
741 (defmeth *object
* :print
(&optional
(stream *standard-output
*))
742 "Method args: (&optional (stream *standard-output*))
743 Default object printing method."
745 ((send self
:has-slot
'proto-name
)
747 "#<Object: ~D, prototype = ~A>"
748 (ls-object-serial self
)
749 (slot-value 'proto-name
)))
750 (t (format stream
"#<Object: ~D>" (ls-object-serial self
)))))
752 (defmeth *object
* :slot-value
(sym &optional
(val nil set
))
753 "Method args: (sym &optional val)
754 Sets and retrieves value of slot named SYM. Sugnals an error if slot
756 (if set
(setf (slot-value sym
) val
))
759 (defmeth *object
* :slot-names
()
761 Returns list of slots available to the object."
763 (mapcar #'(lambda (x) (send x
:own-slots
))
764 (send self
:precedence-list
))))
766 (defmeth *object
* :method-selectors
()
768 Returns list of method selectors available to object."
770 (mapcar #'(lambda (x) (send x
:own-methods
))
771 (send self
:precedence-list
))))
774 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
776 ;;;; Object Help Methods
778 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
780 (defmeth *object
* :doc-topics
()
782 Returns all topics with documentation for this object."
788 (if (send x
:has-slot
'documentation
:own t
)
789 (send x
:slot-value
(quote documentation
))))
790 (send self
:precedence-list
))))))
792 (defmeth *object
* :documentation
(topic &optional
(val nil set
))
793 "Method args: (topic &optional val)
794 Retrieves or sets object documentation for topic."
795 (if set
(send self
:internal-doc topic val
))
796 (let ((val (dolist (i (send self
:precedence-list
))
797 (let ((val (send i
:internal-doc topic
)))
798 (if val
(return val
))))))
801 (defmeth *object
* :delete-documentation
(topic)
802 "Method args: (topic)
803 Deletes object documentation for TOPIC."
804 (setf (slot-value 'documentation
)
805 ;;(remove :title nil :test #'(lambda (x y) (eql x (first y)))) ;; original
806 (remove topic
(send self
:documentation
) :test
#'(lambda (x y
) (eql x
(first y
))))) ;; AJR:PROBLEM?
809 (defmeth *object
* :help
(&optional topic
)
810 "Method args: (&optional topic)
811 Prints help message for TOPIC, or genreal help if TOPIC is NIL."
813 (let ((doc (send self
:documentation topic
)))
815 (doc (princ topic
) (terpri) (princ doc
) (terpri))
816 (t (format t
"Sorry, no help available on ~a~%" topic
))))
817 (let ((topics (stable-sort (copy-seq (send self
:doc-topics
))
819 (string-lessp (string x
) (string y
)))))
820 (proto-doc (send self
:documentation
'proto
)))
821 (if (send self
:has-slot
'proto-name
)
822 (format t
"~s~%" (slot-value 'proto-name
)))
823 (when proto-doc
(princ proto-doc
) (terpri))
824 (format t
"Help is available on the following:~%~%")
825 (dolist (i topics
) (format t
"~s " i
))
829 (defmeth *object
* :compile-method
(name)
831 Compiles method NAME unless it is already compiled. The object must
833 (unless (send self
:has-method name
)
834 (error "No ~s method in this object" name
))
835 (unless (send self
:has-method name
:own t
)
836 (error "Object does not own ~s method" name
))
837 (let ((fun (send self
:get-method name
)))
838 (unless (compiled-function-p fun
)
839 (multiple-value-bind (form env
) (function-lambda-expression fun
)
842 "method may have been defined in non-null environment"))
843 (send self
:add-method name
(compile nil form
))))))