lsobjects.lsp

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