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