defvar to fix var unknowns, declared away some obvious unused vars, but still need...
[CommonLispStat.git] / lsobjects.lsp
blob50e603e4988382cf9ff69984db9fe89401814ae9
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 defproto2
66 instance-slots proto-name))
68 (in-package :lisp-stat-object-system)
70 (defun use-lsos ()
71 "Formerly set up to import lisp-stat-object-system into current package."
72 (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
73 (use-package 'lisp-stat-object-system))
75 ;;; Structure Implementation of Lisp-Stat Object System
77 ;; We might consider a global rewrite if it doesn't seem to break
78 ;; anything. In particular, the real name ought to be
79 ;; proto-sys-object or similar so that we can ensure that the right
80 ;; interpretation is made for this. Call it the prototype object
81 ;; system, and possibly be done with it then.
83 (defvar *object-serial* 0)
85 (defstruct (ls-object
86 (:constructor make-object-structure) ;; why not make-ls-object?
87 (:print-function print-object-structure)
88 (:predicate objectp)) ;; why not ls-object-p?
89 slots
90 methods
91 parents
92 preclist ;; precedence list
93 (serial (incf *object-serial*)))
95 (defun print-object-structure (object stream depth)
96 (declare (ignore depth))
97 (send object :print stream))
99 (setf (documentation 'objectp 'function)
100 "Args: (x)
101 Returns T if X is an object, NIL otherwise.")
103 (defvar *object* (make-object-structure)
104 "*object* is the global root object.")
106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107 ;;;;
108 ;;;; Utilities
109 ;;;;
110 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
112 ;;;
113 ;;; AJR:FIXME:Is this going to cause issues with concurrency/threading?
114 ;;; (need to appropriately handle interrupts).
115 (defvar *self* nil
116 "special variable to hold current value of SELF.
117 Assign to current object that we are working with.")
119 (defun get-self ()
120 "FIXME? better as macro?."
121 (if (not (objectp *self*))
122 (error "not in a method"))
123 *self*)
125 (defun has-duplicates (list)
126 "predicate: takes a list, and returns true if duplicates.
127 This should be simpler, right?"
128 (do ((next list (rest next)))
129 ((not (consp next)) nil)
130 (if (member (first next) (rest next)) (return t))))
132 (defun assoc-eq (item alist)
133 "Version of assoc using eq -- should be faster than regular assoc."
134 (declare (inline car eq))
135 (dolist (i alist)
136 (if (eq (car i) item) (return i))))
138 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
140 ;;; Predicates for Consistency Checking
142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
144 (defun check-non-nil-symbol (x)
145 (unless (and x (symbolp x)) (error "bad symbol - ~s" x)))
147 (defun check-object (x)
148 "Returns self if true, throws an error otherwise."
149 (if (objectp x) x (error "bad object - ~s" x)))
151 (defun kind-of-p (x y)
152 "Args: (x y)
153 Returns T if X and Y are objects and X inherits from Y, NIL otherwise."
154 (if (and (objectp x) (objectp y))
155 (if (member y (ls-object-preclist x)) t nil)
156 nil))
158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
159 ;;;;
160 ;;;; Precedence List Functions
161 ;;;;
162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
164 (defun find-SC (object)
165 "find set of object and ancestors. (diff from this and find-S?)"
166 (copy-list (ls-object-preclist (check-object object))))
168 (defun find-S (object)
169 "find set of object and ancestors. (diff from this and find-SC?)"
170 (do ((result nil)
171 (parents (ls-object-parents object) (cdr parents)))
172 ((not (consp parents))
173 (delete-duplicates (cons object result)))
174 (setf result (nconc (find-SC (first parents)) result))))
176 (defun find-RC (object)
177 "find local precedence ordering."
178 (let ((list (copy-list (ls-object-parents (check-object object)))))
179 (do ((next list (rest next)))
180 ((not (consp next)) list)
181 (setf (first next) (cons object (first next)))
182 (setf object (rest (first next))))))
184 (defun find-R (S)
185 "find partial precedence ordering."
186 (do ((result nil)
187 (S S (rest S)))
188 ((not (consp S))
189 (delete-duplicates result))
190 (setf result (nconc result (find-RC (first S))))))
192 (defun has-predecessor (x R)
193 "check if x has a predecessor according to R."
194 (dolist (cell R nil)
195 (if (and (consp cell) (eq x (rest cell))) (return t))))
197 (defun find-no-predecessor-list (S R)
198 "find list of objects in S without predecessors, by R."
199 (let ((result nil))
200 (dolist (x S result)
201 (unless (has-predecessor x R) (setf result (cons x result))))))
203 (defun child-position (x P)
204 "find the position of child, if any, of x in P, the list found so
205 far."
206 (let ((count 0))
207 (declare (fixnum count))
208 (dolist (next P -1)
209 (if (member x (ls-object-parents next)) (return count))
210 (incf count))))
212 (defun next-object (no-preds P)
213 "find the next object in the precedence list from objects with no
214 predecessor and current list."
215 (cond
216 ((not (consp no-preds)) nil)
217 ((not (consp (rest no-preds))) (first no-preds))
219 (let ((count -1)
220 (result nil))
221 (declare (fixnum count))
222 (dolist (x no-preds result)
223 (let ((tcount (child-position x P)))
224 (declare (fixnum tcount))
225 (when (> tcount count)
226 (setf result x)
227 (setf count tcount))))))))
229 (defun trim-S (x S)
230 "Remove object x from S."
231 (delete x S))
233 (defun trim-R (x R)
234 "Remove all pairs containing x from R. x is assumed to have no
235 predecessors, so only the first position is checked."
236 (delete x R :key #'first))
238 (defun precedence-list (object)
239 "Calculate the object's precedence list."
240 (do* ((S (find-S object))
241 (R (find-R S))
242 (P nil)
243 (no-preds nil)
244 (next nil))
245 ((not (consp S)) P)
246 (setf no-preds (find-no-predecessor-list S R))
247 (setf next (next-object no-preds P))
248 (if (null next) (error "inconsistent precedence order"))
249 (setf P (nconc P (list next)))
250 (setf S (trim-S next S))
251 (setf R (trim-R next R))))
253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
254 ;;;;
255 ;;;; Object Construction Functions
256 ;;;;
257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
259 (defun calculate-preclist (object)
260 "Return the precedence list for the object."
261 (let ((parents (ls-object-parents (check-object object))))
262 (if (not (consp parents)) (error "bad parent list - ~s" parents))
263 (if (consp (rest parents))
264 (precedence-list object)
265 (let ((parent (check-object (first parents))))
266 (cons object (ls-object-preclist parent))))))
268 (defun check-parents (parents)
269 "Ensure valid parents: They must be null, object, or consp without duplicates."
270 (cond
271 ((or (null parents) (objectp parents)) parents)
272 ((consp parents)
273 (dolist (x parents) (check-object x))
274 (if (has-duplicates parents)
275 (error "parents may not contain duplicates")))
276 (t (error "bad parents - ~s" parents))))
278 (defun make-basic-object (parents object)
279 "Creates a basic object for the prototype system by ensuring that it
280 can be placed into the storage heirarchy.
281 If object is not initialized, instantiate the structure.
282 Place into parental structure.
283 If parents is null, use root *object*,
284 if parents is a single object, use it (encapsulate as list)
285 otherwise, use parents"
287 (check-parents parents)
289 (if (not (objectp object)) (setf object (make-object-structure)))
291 (setf (ls-object-preclist object) (ls-object-preclist *object*))
292 (setf (ls-object-parents object)
293 (cond ((null parents) (list *object*))
294 ((objectp parents) (list parents))
295 (t parents)))
296 (setf (ls-object-preclist object) (calculate-preclist object))
298 object)
300 (defun make-object (&rest parents)
301 "Args: (&rest parents)
302 Returns a new object with parents PARENTS. If PARENTS is NIL, (list *OBJECT*) is used."
303 (make-basic-object parents NIL))
305 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
306 ;;;;
307 ;;;; Constraint Hook Functions
308 ;;;;
309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
311 (pushnew :constrainthooks *features*)
313 #+:constrainthooks
314 (progn
315 (defvar *message-hook* nil)
316 (defvar *set-slot-hook* nil)
318 (defun check-constraint-hooks (object sym slot)
319 (let ((hook (if slot *set-slot-hook* *message-hook*)))
320 (if hook
321 (if slot
322 (let ((*set-slot-hook* nil))
323 (funcall hook object sym))
324 (let ((*message-hook* nil))
325 (funcall hook object sym)))))))
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
329 ;;; Slot Access Functions
331 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
333 (defun make-slot-entry (x y) (cons x y))
334 (defun slot-entry-p (x) (consp x))
335 (defun slot-entry-key (x) (first x))
336 (defun slot-entry-value (x) (rest x))
337 (defun set-slot-entry-value (x v) (setf (rest x) v))
338 (defsetf slot-entry-value set-slot-entry-value)
340 (defun find-own-slot (x slot)
341 (if (objectp x) (assoc-eq slot (ls-object-slots x))))
343 (defun find-slot (x slot)
344 (if (objectp x)
345 (let ((preclist (ls-object-preclist x)))
346 (dolist (object preclist)
347 (let ((slot-entry (find-own-slot object slot)))
348 (if slot-entry (return slot-entry)))))))
350 (defun add-slot (x slot value)
351 (check-object x)
352 (check-non-nil-symbol slot)
353 (let ((slot-entry (find-own-slot x slot)))
354 (if slot-entry
355 (setf (slot-entry-value slot-entry) value)
356 (setf (ls-object-slots x)
357 (cons (make-slot-entry slot value) (ls-object-slots x)))))
358 nil)
360 (defun delete-slot (x slot)
361 (check-object x)
362 (setf (ls-object-slots x)
363 (delete slot (ls-object-slots x) :key #'slot-entry-key)))
365 (defun get-slot-value (x slot &optional no-err)
366 (check-object x)
367 (let ((slot-entry (find-slot x slot)))
368 (if (slot-entry-p slot-entry)
369 (slot-entry-value slot-entry)
370 (unless no-err (error "no slot named ~s in this object" slot)))))
372 (defun set-slot-value (x slot value)
373 (check-object x)
374 (let ((slot-entry (find-own-slot x slot)))
375 (cond
376 ((slot-entry-p slot-entry)
377 (set-slot-entry-value slot-entry value)
378 #+:constrainthooks (check-constraint-hooks x slot t))
380 (if (find-slot x slot)
381 (error "object does not own slot ~s" slot)
382 (error "no slot named ~s in this object" slot))))))
384 (defun slot-value (slot)
385 "Args: (slot)
386 Must be used in a method. Returns the value of current objects slot
387 named SLOT."
388 (get-slot-value (get-self) slot))
390 (defun slot-value-setf (slot value)
391 (set-slot-value (get-self) slot value))
393 (defsetf slot-value slot-value-setf)
395 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
396 ;;;;
397 ;;;; Method Access Functions;
398 ;;;;
399 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
401 (defun make-method-entry (x y) (cons x y))
402 (defun method-entry-p (x) (consp x))
403 (defun method-entry-key (x) (first x))
404 (defun method-entry-method (x) (rest x))
405 (defun set-method-entry-method (x v) (setf (rest x) v))
406 (defsetf method-entry-method set-method-entry-method)
408 (defun find-own-method (x selector)
409 (if (objectp x) (assoc-eq selector (ls-object-methods x)))) ;; prev was assoc not assoc-eq
411 (defun find-lsos-method (x selector)
412 (if (objectp x)
413 (let ((preclist (ls-object-preclist x)))
414 (dolist (object preclist)
415 (let ((method-entry (find-own-method object selector)))
416 (if method-entry (return method-entry)))))))
418 (defun add-lsos-method (x selector value)
419 "x = object; selector = name of method; value = form computing the method."
420 (check-object x)
421 (check-non-nil-symbol selector)
422 (let ((method-entry (find-own-method x selector)))
423 (if method-entry
424 (setf (method-entry-method method-entry) value)
425 (setf (ls-object-methods x)
426 (cons (make-method-entry selector value) (ls-object-methods x)))))
427 nil)
429 (defun delete-method (x selector)
430 (check-object x)
431 (setf (ls-object-methods x)
432 (delete selector (ls-object-methods x) :key #'method-entry-key)))
434 (defun get-message-method (x selector &optional no-err)
435 (check-object x)
436 (let ((method-entry (find-lsos-method x selector)))
437 (if (method-entry-p method-entry)
438 (method-entry-method method-entry)
439 (unless no-err (error "no method for selector ~s" selector)))))
441 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
443 ;;; Message Sending Functions
445 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
447 (defvar *current-preclist* nil)
448 (defvar *current-selector* nil)
450 (defun sendmsg (object selector preclist args)
451 (let ((method-entry nil)
452 (method nil))
454 ;; look for the message in the precedence list
455 (loop
456 (setf method-entry (find-own-method (first preclist) selector))
457 (if (or method-entry (not (consp preclist))) (return))
458 (setf preclist (rest preclist)))
459 (cond
460 ((null method-entry) (error "no method for selector ~s" selector))
461 ((not (method-entry-p method-entry)) (error "bad method entry"))
462 (t (setf method (method-entry-method method-entry))))
464 ;; invoke the method
465 (let ((*current-preclist* preclist)
466 (*current-selector* selector)
467 (*self* object))
468 (multiple-value-prog1
469 (apply method object args)
470 #+:constrainthooks (check-constraint-hooks object selector nil)))))
472 ;;;; built-in send function
473 (defun send (object selector &rest args)
474 "Args: (object selector &rest args)
475 Applies first method for SELECTOR found in OBJECT's precedence list to
476 OBJECT and ARGS."
477 (sendmsg object selector (ls-object-preclist object) args))
479 ;;;; call-next-method - call inherited version of current method
480 (defun call-next-method (&rest args)
481 "Args (&rest args)
482 Funcalls next method for current selector and precedence list. Can only be
483 used in a method."
484 (sendmsg *self* *current-selector* (rest *current-preclist*) args))
486 (defun call-method (object selector &rest args)
487 "Args (object selector &rest args)
488 Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in
489 a method.
490 Call method belonging to another object on current object."
491 (sendmsg *self* selector (ls-object-preclist object) args))
493 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
495 ;;; Object Documentation
497 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
499 (defun find-documentation (x sym add)
500 (if (objectp x)
501 (let ((doc (find-own-slot x 'documentation)))
502 (if (and (null doc) add) (add-slot x 'documentation nil))
503 (if (slot-entry-p doc) (assoc sym (slot-entry-value doc))))))
505 (defun add-documentation (x sym value)
506 (check-object x)
507 (check-non-nil-symbol sym)
508 (let ((doc-entry (find-documentation x sym t)))
509 (cond
510 ((not (null doc-entry))
511 (setf (rest doc-entry) value))
513 (set-slot-value x
514 'documentation
515 (cons (cons sym value)
516 (get-slot-value x 'documentation))))))
517 nil)
519 (defun get-documentation (x sym)
520 (check-object x)
521 (dolist (object (ls-object-preclist x))
522 (let ((doc-entry (find-documentation object sym nil))) ;; FIXME: verify
523 (if doc-entry (return (rest doc-entry))))))
525 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
526 ;;;;
527 ;;;; DEFMETH Macro
528 ;;;;
529 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
531 (defmacro defmeth (object name arglist first &rest body)
532 "Syntax: (defmeth object method-name lambda-list [doc] {form}*)
533 OBJECT must evaluate to an existing object. Installs a method for NAME in
534 the value of OBJECT and installs DOC in OBJECTS's documentation.
535 RETURNS: method-name."
536 (declare (ignorable self)) ;; hints for the compiler that sometimes it isn't used
537 (if (and body (stringp first))
538 `(progn ;; first=docstring + body
539 (add-lsos-method ,object ,name
540 #'(lambda (self ,@arglist) (block ,name ,@body)))
541 (add-documentation ,object ,name ,first)
542 ,name)
543 `(progn ;; first=code + body
544 (add-lsos-method ,object ,name
545 #'(lambda (self ,@arglist) (block ,name ,first ,@body)))
546 ,name)))
548 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
550 ;;; Prototype Construction
552 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
554 (defun find-instance-slots (x slots)
555 (let ((result (nreverse (delete-duplicates (copy-list slots)))))
556 (dolist (parent (ls-object-parents x) (nreverse result))
557 (dolist (slot (get-slot-value parent 'instance-slots))
558 (pushnew slot result)))))
560 (defun get-initial-slot-value (object slot)
561 (let ((entry (find-slot object slot)))
562 (if (slot-entry-p entry) (slot-entry-value entry))))
564 (defun make-prototype (object name ivars cvars doc set)
565 (setf ivars (find-instance-slots object ivars))
566 (add-slot object 'instance-slots ivars)
567 (add-slot object 'proto-name name)
568 (dolist (slot ivars)
569 (add-slot object slot (get-initial-slot-value object slot)))
570 (dolist (slot cvars)
571 (add-slot object slot nil))
573 (if (and doc (stringp doc))
574 (add-documentation object 'proto doc))
575 (if set (setf (symbol-value name) object)))
578 (defmacro defproto (name &optional ivars cvars parents doc)
579 "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
580 Makes a new object prototype with instantiated/set variables IVARS,
581 'class' variables CVARS (class or 'cleared'??)) and parents
582 PARENT. PARENT can be a single object or a list of objects. IVARS and
583 CVARS must be lists."
584 (let ((obsym (gensym))
585 (namesym (gensym))
586 (parsym (gensym)))
587 `(progn
588 (let* ((,namesym ',name)
589 (,parsym ,parents)
590 (,obsym (make-basic-object (if (listp ,parsym)
591 ,parsym
592 (list ,parsym)) ;; should this be ,@parsym ?
593 nil)))
594 (make-prototype ,obsym ,namesym ,ivars ,cvars ,doc t)
595 ,namesym))))
598 ;; Infrastructure for new defproto from Common-Lisp Cookbook! Thanks!
600 ;(defmacro odd-define (name buildargs)
601 ; `(progn (defun ,(build-symbol make-a- (:< name))
602 ; ,buildargs
603 ; (vector ,(length buildargs) ',name ,@buildargs))
604 ; (defun ,(build-symbol test-whether- (:< name)) (x)
605 ; (and (vectorp x) (eq (aref x 1) ',name))
606 ; (defun ,(build-symbol (:< name) -copy) (x)
607 ; ...)
608 ; (defun ,(build-symbol (:< name) -deactivate) (x)
609 ; ...))))
611 ;(defmacro for (listspec exp)
612 ; (cond ((and (= (length listspec) 3)
613 ; (symbolp (car listspec))
614 ; (eq (cadr listspec) ':in))
615 ; `(mapcar (lambda (,(car listspec))
616 ; ,exp)
617 ; ,(caddr listspec)))
618 ; (t (error "Ill-formed: ~s" `(for ,listspec ,exp)))))
620 ;(defmacro symstuff (l)
621 ; `(concatenate 'string
622 ; ,@(for (x :in l)
623 ; (cond ((stringp x)
624 ; `',x)
625 ; ((atom x)
626 ; `',(format nil "~a" x))
627 ; ((eq (car x) ':<)
628 ; `(format nil "~a" ,(cadr x)))
629 ; ((eq (car x) ':++)
630 ; `(format nil "~a" (incf ,(cadr x))))
631 ; (t
632 ; `(format nil "~a" ,x))))))
634 ;(defmacro build-symbol (&rest l)
635 ; (let ((p (find-if (lambda (x)
636 ; (and (consp x)
637 ; (eq (car x) ':package)))
638 ; l)))
639 ; (cond (p
640 ; (setq l (remove p l))))
641 ; (let ((pkg (cond ((eq (cadr p) 'nil)
642 ; nil)
643 ; (t `(find-package ',(cadr p))))))
644 ; (cond (p
645 ; (cond (pkg
646 ; `(values (intern ,(symstuff l) ,pkg)))
647 ; (t
648 ; `(make-symbol ,(symstuff l)))))
649 ; (t
650 ; `(values (intern ,(symstuff l))))))))
652 (defmacro defproto2 (name &optional ivars cvars parents doc)
653 "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
654 Makes a new object prototype with instance variables IVARS, 'class'
655 variables CVARS and parents PARENT. PARENT can be a single object or
656 a list of objects. IVARS and CVARS must be lists."
657 (if (boundp name)
658 (error "can not rebind a prototype object yet")
659 (let ((namesym (gensym))
660 (obsym (gensym))
661 (parsym (gensym)))
662 `(progn
663 (let* ((,namesym ,name)
664 (,parsym ,parents)
665 (,obsym (make-basic-object
666 (if (listp ,parsym)
667 ,parsym
668 (list ,@parsym)) ;; should this be ,@parsym ?
669 nil)))
670 (make-prototype ,obsym ,name ,ivars ,cvars ,doc t)
671 ,name)))))
673 ;; recall:
674 ;; , => turn on evaluation again (not macro substitution)
675 ;; ` => template comes (use , to undo template and restore eval
676 ;; ' => regular quote (not special in this context), 'ted => (quote ted)
679 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
681 ;;; Initialize the Root Object
683 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
685 (setf (ls-object-preclist *object*) (list *object*))
686 (add-slot *object* 'instance-slots nil)
687 (add-slot *object* 'proto-name '*object*)
688 (add-slot *object* 'documentation nil) ; AJR - for SBCL compiler
689 ; issues about macro with
690 ; unknown slot
692 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
694 ;;; *OBJECT* Methods
696 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
698 (defmeth *object* :isnew (&rest args)
699 "Method args: (&rest args)
700 Checks ARGS for keyword arguments matching slots and uses them to
701 initialize slots."
702 (if args
703 (dolist (slot-entry (ls-object-slots self))
704 (let* ((slot (slot-entry-key slot-entry))
705 (key (intern (symbol-name slot) (find-package 'keyword)))
706 (val (slot-value slot))
707 (new-val (getf args key val)))
708 (unless (eq val new-val) (setf (slot-value slot) new-val)))))
709 self)
711 (defmeth *object* :has-slot (slot &key own)
712 "Method args: (slot &optional own)
713 Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
714 only checks the object; otherwise check the entire precedence list."
715 (let ((entry (if own (find-own-slot self slot) (find-slot self slot))))
716 (if entry t nil)))
718 (defmeth *object* :add-slot (slot &optional value)
719 "Method args: (slot &optional value)
720 Installs slot SLOT in object, if it does not already exist, and
721 sets its value to VLAUE."
722 (add-slot self slot value)
723 value)
725 (defmeth *object* :delete-slot (slot)
726 "Method args: (slot)
727 Deletes slot SLOT from object if it exists."
728 (delete-slot self slot)
729 nil)
731 (defmeth *object* :own-slots ()
732 "Method args: ()
733 Returns list of names of slots owned by object."
734 (mapcar #'slot-entry-key (ls-object-slots self)))
736 (defmeth *object* :has-method (selector &key own)
737 "Method args: (selector &optional own)
738 Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
739 only checks the object; otherwise check the entire precedence list."
740 (let ((entry (if own
741 (find-own-method self selector)
742 (find-lsos-method self selector))))
743 (if entry t nil)))
745 (defmeth *object* :add-method (selector method)
746 "Method args: (selector method)
747 Installs METHOD for SELECTOR in object."
748 (add-lsos-method self selector method)
749 nil)
751 (defmeth *object* :delete-method (selector)
752 "Method args: (selector)
753 Deletes method for SELECTOR in object if it exists."
754 (delete-method self selector)
755 nil)
757 (defmeth *object* :get-method (selector)
758 "Method args: (selector)
759 Returns method for SELECTOR symbol from object's precedence list."
760 (get-message-method self selector))
762 (defmeth *object* :own-methods ()
763 "Method args ()
764 Returns copy of selectors for methods owned by object."
765 (mapcar #'method-entry-key (ls-object-methods self)))
767 (defmeth *object* :parents ()
768 "Method args: ()
769 Returns copy of parents list."
770 (copy-list (ls-object-parents self)))
772 (defmeth *object* :precedence-list ()
773 "Method args: ()
774 Returns copy of the precedence list."
775 (copy-list (ls-object-preclist self)))
777 (defmeth *object* :show (&optional (stream t))
778 "Method Args: ()
779 Prints object's internal data."
780 (format stream "Slots = ~s~%" (ls-object-slots self))
781 (format stream "Methods = ~s~%" (ls-object-methods self))
782 (format stream "Parents = ~s~%" (ls-object-parents self))
783 (format stream "Precedence List = ~s~%" (ls-object-preclist self))
784 nil)
786 (defmeth *object* :reparent (&rest parents)
787 "Method args: (&rest parents)
788 Changes precedence list to correspond to PARENTS. Does not change descendants."
789 (make-basic-object parents self))
791 (defmeth *object* :make-prototype (name &optional ivars)
792 (make-prototype self name ivars nil nil nil)
793 self)
795 (defmeth *object* :internal-doc (sym &optional new)
796 "Method args (topic &optional value)
797 Retrieves or installs documentation for topic."
798 (if new (add-documentation self sym new))
799 (get-documentation self sym))
801 (defmeth *object* :new (&rest args)
802 "Method args: (&rest args)
803 Creates new object using self as prototype."
804 (let* ((object (make-object self)))
805 (if (slot-value 'instance-slots)
806 (dolist (s (slot-value 'instance-slots))
807 (send object :add-slot s (slot-value s))))
808 (apply #'send object :isnew args)
809 object))
811 (defmeth *object* :retype (proto &rest args)
812 "Method args: (proto &rest args)
813 Changes object to inherit directly from prototype PROTO. PROTO
814 must be a prototype and SELF must not be one."
815 (if (send self :has-slot 'instance-slots :own t)
816 (error "can't retype a prototype"))
817 (if (not (send proto :has-slot 'instance-slots :own t))
818 (error "not a prototype - ~a" proto))
819 (send self :reparent proto)
820 (dolist (s (send proto :slot-value 'instance-slots))
821 (send self :add-slot s (slot-value s)))
822 (apply #'send self :isnew args)
823 self)
825 (defmeth *object* :print (&optional (stream *standard-output*))
826 "Method args: (&optional (stream *standard-output*))
827 Default object printing method."
828 (cond
829 ((send self :has-slot 'proto-name)
830 (format stream
831 "#<Object: ~D, prototype = ~A>"
832 (ls-object-serial self)
833 (slot-value 'proto-name)))
834 (t (format stream "#<Object: ~D>" (ls-object-serial self)))))
836 (defmeth *object* :slot-value (sym &optional (val nil set))
837 "Method args: (sym &optional val)
838 Sets and retrieves value of slot named SYM. Signals an error if slot
839 does not exist."
840 (if set (setf (slot-value sym) val))
841 (slot-value sym))
843 (defmeth *object* :slot-names ()
844 "Method args: ()
845 Returns list of slots available to the object."
846 (apply #'append
847 (mapcar #'(lambda (x) (send x :own-slots))
848 (send self :precedence-list))))
850 (defmeth *object* :method-selectors ()
851 "Method args: ()
852 Returns list of method selectors available to object."
853 (apply #'append
854 (mapcar #'(lambda (x) (send x :own-methods))
855 (send self :precedence-list))))
858 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
859 ;;;;
860 ;;;; Object Help Methods
861 ;;;;
862 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
864 (defmeth *object* :doc-topics ()
865 "Method args: ()
866 Returns all topics with documentation for this object."
867 (remove-duplicates
868 (mapcar #'car
869 (apply #'append
870 (mapcar
871 #'(lambda (x)
872 (if (send x :has-slot 'documentation :own t)
873 (send x :slot-value (quote documentation))))
874 (send self :precedence-list))))))
876 (defmeth *object* :documentation (topic &optional (val nil set))
877 "Method args: (topic &optional val)
878 Retrieves or sets object documentation for topic."
879 (if set (send self :internal-doc topic val))
880 (let ((val (dolist (i (send self :precedence-list))
881 (let ((val (send i :internal-doc topic)))
882 (if val (return val))))))
883 val))
885 (defmeth *object* :delete-documentation (topic)
886 "Method args: (topic)
887 Deletes object documentation for TOPIC."
888 (setf (slot-value 'documentation)
889 ;;(remove :title nil :test #'(lambda (x y) (eql x (first y)))) ;; original
890 (remove topic (send self :documentation) :test #'(lambda (x y) (eql x (first y))))) ;; AJR:PROBLEM?
891 nil)
893 (defmeth *object* :help (&optional topic)
894 "Method args: (&optional topic)
895 Prints help message for TOPIC, or genreal help if TOPIC is NIL."
896 (if topic
897 (let ((doc (send self :documentation topic)))
898 (cond
899 (doc (princ topic) (terpri) (princ doc) (terpri))
900 (t (format t "Sorry, no help available on ~a~%" topic))))
901 (let ((topics (stable-sort (copy-seq (send self :doc-topics))
902 #'(lambda (x y)
903 (string-lessp (string x) (string y)))))
904 (proto-doc (send self :documentation 'proto)))
905 (if (send self :has-slot 'proto-name)
906 (format t "~s~%" (slot-value 'proto-name)))
907 (when proto-doc (princ proto-doc) (terpri))
908 (format t "Help is available on the following:~%~%")
909 (dolist (i topics) (format t "~s " i))
910 (terpri)))
911 (values))
913 (defmeth *object* :compile-method (name)
914 "Method args: (name)
915 Compiles method NAME unless it is already compiled. The object must
916 own the method."
917 (unless (send self :has-method name)
918 (error "No ~s method in this object" name))
919 (unless (send self :has-method name :own t)
920 (error "Object does not own ~s method" name))
921 (let ((fun (send self :get-method name)))
922 (unless (compiled-function-p fun)
923 (multiple-value-bind (form env) (function-lambda-expression fun)
924 (if env
925 (error
926 "method may have been defined in non-null environment"))
927 (send self :add-method name (compile nil form))))))