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