lsobjects.lsp

   1 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   3 ;;;;
   4 ;;;;                    LISP-STAT Object System
   5 ;;;;
   6 ;;;;
   7 ;;;; Simple CL implementation of the object system for Lisp-Stat (LSOS)
   8 ;;;; as described in Tierney (1990).
   9 ;;;;
  10 ;;;; Copyright (c) 1991, by Luke Tierney. Permission is granted for
  11 ;;;; unrestricted use.
  12 ;;;;
  13 ;;;;
  14 ;;;; NOTES:
  15 ;;;;
  16 ;;;;    If your CL's handling of packages is compliant with CLtL, 2nd
  17 ;;;;    Edition (like Macintosh CL version 2), add the feature :CLtL2
  18 ;;;;    before loading or compiling this code.
  19 ;;;;
  20 ;;;;    This implementation does not make use of CLOS. It can coexist
  21 ;;;;    with CLOS, but there are two name conflicts: slot-value and
  22 ;;;;    call-next-method. These two symbols are shadowed in the LSOS
  23 ;;;;    package and must be shadowed in any package that uses LSOS.
  24 ;;;;    Evaluating the function (lsos::use-lsos) from a package after
  25 ;;;;    loading this code shadows these two symbols and does a
  26 ;;;;    use-package for LSOS.
  27 ;;;;
  28 ;;;;    The :compile-method method uses function-lambda-expression
  29 ;;;;    defined in CLtL, 2nd Edition. (This method is only needed if
  30 ;;;;    you want to force compilation of an interpreted method. It is
  31 ;;;;    not used by the compiler.)
  32 ;;;;
  33 ;;;;    The efficiency of this code could be improved by low level
  34 ;;;;    coding of the dispatching functions send, call-method and
  35 ;;;;    call-next-method to avoid creating an argument list. Other
  36 ;;;;    efficiency improvements are possible as well, in particular
  37 ;;;;    by good use of declarations. It may also be possible to build
  38 ;;;;    a more efficient implementation using the CLOS metaclass
  39 ;;;;    protocol.
  40 ;;;;
  41 ;;;;    There are a few minimal tools for experimenting with constraints
  42 ;;;;    in the code; they are marked by #+:constreinthooks. Sometime
  43 ;;;;    soon I hope to augment or replace these hooks with a CORAL-like
  44 ;;;;    constraint system (as used in GARNET).
  45 ;;;;
  46 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  47 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  48
  49 (provide "lsobjects")
  50
  51 ;;;;
  52 ;;;; Package Setup
  53 ;;;;
  54
  55 #+:CLtL2
  56 (progn
  57   (defpackage "LISP-STAT-OBJECT-SYSTEM"
  58     (:nicknames "LS-OBJECTS" "LSOS")
  59     (:use "COMMON-LISP")
  60     (:shadow "CALL-NEXT-METHOD" "SLOT-VALUE"))
  61
  62   (in-package lisp-stat-object-system))
  63
  64 #-:CLtL2
  65 (progn
  66   (in-package 'lisp-stat-object-system
  67               :nicknames '(ls-objects lsos)
  68               :use '(lisp))
  69
  70   (shadow '(call-next-method slot-value)))
  71
  72 (export '(ls-object objectp *object* kind-of-p make-object *message-hook*
  73           *set-slot-hook* slot-value self send call-next-method call-method
  74           defmeth defproto instance-slots proto-name))
  75
  76 (defun use-lsos ()
  77   (shadowing-import (package-shadowing-symbols 'lisp-stat-object-system))
  78   (use-package 'lisp-stat-object-system))
  79
  80 ;;;;
  81 ;;;; Structure Implementation of Lisp-Stat Object System
  82 ;;;;
  83
  84 (defvar *object-serial* 0)
  85
  86 (defstruct (ls-object
  87             (:constructor make-object-structure)
  88             (:print-function print-object-structure)
  89             (:predicate objectp))
  90   slots
  91   methods
  92   parents
  93   preclist
  94   (serial (incf *object-serial*)))
  95
  96 (defun print-object-structure (object stream 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
 105 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 106 ;;;;
 107 ;;;;                          Utility Functions
 108 ;;;;
 109 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 110
 111 ;;;; special variable to hold current value of SELF
 112 (defvar *self* nil)
 113
 114 (defun get-self ()
 115   (if (not (objectp *self*)) (error "not in a method"))
 116   *self*)
 117
 118 (defun has-duplicates (list)
 119   (do ((next list (rest next)))
 120       ((not (consp next)) nil)
 121     (if (member (first next) (rest next)) (return t))))
 122
 123 ;;; version of assoc using eq -- should be faster than regular assoc
 124 (defun assoc-eq (item alist)
 125   (declare (inline car eq))
 126   (dolist (i alist)
 127     (if (eq (car i) item) (return i))))
 128
 129 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 130 ;;;;
 131 ;;;;               Predicate and Checking Functions
 132 ;;;;
 133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 134
 135 (defun check-non-nil-symbol (x)
 136   (unless (and x (symbolp x)) (error "bad symbol - ~s" x)))
 137
 138 (defun check-object (x)
 139   (if (objectp x) x (error "bad object - ~s" x)))
 140
 141 (defun kind-of-p (x y)
 142 "Args: (x y)
 143 Returns T is X and Y are objects and X inherits from Y, NIL otherwise."
 144   (if (and (objectp x) (objectp y))
 145       (if (member y (ls-object-preclist x)) t nil)
 146       nil))
 147
 148 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 149 ;;;;
 150 ;;;;                     Precedence List Functions
 151 ;;;;
 152 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 153
 154 ;;;; find set of object and ancestors
 155 (defun find-SC (object)
 156   (copy-list (ls-object-preclist (check-object object))))
 157
 158 ;;;; find set of object and ancestors
 159 (defun find-S (object)
 160   (do ((result nil)
 161        (parents (ls-object-parents object) (cdr parents)))
 162       ((not (consp parents))
 163        (delete-duplicates (cons object result)))
 164     (setf result (nconc (find-SC (first parents)) result))))
 165
 166 ;;;; find local precedence ordering
 167 (defun find-RC (object)
 168   (let ((list (copy-list (ls-object-parents (check-object object)))))
 169     (do ((next list (rest next)))
 170         ((not (consp next)) list)
 171       (setf (first  next) (cons object (first next)))
 172       (setf object (rest (first next))))))
 173
 174 ;;;; find partial precedence ordering
 175 (defun find-R (S)
 176   (do ((result nil)
 177        (S S (rest S)))
 178       ((not (consp S))
 179        (delete-duplicates result))
 180     (setf result (nconc result (find-RC (first S))))))
 181
 182 ;;;; check if x has a predecessor according to R
 183 (defun has-predecessor (x R)
 184   (dolist (cell R nil)
 185     (if (and (consp cell) (eq x (rest cell))) (return t))))
 186
 187 ;;;; find list of objects in S without predecessors, by R
 188 (defun find-no-predecessor-list (S R)
 189   (let ((result nil))
 190     (dolist (x S result)
 191       (unless (has-predecessor x R) (setf result (cons x result))))))
 192
 193 ;;;; find the position of child, if any, of x in P, the list found so far
 194 (defun child-position (x P)
 195   (let ((count 0))
 196     (declare (fixnum count))
 197     (dolist (next P -1)
 198       (if (member x (ls-object-parents next)) (return count))
 199       (incf count))))
 200
 201 ;;;; find the next object in the precedence list from objects with no
 202 ;;;; predecessor and current list.
 203 (defun next-object (no-preds P)
 204   (cond
 205    ((not (consp no-preds)) nil)
 206    ((not (consp (rest no-preds))) (first no-preds))
 207    (t
 208     (let ((count -1)
 209           (result nil))
 210       (declare (fixnum count))
 211       (dolist (x no-preds result)
 212         (let ((tcount (child-position x P)))
 213           (declare (fixnum tcount))
 214           (when (> tcount count)
 215             (setf result x)
 216             (setf count tcount))))))))
 217
 218 ;;;; remove object x from S
 219 (defun trim-S (x S) (delete x S))
 220
 221 ;;;; remove all pairs containing x from R. x is assumed to have no
 222 ;;;; predecessors, so only the first position is checked.
 223 (defun trim-R (x R) (delete x R :key #'first))
 224
 225 ;;;; calculat the object's precedence list
 226 (defun precedence-list (object)
 227   (do* ((S (find-S object))
 228         (R (find-R S))
 229         (P nil)
 230         (no-preds nil)
 231         (next nil))
 232        ((not (consp S)) P)
 233     (setf no-preds (find-no-predecessor-list S R))
 234     (setf next (next-object no-preds P))
 235     (if (null next) (error "inconsistent precedence order"))
 236     (setf P (nconc P (list next)))
 237     (setf S (trim-S next S))
 238     (setf R (trim-R next R))))
 239
 240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 241 ;;;;
 242 ;;;;                 Object Construction Functions
 243 ;;;;
 244 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 245
 246 (defun calculate-preclist (object)
 247   (let ((parents (ls-object-parents (check-object object))))
 248     (if (not (consp parents)) (error "bad parent list - ~s" parents))
 249     (if (consp (rest parents))
 250         (precedence-list object)
 251         (let ((parent (check-object (first parents))))
 252           (cons object (ls-object-preclist parent))))))
 253
 254 (defun check-parents (parents)
 255   (cond
 256    ((or (null parents) (objectp parents)) parents)
 257    ((consp parents)
 258     (dolist (x parents) (check-object x))
 259     (if (has-duplicates parents) (error "parents may not contain duplicates")))
 260    (t (error "bad parents - ~s" parents))))
 261
 262 (defun make-basic-object (parents object)
 263   (check-parents parents)
 264
 265   (if (not (objectp object)) (setf object (make-object-structure)))
 266
 267   (setf (ls-object-preclist object) (ls-object-preclist *object*))
 268   (setf (ls-object-parents object)
 269         (cond ((null parents) (list *object*))
 270               ((objectp parents) (list parents))
 271               (t parents)))
 272   (setf (ls-object-preclist object) (calculate-preclist object))
 273
 274   object)
 275
 276 (defun make-object (&rest parents)
 277 "Args: (&rest parents)
 278 Returns a new object with parents PARENTS. If PARENTS is NIL,
 279 (list *OBJECT*) is used."
 280   (make-basic-object parents NIL))
 281
 282 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 283 ;;;;
 284 ;;;;                   Constraint Hook Functions
 285 ;;;;
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287
 288 (pushnew :constrainthooks *features*)
 289 #+:constrainthooks (defvar *message-hook* nil)
 290 #+:constrainthooks (defvar *set-slot-hook* nil)
 291
 292 #+:constrainthooks
 293 (defun check-constraint-hooks (object sym slot)
 294   (let ((hook (if slot *set-slot-hook* *message-hook*)))
 295     (if hook
 296       (if slot
 297         (let ((*set-slot-hook* nil))
 298           (funcall hook object sym))
 299         (let ((*message-hook* nil))
 300           (funcall hook object sym))))))
 301
 302 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 303 ;;;;
 304 ;;;;                     Slot Access Functions
 305 ;;;;
 306 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 307
 308 (defun make-slot-entry (x y) (cons x y))
 309 (defun slot-entry-p (x) (consp x))
 310 (defun slot-entry-key (x) (first x))
 311 (defun slot-entry-value (x) (rest x))
 312 (defun set-slot-entry-value (x v) (setf (rest x) v))
 313 (defsetf slot-entry-value set-slot-entry-value)
 314
 315 (defun find-own-slot (x slot)
 316   (if (objectp x) (assoc-eq slot (ls-object-slots x))))
 317
 318 (defun find-slot (x slot)
 319   (if (objectp x)
 320     (let ((preclist (ls-object-preclist x)))
 321       (dolist (object preclist)
 322         (let ((slot-entry (find-own-slot object slot)))
 323           (if slot-entry (return slot-entry)))))))
 324
 325 (defun add-slot (x slot value)
 326   (check-object x)
 327   (check-non-nil-symbol slot)
 328   (let ((slot-entry (find-own-slot x slot)))
 329     (if slot-entry
 330       (setf (slot-entry-value slot-entry) value)
 331       (setf (ls-object-slots x)
 332             (cons (make-slot-entry slot value) (ls-object-slots x)))))
 333   nil)
 334
 335 (defun delete-slot (x slot)
 336   (check-object x)
 337   (setf (ls-object-slots x)
 338         (delete slot (ls-object-slots x) :key #'slot-entry-key)))
 339
 340 (defun get-slot-value (x slot &optional no-err)
 341   (check-object x)
 342   (let ((slot-entry (find-slot x slot)))
 343     (if (slot-entry-p slot-entry)
 344       (slot-entry-value slot-entry)
 345       (unless no-err (error "no slot named ~s in this object" slot)))))
 346
 347 (defun set-slot-value (x slot value)
 348   (check-object x)
 349   (let ((slot-entry (find-own-slot x slot)))
 350     (cond
 351      ((slot-entry-p slot-entry)
 352       (set-slot-entry-value slot-entry value)
 353       #+:constrainthooks (check-constraint-hooks x slot t))
 354      (t
 355       (if (find-slot x slot)
 356         (error "object does not own slot ~s" slot)
 357         (error "no slot named ~s in this object" slot))))))
 358
 359 (defun slot-value (slot)
 360 "Args: (slot)
 361 Must be used in a method. Returns the value of current objects slot
 362 named SLOT."
 363   (get-slot-value (get-self) slot))
 364
 365 (defun slot-value-setf (slot value)
 366   (set-slot-value (get-self) slot value))
 367
 368 (defsetf slot-value slot-value-setf)
 369
 370 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 371 ;;;;
 372 ;;;;                   Method Access Functions;
 373 ;;;;
 374 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 375
 376 (defun make-method-entry (x y) (cons x y))
 377 (defun method-entry-p (x) (consp x))
 378 (defun method-entry-key (x) (first x))
 379 (defun method-entry-method (x) (rest x))
 380 (defun set-method-entry-method (x v) (setf (rest x) v))
 381 (defsetf method-entry-method set-method-entry-method)
 382
 383 ;(defun find-own-method (x selector)
 384 ;  (if (objectp x) (assoc selector (ls-object-methods x))))
 385 (defun find-own-method (x selector)
 386   (if (objectp x) (assoc-eq selector (ls-object-methods x))))
 387
 388 (defun find-lsos-method (x selector)
 389   (if (objectp x)
 390     (let ((preclist (ls-object-preclist x)))
 391       (dolist (object preclist)
 392         (let ((method-entry (find-own-method object selector)))
 393           (if method-entry (return method-entry)))))))
 394
 395 (defun add-lsos-method (x selector value)
 396   (check-object x)
 397   (check-non-nil-symbol selector)
 398   (let ((method-entry (find-own-method x selector)))
 399     (if method-entry
 400       (setf (method-entry-method method-entry) value)
 401       (setf (ls-object-methods x)
 402             (cons (make-method-entry selector value) (ls-object-methods x)))))
 403   nil)
 404
 405 (defun delete-method (x selector)
 406   (check-object x)
 407   (setf (ls-object-methods x)
 408         (delete selector (ls-object-methods x) :key #'method-entry-key)))
 409
 410 (defun get-message-method (x selector &optional no-err)
 411   (check-object x)
 412   (let ((method-entry (find-lsos-method x selector)))
 413     (if (method-entry-p method-entry)
 414       (method-entry-method method-entry)
 415       (unless no-err (error "no method for selector ~s" selector)))))
 416
 417 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 418 ;;;;
 419 ;;;;                   Message Sending Functions
 420 ;;;;
 421 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 422
 423 (defvar *current-preclist* nil)
 424 (defvar *current-selector* nil)
 425
 426 (defun sendmsg (object selector preclist args)
 427   (let ((method-entry nil)
 428         (method nil))
 429
 430     ;; look for the message in the precedence list
 431     (loop
 432       (setf method-entry (find-own-method (first preclist) selector))
 433       (if (or method-entry (not (consp preclist))) (return))
 434       (setf preclist (rest preclist)))
 435     (cond
 436      ((null method-entry) (error "no method for selector ~s" selector))
 437      ((not (method-entry-p method-entry)) (error "bad method entry"))
 438      (t (setf method (method-entry-method method-entry))))
 439
 440     ;; invoke the method
 441     (let ((*current-preclist* preclist)
 442           (*current-selector* selector)
 443           (*self* object))
 444       (multiple-value-prog1
 445         (apply method object args)
 446         #+:constrainthooks (check-constraint-hooks object selector nil)))))
 447
 448 ;;;; built-in send function
 449 (defun send (object selector &rest args)
 450 "Args: (object selector &rest args)
 451 Applies first method for SELECTOR found in OBJECT's precedence list to
 452 OBJECT and ARGS."
 453   (sendmsg object selector (ls-object-preclist object) args))
 454
 455 ;;;; call-next-method - call inherited version of current method
 456 (defun call-next-method (&rest args)
 457 "Args (&rest args)
 458 Funcalls next method for current selector and precedence list. Can only be
 459 used in a method."
 460   (sendmsg *self* *current-selector* (rest *current-preclist*) args))
 461
 462 ;;;; call-method - call method belonging to another object on current object
 463 (defun call-method (object selector &rest args)
 464 "Args (object selector &rest args)
 465 Funcalls method for SELECTOR found in OBJECT to SELF. Can only be used in
 466 a method."
 467   (sendmsg *self* selector (ls-object-preclist object) args))
 468
 469 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 470 ;;;;
 471 ;;;;                  Object Documentation Functions
 472 ;;;;
 473 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 474
 475 (defun find-documentation (x sym add)
 476   (if (objectp x)
 477     (let ((doc (find-own-slot x 'documentation)))
 478       (if (and (null doc) add) (add-slot x 'documentation nil))
 479       (if (slot-entry-p doc) (assoc sym (slot-entry-value doc))))))
 480
 481 (defun add-documentation (x sym value)
 482   (check-object x)
 483   (check-non-nil-symbol sym)
 484   (let ((doc-entry (find-documentation x sym t)))
 485     (cond
 486      ((not (null doc-entry))
 487       (setf (rest doc-entry) value))
 488      (t
 489       (set-slot-value x
 490                       'documentation
 491                       (cons (cons sym value)
 492                             (get-slot-value x 'documentation))))))
 493   nil)
 494
 495 (defun get-documentation (x sym)
 496   (check-object x)
 497   (dolist (object (ls-object-preclist x))
 498     (let ((doc-entry (find-documentation x sym nil)))
 499       (if doc-entry (return (rest doc-entry))))))
 500
 501 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 502 ;;;;
 503 ;;;;                         DEFMETH Macro
 504 ;;;;
 505 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 506
 507 (defmacro defmeth (object name arglist first &rest body)
 508 "Syntax: (defmeth object name lambda-list [doc] {form}*)
 509 OBJECT must evaluate to an existing object. Installs a method for NAME in
 510 the value of OBJECT and installs DOC in OBJECTS's documentation."
 511   (if (and body (stringp first))
 512     `(progn
 513        (add-lsos-method ,object ,name
 514                  #'(lambda (self ,@arglist) (block ,name ,@body)))
 515        (add-documentation ,object ,name ,first)
 516        ,name)
 517     `(progn
 518        (add-lsos-method ,object ,name
 519                    #'(lambda (self ,@arglist) (block ,name ,first ,@body)))
 520        ,name)))
 521
 522 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 523 ;;;;
 524 ;;;;             Prototype Construction Functions and Macros
 525 ;;;;
 526 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 527
 528 (defun find-instance-slots (x slots)
 529   (let ((result (nreverse (delete-duplicates (copy-list slots)))))
 530     (dolist (parent (ls-object-parents x) (nreverse result))
 531       (dolist (slot (get-slot-value parent 'instance-slots))
 532         (pushnew slot result)))))
 533
 534 (defun get-initial-slot-value (object slot)
 535   (let ((entry (find-slot object slot)))
 536     (if (slot-entry-p entry) (slot-entry-value entry))))
 537
 538 (defun make-prototype (object name ivars cvars doc set)
 539   (setf ivars (find-instance-slots object ivars))
 540   (add-slot object 'instance-slots ivars)
 541   (add-slot object 'proto-name name)
 542
 543   (dolist (slot ivars)
 544     (add-slot object slot (get-initial-slot-value object slot)))
 545
 546   (dolist (slot cvars)
 547     (add-slot object slot nil))
 548
 549   (if (and doc (stringp doc))
 550     (add-documentation object 'proto doc))
 551
 552   (if set (set name object)))
 553
 554 (defmacro defproto (name &optional ivars cvars parents doc)
 555 "Syntax (defproto name &optional ivars cvars (parent *object*) doc)
 556 Makes a new object prototype with instance variables IVARS, 'class'
 557 variables CVARS and parents PARENT. PARENT can be a single object or
 558 a list of objects. IVARS and CVARS must be lists."
 559   (let ((obsym (gensym))
 560         (namesym (gensym))
 561         (parsym (gensym)))
 562     `(progn
 563        (let* ((,namesym ',name)
 564               (,parsym ,parents)
 565               (,obsym (make-basic-object (if (listp ,parsym)
 566                                            ,parsym
 567                                            (list ,parsym))
 568                                          nil)))
 569          (make-prototype ,obsym ,namesym ,ivars ,cvars ,doc t)
 570         ,namesym))))
 571
 572 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 573 ;;;;
 574 ;;;;                   Initialize the Root Object
 575 ;;;;
 576 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 577
 578 (setf (ls-object-preclist *object*) (list *object*))
 579 (add-slot *object* 'instance-slots nil)
 580 (add-slot *object* 'proto-name '*object*)
 581
 582 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 583 ;;;;
 584 ;;;;                       *OBJECT* Methods
 585 ;;;;
 586 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 587
 588 (defmeth *object* :isnew (&rest args)
 589 "Method args: (&rest args)
 590 Checks ARGS for keyword arguments matching slots and uses them to
 591 initialize slots."
 592   (if args
 593     (dolist (slot-entry (ls-object-slots self))
 594       (let* ((slot (slot-entry-key slot-entry))
 595              (key (intern (symbol-name slot) (find-package 'keyword)))
 596              (val (slot-value slot))
 597              (new-val (getf args key val)))
 598         (unless (eq val new-val) (setf (slot-value slot) new-val)))))
 599   self)
 600
 601 (defmeth *object* :has-slot (slot &key own)
 602 "Method args: (slot &optional own)
 603 Returns T if slot SLOT exists, NIL if not. If OWN is not NIL
 604 only checks the object; otherwise check the entire precedence list."
 605   (let ((entry (if own (find-own-slot self slot) (find-slot self slot))))
 606     (if entry t nil)))
 607
 608 (defmeth *object* :add-slot (slot &optional value)
 609 "Method args: (slot &optional value)
 610 Installs slot SLOT in object, if it does not already exist, and
 611 sets its value to VLAUE."
 612   (add-slot self slot value)
 613   value)
 614
 615 (defmeth *object* :delete-slot (slot)
 616 "Method args: (slot)
 617 Deletes slot SLOT from object if it exists."
 618   (delete-slot self slot)
 619   nil)
 620
 621 (defmeth *object* :own-slots ()
 622 "Method args: ()
 623 Returns list of names of slots owned by object."
 624   (mapcar #'slot-entry-key (ls-object-slots self)))
 625
 626 (defmeth *object* :has-method (selector &key own)
 627 "Method args: (selector &optional own)
 628 Returns T if method for SELECTOR exists, NIL if not. If OWN is not NIL
 629 only checks the object; otherwise check the entire precedence list."
 630   (let ((entry (if own
 631                  (find-own-method self selector)
 632                  (find-lsos-method self selector))))
 633     (if entry t nil)))
 634
 635 (defmeth *object* :add-method (selector method)
 636 "Method args: (selector method)
 637 Installs METHOD for SELECTOR in object."
 638   (add-lsos-method self selector method)
 639   nil)
 640
 641 (defmeth *object* :delete-method (selector)
 642 "Method args: (selector)
 643 Deletes method for SELECTOR in object if it exists."
 644   (delete-method self selector)
 645   nil)
 646
 647 (defmeth *object* :get-method (selector)
 648 "Method args: (selector)
 649 Returns method for SELECTOR symbol from object's precedence list."
 650   (get-message-method self selector))
 651
 652 (defmeth *object* :own-methods ()
 653 "Method args ()
 654 Returns copy of selectors for methods owned by object."
 655   (mapcar #'method-entry-key (ls-object-methods self)))
 656
 657 (defmeth *object* :parents ()
 658 "Method args: ()
 659 Returns copy of parents list."
 660   (copy-list (ls-object-parents self)))
 661
 662 (defmeth *object* :precedence-list ()
 663 "Method args: ()
 664 Returns copy of the precedence list."
 665   (copy-list (ls-object-preclist self)))
 666
 667 (defmeth *object* :show (&optional (stream t))
 668 "Method Args: ()
 669 Prints object's internal data."
 670   (format stream "Slots = ~s~%" (ls-object-slots self))
 671   (format stream "Methods = ~s~%" (ls-object-methods self))
 672   (format stream "Parents = ~s~%" (ls-object-parents self))
 673   (format stream "Precedence List  = ~s~%" (ls-object-preclist self))
 674   nil)
 675
 676 (defmeth *object* :reparent (&rest parents)
 677 "Method args: (&rest parents)
 678 Changes precedence list to correspond to PARENTS. Does not change descendants."
 679   (make-basic-object parents self))
 680
 681 (defmeth *object* :make-prototype (name &optional ivars)
 682   (make-prototype self name ivars nil nil nil)
 683   self)
 684
 685 (defmeth *object* :internal-doc (sym &optional new)
 686 "Method args (topic &optional value)
 687 Retrieves or installs documentation for topic."
 688   (if new (add-documentation self sym new))
 689   (get-documentation self sym))
 690
 691 (defmeth *object* :new (&rest args)
 692 "Method args: (&rest args)
 693 Creates new object using self as prototype."
 694   (let* ((object (make-object self)))
 695     (if (slot-value 'instance-slots)
 696         (dolist (s (slot-value 'instance-slots))
 697                 (send object :add-slot s (slot-value s))))
 698     (apply #'send object :isnew args)
 699     object))
 700
 701 (defmeth *object* :retype (proto &rest args)
 702 "Method args: (proto &rest args)
 703 Changes object to inherit directly from prototype PROTO. PROTO
 704 must be a prototype and SELF must not be one."
 705   (if (send self :has-slot 'instance-slots :own t)
 706       (error "can't retype a prototype"))
 707   (if (not (send proto :has-slot 'instance-slots :own t))
 708       (error "not a prototype - ~a" proto))
 709   (send self :reparent proto)
 710   (dolist (s (send proto :slot-value 'instance-slots))
 711     (send self :add-slot s (slot-value s)))
 712   (apply #'send self :isnew args)
 713   self)
 714
 715 (defmeth *object* :print (&optional (stream *standard-output*))
 716 "Method args: (&optional (stream *standard-output*))
 717 Default object printing method."
 718   (cond
 719     ((send self :has-slot 'proto-name)
 720      (format stream
 721              "#<Object: ~D, prototype = ~A>"
 722              (ls-object-serial self)
 723              (slot-value 'proto-name)))
 724     (t (format stream "#<Object: ~D>" (ls-object-serial self)))))
 725
 726 (defmeth *object* :slot-value (sym &optional (val nil set))
 727 "Method args: (sym &optional val)
 728 Sets and retrieves value of slot named SYM. Sugnals an error if slot
 729 does not exist."
 730   (if set (setf (slot-value sym) val))
 731   (slot-value sym))
 732
 733 (defmeth *object* :slot-names ()
 734 "Method args: ()
 735 Returns list of slots available to the object."
 736   (apply #'append
 737          (mapcar #'(lambda (x) (send x :own-slots))
 738                  (send self :precedence-list))))
 739
 740 (defmeth *object* :method-selectors ()
 741 "Method args: ()
 742 Returns list of method selectors available to object."
 743   (apply #'append
 744          (mapcar #'(lambda (x) (send x :own-methods))
 745                  (send self :precedence-list))))
 746
 747
 748 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 749 ;;;;
 750 ;;;;                      Object Help Methods
 751 ;;;;
 752 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 753
 754 (defmeth *object* :doc-topics ()
 755 "Method args: ()
 756 Returns all topics with documentation for this object."
 757   (remove-duplicates
 758    (mapcar #'car
 759            (apply #'append
 760                   (mapcar
 761                    #'(lambda (x)
 762                        (if (send x :has-slot 'documentation :own t)
 763                            (send x :slot-value (quote documentation))))
 764                    (send self :precedence-list))))))
 765
 766 (defmeth *object* :documentation (topic &optional (val nil set))
 767 "Method args: (topic &optional val)
 768 Retrieves or sets object documentation for topic."
 769   (if set (send self :internal-doc topic val))
 770   (let ((val (dolist (i (send self :precedence-list))
 771                      (let ((val (send i :internal-doc topic)))
 772                        (if val (return val))))))
 773     val))
 774
 775 (defmeth *object* :delete-documentation (topic)
 776 "Method args: (topic)
 777 Deletes object documentation for TOPIC."
 778   (setf (slot-value 'documentation)
 779         (remove :title nil :test #'(lambda (x y) (eql x (first y)))))
 780   nil)
 781
 782 (defmeth *object* :help (&optional topic)
 783 "Method args: (&optional topic)
 784 Prints help message for TOPIC, or genreal help if TOPIC is NIL."
 785   (if topic
 786       (let ((doc (send self :documentation topic)))
 787         (cond
 788           (doc (princ topic) (terpri) (princ doc) (terpri))
 789           (t (format t "Sorry, no help available on ~a~%" topic))))
 790       (let ((topics (stable-sort (copy-seq (send self :doc-topics))
 791                                  #'(lambda (x y)
 792                                      (string-lessp (string x) (string y)))))
 793             (proto-doc (send self :documentation 'proto)))
 794         (if (send self :has-slot 'proto-name)
 795             (format t "~s~%" (slot-value 'proto-name)))
 796         (when proto-doc (princ proto-doc) (terpri))
 797         (format t "Help is available on the following:~%~%")
 798         (dolist (i topics) (format t "~s " i))
 799         (terpri)))
 800   (values))
 801
 802 (defmeth *object* :compile-method (name)
 803 "Method args: (name)
 804 Compiles method NAME unless it is already compiled. The object must
 805 own the method."
 806   (unless (send self :has-method name)
 807           (error "No ~s method in this object" name))
 808   (unless (send self :has-method name :own t)
 809           (error "Object does not own ~s method" name))
 810   (let ((fun (send self :get-method name)))
 811     (unless (compiled-function-p fun)
 812             (multiple-value-bind (form env) (function-lambda-expression fun)
 813                  (if env
 814                      (error
 815                       "method may have been defined in non-null environment"))
 816                  (send self :add-method name (compile nil form))))))