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