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