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