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