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