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