use complete forms to initialize environment
[CommonLispStat.git] / lsobjects.lsp
blobeb8996b4021b831afe5ceb332245e2f84b49fad4
1 ;;; -*- mode: lisp -*-
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;;;
9 ;;;; LISP-STAT Object System
10 ;;;;
11 ;;;;
12 ;;;; Simple CL implementation of the object system for Lisp-Stat (LSOS)
13 ;;;; as described in Tierney (1990).
14 ;;;;
15 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
16 ;;;; unrestricted use.
17 ;;;;
18 ;;;;
19 ;;;; NOTES:
20 ;;;;
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.
24 ;;;;
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.
32 ;;;;
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.)
37 ;;;;
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
44 ;;;; protocol.
45 ;;;;
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).
50 ;;;;
51 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
55 ;;; Package Setup
57 (in-package :cl-user)
59 (defpackage :lisp-stat-object-system
60 (:nicknames :ls-objects :lsos)
61 (:use :common-lisp)
62 (:shadow :call-method :call-next-method :slot-value)
63 (:export ls-object objectp *object* kind-of-p make-object *message-hook*
64 *set-slot-hook* slot-value self send call-next-method call-method
65 defmeth defproto instance-slots proto-name))
67 (in-package :lisp-stat-object-system)
69 (defun use-lsos ()
70 "Formerly set up to import lisp-stat-object-system into current package."
71 (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
72 (use-package 'lisp-stat-object-system))
74 ;;; Structure Implementation of Lisp-Stat Object System
76 (defvar *object-serial* 0)
78 (defstruct (ls-object
79 (:constructor make-object-structure) ;; why not make-ls-object?
80 (:print-function print-object-structure)
81 (:predicate objectp)) ;; why not ls-object-p?
82 slots
83 methods
84 parents
85 preclist
86 (serial (incf *object-serial*)))
88 (defun print-object-structure (object stream depth)
89 (declare (ignore depth))
90 (send object :print stream))
92 (setf (documentation 'objectp 'function)
93 "Args: (x)
94 Returns T if X is an object, NIL otherwise.")
96 (defvar *object* (make-object-structure)
97 "*object* is the global root object.")
99 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
100 ;;;;
101 ;;;; Utility Functions
102 ;;;;
103 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
105 ;;; special variable to hold current value of SELF. Assign to current
106 ;;; object that we are working with. AJR:FIXME:Is this going to cause
107 ;;; issues with concurrency? (need to appropriately handle
108 ;;; interrupts).
109 (defvar *self* nil)
111 ;;; FIXME: better as macro? maybe not?
112 (defun get-self ()
113 (if (not (objectp *self*))
114 (error "not in a method"))
115 *self*)
117 (defun has-duplicates (list)
118 (do ((next list (rest next)))
119 ((not (consp next)) nil)
120 (if (member (first next) (rest next)) (return t))))
122 (defun assoc-eq (item alist)
123 "Version of assoc using eq -- should be faster than regular assoc."
124 (declare (inline car eq))
125 (dolist (i alist)
126 (if (eq (car i) item) (return i))))
128 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
129 ;;;;
130 ;;;; Predicate and Checking Functions
131 ;;;;
132 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
134 (defun check-non-nil-symbol (x)
135 (unless (and x (symbolp x)) (error "bad symbol - ~s" x)))
137 (defun check-object (x)
138 (if (objectp x) x (error "bad object - ~s" x)))
140 (defun kind-of-p (x y)
141 "Args: (x y)
142 Returns T is X and Y are objects and X inherits from Y, NIL otherwise."
143 (if (and (objectp x) (objectp y))
144 (if (member y (ls-object-preclist x)) t nil)
145 nil))
147 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
148 ;;;;
149 ;;;; Precedence List Functions
150 ;;;;
151 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
153 (defun find-SC (object)
154 "find set of object and ancestors. (diff from this and find-S?)"
155 (copy-list (ls-object-preclist (check-object object))))
157 (defun find-S (object)
158 "find set of object and ancestors. (diff from this and find-SC?)"
159 (do ((result nil)
160 (parents (ls-object-parents object) (cdr parents)))
161 ((not (consp parents))
162 (delete-duplicates (cons object result)))
163 (setf result (nconc (find-SC (first parents)) result))))
165 (defun find-RC (object)
166 "find local precedence ordering."
167 (let ((list (copy-list (ls-object-parents (check-object object)))))
168 (do ((next list (rest next)))
169 ((not (consp next)) list)
170 (setf (first next) (cons object (first next)))
171 (setf object (rest (first next))))))
173 (defun find-R (S)
174 "find partial precedence ordering."
175 (do ((result nil)
176 (S S (rest S)))
177 ((not (consp S))
178 (delete-duplicates result))
179 (setf result (nconc result (find-RC (first S))))))
181 (defun has-predecessor (x R)
182 "check if x has a predecessor according to R."
183 (dolist (cell R nil)
184 (if (and (consp cell) (eq x (rest cell))) (return t))))
186 (defun find-no-predecessor-list (S R)
187 "find list of objects in S without predecessors, by R."
188 (let ((result nil))
189 (dolist (x S result)
190 (unless (has-predecessor x R) (setf result (cons x result))))))
192 (defun child-position (x P)
193 "find the position of child, if any, of x in P, the list found so
194 far."
195 (let ((count 0))
196 (declare (fixnum count))
197 (dolist (next P -1)
198 (if (member x (ls-object-parents next)) (return count))
199 (incf count))))
201 (defun next-object (no-preds P)
202 "find the next object in the precedence list from objects with no
203 predecessor and current list."
204 (cond
205 ((not (consp no-preds)) nil)
206 ((not (consp (rest no-preds))) (first no-preds))
208 (let ((count -1)
209 (result nil))
210 (declare (fixnum count))
211 (dolist (x no-preds result)
212 (let ((tcount (child-position x P)))
213 (declare (fixnum tcount))
214 (when (> tcount count)
215 (setf result x)
216 (setf count tcount))))))))
218 (defun trim-S (x S)
219 "Remove object x from S."
220 (delete x S))
222 (defun trim-R (x R)
223 "Remove all pairs containing x from R. x is assumed to have no
224 predecessors, so only the first position is checked."
225 (delete x R :key #'first))
227 (defun precedence-list (object)
228 "Calculate the object's precedence list."
229 (do* ((S (find-S object))
230 (R (find-R S))
231 (P nil)
232 (no-preds nil)
233 (next nil))
234 ((not (consp S)) P)
235 (setf no-preds (find-no-predecessor-list S R))
236 (setf next (next-object no-preds P))
237 (if (null next) (error "inconsistent precedence order"))
238 (setf P (nconc P (list next)))
239 (setf S (trim-S next S))
240 (setf R (trim-R next R))))
242 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
243 ;;;;
244 ;;;; Object Construction Functions
245 ;;;;
246 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
248 (defun calculate-preclist (object)
249 "Return the precedence list for the object."
250 (let ((parents (ls-object-parents (check-object object))))
251 (if (not (consp parents)) (error "bad parent list - ~s" parents))
252 (if (consp (rest parents))
253 (precedence-list object)
254 (let ((parent (check-object (first parents))))
255 (cons object (ls-object-preclist parent))))))
257 (defun check-parents (parents)
258 (cond
259 ((or (null parents) (objectp parents)) parents)
260 ((consp parents)
261 (dolist (x parents) (check-object x))
262 (if (has-duplicates parents)
263 (error "parents may not contain duplicates")))
264 (t (error "bad parents - ~s" parents))))
266 (defun make-basic-object (parents object)
267 (check-parents parents)
269 (if (not (objectp object)) (setf object (make-object-structure)))
271 (setf (ls-object-preclist object) (ls-object-preclist *object*))
272 (setf (ls-object-parents object)
273 (cond ((null parents) (list *object*))
274 ((objectp parents) (list parents))
275 (t parents)))
276 (setf (ls-object-preclist object) (calculate-preclist object))
278 object)
280 (defun make-object (&rest parents)
281 "Args: (&rest parents)
282 Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is used."
283 (make-basic-object parents NIL))
285 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
286 ;;;;
287 ;;;; Constraint Hook Functions
288 ;;;;
289 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291 (pushnew :constrainthooks *features*)
293 #+:constrainthooks
294 (progn
295 (defvar *message-hook* nil)
296 (defvar *set-slot-hook* nil)
298 (defun check-constraint-hooks (object sym slot)
299 (let ((hook (if slot *set-slot-hook* *message-hook*)))
300 (if hook
301 (if slot
302 (let ((*set-slot-hook* nil))
303 (funcall hook object sym))
304 (let ((*message-hook* nil))
305 (funcall hook object sym)))))))
307 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
309 ;;; Slot Access Functions
311 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
313 (defun make-slot-entry (x y) (cons x y))
314 (defun slot-entry-p (x) (consp x))
315 (defun slot-entry-key (x) (first x))
316 (defun slot-entry-value (x) (rest x))
317 (defun set-slot-entry-value (x v) (setf (rest x) v))
318 (defsetf slot-entry-value set-slot-entry-value)
320 (defun find-own-slot (x slot)
321 (if (objectp x) (assoc-eq slot (ls-object-slots x))))
323 (defun find-slot (x slot)
324 (if (objectp x)
325 (let ((preclist (ls-object-preclist x)))
326 (dolist (object preclist)
327 (let ((slot-entry (find-own-slot object slot)))
328 (if slot-entry (return slot-entry)))))))
330 (defun add-slot (x slot value)
331 (check-object x)
332 (check-non-nil-symbol slot)
333 (let ((slot-entry (find-own-slot x slot)))
334 (if slot-entry
335 (setf (slot-entry-value slot-entry) value)
336 (setf (ls-object-slots x)
337 (cons (make-slot-entry slot value) (ls-object-slots x)))))
338 nil)
340 (defun delete-slot (x slot)
341 (check-object x)
342 (setf (ls-object-slots x)
343 (delete slot (ls-object-slots x) :key #'slot-entry-key)))
345 (defun get-slot-value (x slot &optional no-err)
346 (check-object x)
347 (let ((slot-entry (find-slot x slot)))
348 (if (slot-entry-p slot-entry)
349 (slot-entry-value slot-entry)
350 (unless no-err (error "no slot named ~s in this object" slot)))))
352 (defun set-slot-value (x slot value)
353 (check-object x)
354 (let ((slot-entry (find-own-slot x slot)))
355 (cond
356 ((slot-entry-p slot-entry)
357 (set-slot-entry-value slot-entry value)
358 #+:constrainthooks (check-constraint-hooks x slot t))
360 (if (find-slot x slot)
361 (error "object does not own slot ~s" slot)
362 (error "no slot named ~s in this object" slot))))))
364 (defun slot-value (slot)
365 "Args: (slot)
366 Must be used in a method. Returns the value of current objects slot
367 named SLOT."
368 (get-slot-value (get-self) slot))
370 (defun slot-value-setf (slot value)
371 (set-slot-value (get-self) slot value))
373 (defsetf slot-value slot-value-setf)
375 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
376 ;;;;
377 ;;;; Method Access Functions;
378 ;;;;
379 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
381 (defun make-method-entry (x y) (cons x y))
382 (defun method-entry-p (x) (consp x))
383 (defun method-entry-key (x) (first x))
384 (defun method-entry-method (x) (rest x))
385 (defun set-method-entry-method (x v) (setf (rest x) v))
386 (defsetf method-entry-method set-method-entry-method)
388 ;(defun find-own-method (x selector)
389 ; (if (objectp x) (assoc selector (ls-object-methods x))))
390 (defun find-own-method (x selector)
391 (if (objectp x) (assoc-eq selector (ls-object-methods x))))
393 (defun find-lsos-method (x selector)
394 (if (objectp x)
395 (let ((preclist (ls-object-preclist x)))
396 (dolist (object preclist)
397 (let ((method-entry (find-own-method object selector)))
398 (if method-entry (return method-entry)))))))
400 (defun add-lsos-method (x selector value)
401 "x = object; selector = name of method; value = form computing the method."
402 (check-object x)
403 (check-non-nil-symbol selector)
404 (let ((method-entry (find-own-method x selector)))
405 (if method-entry
406 (setf (method-entry-method method-entry) value)
407 (setf (ls-object-methods x)
408 (cons (make-method-entry selector value) (ls-object-methods x)))))
409 nil)
411 (defun delete-method (x selector)
412 (check-object x)
413 (setf (ls-object-methods x)
414 (delete selector (ls-object-methods x) :key #'method-entry-key)))
416 (defun get-message-method (x selector &optional no-err)
417 (check-object x)
418 (let ((method-entry (find-lsos-method x selector)))
419 (if (method-entry-p method-entry)
420 (method-entry-method method-entry)
421 (unless no-err (error "no method for selector ~s" selector)))))
423 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
424 ;;;;
425 ;;;; Message Sending Functions
426 ;;;;
427 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
429 (defvar *current-preclist* nil)
430 (defvar *current-selector* nil)
432 (defun sendmsg (object selector preclist args)
433 (let ((method-entry nil)
434 (method nil))
436 ;; look for the message in the precedence list
437 (loop
438 (setf method-entry (find-own-method (first preclist) selector))
439 (if (or method-entry (not (consp preclist))) (return))
440 (setf preclist (rest preclist)))
441 (cond
442 ((null method-entry) (error "no method for selector ~s" selector))
443 ((not (method-entry-p method-entry)) (error "bad method entry"))
444 (t (setf method (method-entry-method method-entry))))
446 ;; invoke the method
447 (let ((*current-preclist* preclist)
448 (*current-selector* selector)
449 (*self* object))
450 (multiple-value-prog1
451 (apply method object args)
452 #+:constrainthooks (check-constraint-hooks object selector nil)))))
454 ;;;; built-in send function
455 (defun send (object selector &rest args)
456 "Args: (object selector &rest args)
457 Applies first method for SELECTOR found in OBJECT's precedence list to
458 OBJECT and ARGS."
459 (sendmsg object selector (ls-object-preclist object) args))
461 ;;;; call-next-method - call inherited version of current method
462 (defun call-next-method (&rest args)
463 "Args (&rest args)
464 Funcalls next method for current selector and precedence list. Can only be
465 used in a method."
466 (sendmsg *self* *current-selector* (rest *current-preclist*) args))
468 ;;;; call-method - call method belonging to another object on current object
470 ;; ugly cruft, need better solution for SBCL packagelocks
471 ;; #+sbcl(declare (sb-ext:disable-package-locks ls-objects:call-method))
473 (defun call-method (object selector &rest args)
474 "Args (object selector &rest args)
475 Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in
476 a method."
477 (sendmsg *self* selector (ls-object-preclist object) args))
479 ;; #+sbcl(declare (sb-ext:enable-package-locks ls-objects:call-method))
481 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
482 ;;;;
483 ;;;; Object Documentation Functions
484 ;;;;
485 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
487 (defun find-documentation (x sym add)
488 (if (objectp x)
489 (let ((doc (find-own-slot x 'documentation)))
490 (if (and (null doc) add) (add-slot x 'documentation nil))
491 (if (slot-entry-p doc) (assoc sym (slot-entry-value doc))))))
493 (defun add-documentation (x sym value)
494 (check-object x)
495 (check-non-nil-symbol sym)
496 (let ((doc-entry (find-documentation x sym t)))
497 (cond
498 ((not (null doc-entry))
499 (setf (rest doc-entry) value))
501 (set-slot-value x
502 'documentation
503 (cons (cons sym value)
504 (get-slot-value x 'documentation))))))
505 nil)
507 (defun get-documentation (x sym)
508 (check-object x)
509 (dolist (object (ls-object-preclist x))
510 ;; (let ((doc-entry (find-documentation x sym nil))) ;; shouldn't object be here somewhere?
511 (let ((doc-entry (find-documentation object sym nil))) ;; FIXME: verify
512 (if doc-entry (return (rest doc-entry))))))
514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
515 ;;;;
516 ;;;; DEFMETH Macro
517 ;;;;
518 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
520 (defmacro defmeth (object name arglist first &rest body)
521 "Syntax: (defmeth object method-name lambda-list [doc] {form}*)
522 OBJECT must evaluate to an existing object. Installs a method for NAME in
523 the value of OBJECT and installs DOC in OBJECTS's documentation.
524 RETURNS: method-name."
525 (if (and body (stringp first))
526 `(progn ;; first=docstring + body
527 (add-lsos-method ,object ,name
528 #'(lambda (self ,@arglist) (block ,name ,@body)))
529 (add-documentation ,object ,name ,first)
530 ,name)
531 `(progn ;; first=code + body
532 (add-lsos-method ,object ,name
533 #'(lambda (self ,@arglist) (block ,name ,first ,@body)))
534 ,name)))
536 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
537 ;;;;
538 ;;;; Prototype Construction Functions and Macros
539 ;;;;
540 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
542 (defun find-instance-slots (x slots)
543 (let ((result (nreverse (delete-duplicates (copy-list slots)))))
544 (dolist (parent (ls-object-parents x) (nreverse result))
545 (dolist (slot (get-slot-value parent 'instance-slots))
546 (pushnew slot result)))))
548 (defun get-initial-slot-value (object slot)
549 (let ((entry (find-slot object slot)))
550 (if (slot-entry-p entry) (slot-entry-value entry))))
552 (defun make-prototype (object name ivars cvars doc set)
553 (setf ivars (find-instance-slots object ivars))
554 (add-slot object 'instance-slots ivars)
555 (add-slot object 'proto-name name)
557 (dolist (slot ivars)
558 (add-slot object slot (get-initial-slot-value object slot)))
560 (dolist (slot cvars)
561 (add-slot object slot nil))
563 (if (and doc (stringp doc))
564 (add-documentation object 'proto doc))
565 (if set (setf (symbol-value name) object)))
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))
573 (namesym (gensym))
574 (parsym (gensym)))
575 `(progn
576 (let* ((,namesym ',name)
577 (,parsym ,parents)
578 (,obsym (make-basic-object (if (listp ,parsym)
579 ,parsym
580 (list ,parsym)) ;; should this be ,@parsym ?
581 nil)))
582 (make-prototype ,obsym ,namesym ,ivars ,cvars ,doc t)
583 ,namesym))))
586 ;; recall:
587 ;; , => turn on evaluation again (not macro substitution)
588 ;; ` =>
589 ;; ' => regular quote (not special in this context).
592 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
593 ;;;;
594 ;;;; Initialize the Root Object
595 ;;;;
596 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
598 (setf (ls-object-preclist *object*) (list *object*))
599 (add-slot *object* 'instance-slots nil)
600 (add-slot *object* 'proto-name '*object*)
601 (add-slot *object* 'documentation nil) ; AJR - for SBCL compiler
602 ; issues about macro with
603 ; unknown slot
605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
606 ;;;;
607 ;;;; *OBJECT* Methods
608 ;;;;
609 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611 (defmeth *object* :isnew (&rest args)
612 "Method args: (&rest args)
613 Checks ARGS for keyword arguments matching slots and uses them to
614 initialize slots."
615 (if args
616 (dolist (slot-entry (ls-object-slots self))
617 (let* ((slot (slot-entry-key slot-entry))
618 (key (intern (symbol-name slot) (find-package 'keyword)))
619 (val (slot-value slot))
620 (new-val (getf args key val)))
621 (unless (eq val new-val) (setf (slot-value slot) new-val)))))
622 self)
624 (defmeth *object* :has-slot (slot &key own)
625 "Method args: (slot &optional own)
626 Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
627 only checks the object; otherwise check the entire precedence list."
628 (let ((entry (if own (find-own-slot self slot) (find-slot self slot))))
629 (if entry t nil)))
631 (defmeth *object* :add-slot (slot &optional value)
632 "Method args: (slot &optional value)
633 Installs slot SLOT in object, if it does not already exist, and
634 sets its value to VLAUE."
635 (add-slot self slot value)
636 value)
638 (defmeth *object* :delete-slot (slot)
639 "Method args: (slot)
640 Deletes slot SLOT from object if it exists."
641 (delete-slot self slot)
642 nil)
644 (defmeth *object* :own-slots ()
645 "Method args: ()
646 Returns list of names of slots owned by object."
647 (mapcar #'slot-entry-key (ls-object-slots self)))
649 (defmeth *object* :has-method (selector &key own)
650 "Method args: (selector &optional own)
651 Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
652 only checks the object; otherwise check the entire precedence list."
653 (let ((entry (if own
654 (find-own-method self selector)
655 (find-lsos-method self selector))))
656 (if entry t nil)))
658 (defmeth *object* :add-method (selector method)
659 "Method args: (selector method)
660 Installs METHOD for SELECTOR in object."
661 (add-lsos-method self selector method)
662 nil)
664 (defmeth *object* :delete-method (selector)
665 "Method args: (selector)
666 Deletes method for SELECTOR in object if it exists."
667 (delete-method self selector)
668 nil)
670 (defmeth *object* :get-method (selector)
671 "Method args: (selector)
672 Returns method for SELECTOR symbol from object's precedence list."
673 (get-message-method self selector))
675 (defmeth *object* :own-methods ()
676 "Method args ()
677 Returns copy of selectors for methods owned by object."
678 (mapcar #'method-entry-key (ls-object-methods self)))
680 (defmeth *object* :parents ()
681 "Method args: ()
682 Returns copy of parents list."
683 (copy-list (ls-object-parents self)))
685 (defmeth *object* :precedence-list ()
686 "Method args: ()
687 Returns copy of the precedence list."
688 (copy-list (ls-object-preclist self)))
690 (defmeth *object* :show (&optional (stream t))
691 "Method Args: ()
692 Prints object's internal data."
693 (format stream "Slots = ~s~%" (ls-object-slots self))
694 (format stream "Methods = ~s~%" (ls-object-methods self))
695 (format stream "Parents = ~s~%" (ls-object-parents self))
696 (format stream "Precedence List = ~s~%" (ls-object-preclist self))
697 nil)
699 (defmeth *object* :reparent (&rest parents)
700 "Method args: (&rest parents)
701 Changes precedence list to correspond to PARENTS. Does not change descendants."
702 (make-basic-object parents self))
704 (defmeth *object* :make-prototype (name &optional ivars)
705 (make-prototype self name ivars nil nil nil)
706 self)
708 (defmeth *object* :internal-doc (sym &optional new)
709 "Method args (topic &optional value)
710 Retrieves or installs documentation for topic."
711 (if new (add-documentation self sym new))
712 (get-documentation self sym))
714 (defmeth *object* :new (&rest args)
715 "Method args: (&rest args)
716 Creates new object using self as prototype."
717 (let* ((object (make-object self)))
718 (if (slot-value 'instance-slots)
719 (dolist (s (slot-value 'instance-slots))
720 (send object :add-slot s (slot-value s))))
721 (apply #'send object :isnew args)
722 object))
724 (defmeth *object* :retype (proto &rest args)
725 "Method args: (proto &rest args)
726 Changes object to inherit directly from prototype PROTO. PROTO
727 must be a prototype and SELF must not be one."
728 (if (send self :has-slot 'instance-slots :own t)
729 (error "can't retype a prototype"))
730 (if (not (send proto :has-slot 'instance-slots :own t))
731 (error "not a prototype - ~a" proto))
732 (send self :reparent proto)
733 (dolist (s (send proto :slot-value 'instance-slots))
734 (send self :add-slot s (slot-value s)))
735 (apply #'send self :isnew args)
736 self)
738 (defmeth *object* :print (&optional (stream *standard-output*))
739 "Method args: (&optional (stream *standard-output*))
740 Default object printing method."
741 (cond
742 ((send self :has-slot 'proto-name)
743 (format stream
744 "#<Object: ~D, prototype = ~A>"
745 (ls-object-serial self)
746 (slot-value 'proto-name)))
747 (t (format stream "#<Object: ~D>" (ls-object-serial self)))))
749 (defmeth *object* :slot-value (sym &optional (val nil set))
750 "Method args: (sym &optional val)
751 Sets and retrieves value of slot named SYM. Signals an error if slot
752 does not exist."
753 ;;(declare (ignore self))
754 (if set (setf (slot-value sym) val))
755 (slot-value sym))
757 (defmeth *object* :slot-names ()
758 "Method args: ()
759 Returns list of slots available to the object."
760 (apply #'append
761 (mapcar #'(lambda (x) (send x :own-slots))
762 (send self :precedence-list))))
764 (defmeth *object* :method-selectors ()
765 "Method args: ()
766 Returns list of method selectors available to object."
767 (apply #'append
768 (mapcar #'(lambda (x) (send x :own-methods))
769 (send self :precedence-list))))
772 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
773 ;;;;
774 ;;;; Object Help Methods
775 ;;;;
776 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
778 (defmeth *object* :doc-topics ()
779 "Method args: ()
780 Returns all topics with documentation for this object."
781 (remove-duplicates
782 (mapcar #'car
783 (apply #'append
784 (mapcar
785 #'(lambda (x)
786 (if (send x :has-slot 'documentation :own t)
787 (send x :slot-value (quote documentation))))
788 (send self :precedence-list))))))
790 (defmeth *object* :documentation (topic &optional (val nil set))
791 "Method args: (topic &optional val)
792 Retrieves or sets object documentation for topic."
793 (if set (send self :internal-doc topic val))
794 (let ((val (dolist (i (send self :precedence-list))
795 (let ((val (send i :internal-doc topic)))
796 (if val (return val))))))
797 val))
799 (defmeth *object* :delete-documentation (topic)
800 "Method args: (topic)
801 Deletes object documentation for TOPIC."
802 (setf (slot-value 'documentation)
803 ;;(remove :title nil :test #'(lambda (x y) (eql x (first y)))) ;; original
804 (remove topic (send self :documentation) :test #'(lambda (x y) (eql x (first y))))) ;; AJR:PROBLEM?
805 nil)
807 (defmeth *object* :help (&optional topic)
808 "Method args: (&optional topic)
809 Prints help message for TOPIC, or genreal help if TOPIC is NIL."
810 (if topic
811 (let ((doc (send self :documentation topic)))
812 (cond
813 (doc (princ topic) (terpri) (princ doc) (terpri))
814 (t (format t "Sorry, no help available on ~a~%" topic))))
815 (let ((topics (stable-sort (copy-seq (send self :doc-topics))
816 #'(lambda (x y)
817 (string-lessp (string x) (string y)))))
818 (proto-doc (send self :documentation 'proto)))
819 (if (send self :has-slot 'proto-name)
820 (format t "~s~%" (slot-value 'proto-name)))
821 (when proto-doc (princ proto-doc) (terpri))
822 (format t "Help is available on the following:~%~%")
823 (dolist (i topics) (format t "~s " i))
824 (terpri)))
825 (values))
827 (defmeth *object* :compile-method (name)
828 "Method args: (name)
829 Compiles method NAME unless it is already compiled. The object must
830 own the method."
831 (unless (send self :has-method name)
832 (error "No ~s method in this object" name))
833 (unless (send self :has-method name :own t)
834 (error "Object does not own ~s method" name))
835 (let ((fun (send self :get-method name)))
836 (unless (compiled-function-p fun)
837 (multiple-value-bind (form env) (function-lambda-expression fun)
838 (if env
839 (error
840 "method may have been defined in non-null environment"))
841 (send self :add-method name (compile nil form))))))