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