lsobjects.lsp

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