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