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