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