distribute.lisp

   1 ;;;-----------------------------------------------------------------------------------
   2 ;;; name       : distribute
   3 ;;; description: Metaclasses and classes necessary to distribute objects across several
   4 ;;;              object spaces. Most important are:
   5 ;;;              Metaclass mobile-object-class. Instances of Classes of this Metaclass
   6 ;;;              can be moved from one object space to another. At class definition you
   7 ;;;              specify, which content of the object stays when the object is moved, and
   8 ;;;              which content follows.
   9 ;;;              Class Proxy. Proxies work as remote references to objects in other object
  10 ;;;              spaces. When a pargeneric or a slot access is applied to a proxy, it gets
  11 ;;;              forwarded to the object the proxy points to.
  12 ;;; notes      : I have to define proxies for future to be able to use futures as arguments
  13 ;;;              for remote calls. But using futures as arguments to methods is problematic,
  14 ;;;              because of correct method-dispatch (how can you use the result-type for
  15 ;;;              dispatch?). So I will tackle this problem later (hehe, *much* later in fact).
  16 ;;; contact    : me (Michael Trowe)
  17 ;;; copyright  :
  18 ;;; history    :
  19 ;;; contents   :
  20 ;;;-----------------------------------------------------------------------------------
  21 (in-package nc)
  22
  23 ;;;;-------------------------------------------------
  24 ;;;; classes
  25 ;;;;-------------------------------------------------
  26
  27 ;;; metaclasses for mobile-objects
  28 ;;;-------------------------------
  29 (defclass mobile-object-class (standard-class)
  30   ()
  31   (:documentation "Instances of this class are classes which instances can be moved
  32                    and accessed remotely."))
  33
  34 (defclass mobile-direct-slot-definition (standard-direct-slot-definition)
  35   ((moving-behavior :initarg :moving-behavior :initform ()
  36          :accessor slot-definition-moving-behavior)))
  37
  38 (defclass mobile-effective-slot-definition (standard-effective-slot-definition)
  39   ((moving-behavior :accessor slot-definition-moving-behavior)))
  40
  41
  42 ;;; metaclasses for proxies
  43 ;;;-------------------------------
  44
  45 (defclass proxy-class (standard-class)
  46   ())
  47
  48 (defclass effective-local-slot-definition (standard-effective-slot-definition)
  49   ())
  50
  51 (defclass effective-remote-slot-definition (standard-effective-slot-definition)
  52   ())
  53
  54 ;; need to validate superclass proxy-class for proxy
  55 (defmethod validate-superclass ((class proxy-class) (superclass standard-class))
  56   t)
  57
  58 ;;; the superclasses for proxies and mobile-objects
  59 ;;;------------------------------------------------
  60 (defclass proxy (concurrency-obj)
  61   ((remote-address :accessor remote-address
  62                    :initarg :remote-address)
  63    (remote-os :accessor remote-os
  64               :initarg :remote-os)
  65    (masterclass-name :accessor masterclass-name
  66                      :initarg :masterclass-name)
  67    (master-pack-string :accessor master-pack-string)
  68    (other-pack-string :accessor other-pack-string))
  69   (:metaclass proxy-class))
  70
  71 (defclass mobile-object ()
  72   ((object-lock :reader object-lock
  73                 :initform (acl-compat-mp:make-process-lock))))
  74
  75
  76 ;;; generic-functions that aslo work on proxies
  77 ;;;--------------------------------------------
  78 (defclass ncl-gf (sending-gf)
  79   ()
  80   (:metaclass funcallable-standard-class))
  81
  82 (defclass ncl-setf (ncl-gf setf-gf)
  83   ()
  84   (:metaclass funcallable-standard-class))
  85
  86 ;;;--------------------------------------------------------
  87 ;;; PROXIES
  88 ;;;--------------------------------------------------------
  89
  90
  91
  92 ;;; creation and initialization of proxies.
  93 ;;;-----------------------------------------
  94
  95 (defun make-proxy (masterclass-name address objspace)
  96   (make-instance (ensure-proxy-class masterclass-name)
  97     :remote-address address
  98     :remote-os objspace
  99     :masterclass-name masterclass-name))
 100
 101 (let ((proxy-classes (make-hash-table)))
 102   (setf (gethash 'function proxy-classes) (find-class 'proxy))
 103   (defun ensure-proxy-class (masterclass-name)
 104     (cond ((gethash masterclass-name proxy-classes))
 105           ((subtypep masterclass-name 'function) (find-class 'proxy))
 106           (t (setf (gethash masterclass-name proxy-classes)
 107                (make-instance (ensure-proxy-class-class (class-of (find-class masterclass-name)))
 108                  :name (intern (format nil "~a~a"
 109                                        "PROXY-"
 110                                        (symbol-name masterclass-name)))
 111                  :direct-superclasses (list (find-class 'proxy)
 112                                             (find-class masterclass-name))))
 113              (setf (find-class (class-name (gethash masterclass-name proxy-classes)))
 114                (gethash masterclass-name proxy-classes))
 115              ))))
 116
 117 (defun ensure-proxy-class-class (masterclass-metaclass-name)
 118   (class-name
 119    (ensure-class
 120     (intern (format nil "~a~a"
 121                     "PROXY-METACLASS-"
 122                     (symbol-name (class-name masterclass-metaclass-name))))
 123     :direct-superclasses (list (find-class 'proxy-class)
 124                                (find-class (class-name masterclass-metaclass-name))))))
 125
 126 ;;; Der initialisierungs-prozess wird unterbunden, da proxies nur stellvertreter sind
 127 (defmethod initialize-instance :around ((proxy proxy)
 128                                       &rest initargs)
 129   (setf (remote-address proxy) (second (member :remote-address initargs)))
 130   (setf (remote-os proxy) (second (member :remote-os initargs)))
 131   (setf (masterclass-name proxy) (second (member :masterclass-name initargs)))
 132   (setf (other-pack-string proxy) (format nil "(np ~a '~a (fos \"~a\"))"
 133                                            (remote-address proxy)
 134                                            (format nil "~S" (masterclass-name proxy))
 135                                            (host (remote-os proxy))))
 136   (setf (master-pack-string proxy) (format nil "(fetch-obj  ~a)"
 137                                            (remote-address proxy)))
 138   proxy)
 139
 140 ;;; erst nach erzeugung des proxies in objectstore
 141 (defmethod initialize-local-slots ((proxy proxy))
 142   (let ((local-slot-names (local-slot-names (class-of proxy))))
 143     (loop for local-slot-name in local-slot-names do
 144           (setf (slot-value proxy local-slot-name)
 145             (get-slot-value-from-original-object proxy local-slot-name)))))
 146
 147
 148 ;;; analog zu slot-value-using-class (s.u.) nur hier genau einmal beim Erzeugen
 149 ;;; des proxies.
 150 (defun get-slot-value-from-original-object (proxy local-slot-name)
 151   ;;; klappt noch nicht, da verklemmung entsteht, wie?
 152   ;;;(send-now proxy *current-actor* 'slot-value local-slot-name)
 153   ;;; daher nehme initform
 154   (initial-slot-value proxy local-slot-name))
 155
 156
 157
 158 (defmethod initial-slot-value (class slot)
 159   nil)
 160
 161
 162
 163 ;;; kann ueberdefiniert werden, um spezielle Slots eines Proxies lokal auf jedem client
 164 ;;; zu halten (makro/Kennzeichnung noch notwendig ums deklarativ zu machen)
 165
 166 (defmethod local-slot-names ((class t))
 167   nil)
 168
 169 (defmethod local-slot-names ((class proxy-class))
 170   (if (next-method-p)
 171       (call-next-method)
 172     nil))
 173
 174 (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
 175   (let ((existing-definition-class (call-next-method))
 176         (new-class
 177          (find-class (let ((name (second (member :name initargs))))
 178                        (if (or (eq name 'remote-address)
 179                                (eq name 'remote-os)
 180                                (eq name 'masterclass-name)
 181                                (eq name 'master-pack-string)
 182                                (eq name 'other-pack-string)
 183                                (find name (local-slot-names class))
 184                                )
 185                            'effective-local-slot-definition
 186                          'effective-remote-slot-definition)))))
 187     (if (not (eq existing-definition-class (find-class 'standard-effective-slot-definition)))
 188         (ensure-new-slot-definition-class existing-definition-class
 189                                               new-class)
 190       new-class)))
 191
 192
 193
 194 (defmethod initialize-instance :around ((slot effective-remote-slot-definition)
 195                                         &rest initargs)
 196   (apply #'call-next-method
 197          slot
 198          :initfunction ()
 199                                         ;:allocation :ignore
 200                                         ;This is as bug according to the MOP-Definition,
 201                                         ;You should be able to use allocations other then
 202                                         ; :instance or :class. But it conforms with CLtL2.
 203          :initargs ()
 204          initargs))
 205
 206
 207
 208 ;;; the three modes of sending a message to a remote object
 209 ;;; -------------------------------------------------------
 210
 211 (defmethod send-future ((proxy proxy) caller method &rest args)
 212   (send-request (remote-os proxy)
 213                 (remote-address proxy)
 214                 caller
 215                 method
 216                 args))
 217
 218 (defmethod send-past ((proxy proxy) caller method &rest args)
 219   (send-operation  (remote-os proxy)
 220                    (remote-address proxy)
 221                    caller
 222                    method
 223                    args))
 224
 225 (defmethod send-now ((proxy proxy) caller method &rest args)
 226   (touch (send-request (remote-os proxy)
 227                        (remote-address proxy)
 228                        caller
 229                        method
 230                        args)))
 231
 232
 233 ;;; locking can't be handled as a normal method whena pplied to a proxy.
 234 ;;; That's because protected objects (the objects that can be locked) specialize
 235 ;;; send-now, so this special method would be used for sending, and wouldn't work.
 236 ;;;-------------------------------------------------------------------------------
 237 (defmethod lock ((proxy proxy))
 238   (touch (send-request (remote-os proxy)
 239                         (remote-address proxy)
 240                         *current-actor*
 241                         'lock
 242                         ())))
 243
 244 (defmethod unlock ((proxy proxy))
 245   (touch (send-request (remote-os proxy)
 246                         (remote-address proxy)
 247                         *current-actor*
 248                         'unlock
 249                         ())))
 250
 251
 252 ;;; These slot accessor methods may not work with code also using the MOP. The alternative is to
 253 ;;; work with reader and writer gf's, but that is pretty inefficient, because it is
 254 ;;; difficult to constrain the effect just to proxies.
 255 ;;; -------------------------------------------------------------------------------------------
 256 (defmethod slot-definition-initfunction ((slot effective-remote-slot-definition))
 257   ())
 258
 259 (defmethod slot-value-using-class ((class proxy-class) (proxy proxy)
 260                                    (slot effective-remote-slot-definition))
 261   (send-now proxy *current-actor* 'slot-value (slot-definition-name slot)))
 262
 263 (defmethod (setf slot-value-using-class) (new-value (class proxy-class) (proxy proxy)
 264                                           (slot effective-remote-slot-definition))
 265   (send-now proxy *current-actor* '(setf slot-value) new-value (slot-definition-name slot)))
 266
 267 (defmethod slot-boundp-using-class ((class proxy-class) (proxy proxy)
 268                                    (slot effective-remote-slot-definition))
 269   (send-now proxy *current-actor* 'slot-boundp (slot-definition-name slot)))
 270
 271 (defmethod slot-makunbound-using-class ((class proxy-class) (proxy proxy)
 272                                    (slot effective-remote-slot-definition))
 273   (send-now proxy *current-actor* 'slot-makunbound (slot-definition-name slot)))
 274
 275
 276 (defmethod slot-missing ((class proxy-class) (proxy proxy)
 277                          slot  (setslot (eql 'slot-value)) &optional new-value)
 278   (send-now proxy *current-actor* 'slot-missing slot setslot new-value))
 279
 280
 281 ;;; Klassen sind (noch) keine activen objecte, daher geht nicht send-now
 282 ;;; ==> active-object auf klassen erweitern
 283 (defmethod slot-missing ((class standard-class) (proxy proxy-class)
 284                          slot  (setslot (eql 'slot-value)) &optional new-value)
 285   ;;;(send-now proxy *current-actor* 'slot-missing slot setslot new-value)
 286   ;;; bis dahin hack:
 287   ;;; aus concept-id-set-desc.lisp
 288     (let ((found-slot (find slot (class-slots proxy) :key #'slot-definition-name)))
 289     (when  found-slot
 290       (eval (slot-definition-initform  found-slot))))
 291   )
 292
 293
 294
 295
 296
 297 ;;;;--------------------------------------------------------------------
 298 ;;;; Initializing of mobile-object classes
 299 ;;;;--------------------------------------------------------------------
 300
 301 ;;; I don't like all this (ensure-new-slot-definition-class etc.), but it's necessary
 302 ;;; to merge my stuff with  alien MOP stuff.
 303
 304 (defmethod direct-slot-definition-class ((class mobile-object-class)
 305                                          &rest initargs)
 306   (declare (ignore initargs))
 307   (let ((existing-definition-class (call-next-method)))
 308     (if (not (eq existing-definition-class (find-class 'standard-direct-slot-definition)))
 309         (ensure-new-slot-definition-class existing-definition-class
 310                                           (find-class 'mobile-direct-slot-definition))
 311       (find-class 'mobile-direct-slot-definition))))
 312
 313 (defmethod effective-slot-definition-class ((class mobile-object-class)
 314                                             &rest initargs)
 315   (declare (ignore initargs))
 316   (let ((existing-definition-class (call-next-method)))
 317     (if (not (eq existing-definition-class (find-class 'standard-effective-slot-definition)))
 318         (ensure-new-slot-definition-class existing-definition-class
 319                                           (find-class 'mobile-effective-slot-definition))
 320       (find-class 'mobile-effective-slot-definition))))
 321
 322
 323 (defun ensure-new-slot-definition-class (existing-class new-class)
 324   (or (find-class (intern (concatenate 'string
 325                             (symbol-name (class-name existing-class))
 326                             (symbol-name (class-name new-class)))) nil)
 327             (find-class (intern (concatenate 'string
 328                             (symbol-name (class-name new-class))
 329                             (symbol-name (class-name existing-class)))) nil)
 330       (let ((new-slot-definition-class
 331              (ensure-class (intern (concatenate 'string
 332                                      (symbol-name (class-name existing-class))
 333                                      (symbol-name (class-name new-class))))
 334                            :direct-superclasses (list new-class existing-class))))
 335         (add-method (ensure-generic-function 'moving-behavior)
 336                     (make-instance 'standard-method
 337                       :function (compile nil '(lambda (x) (declare (ignore x))
 338                                                :follow))
 339                       :lambda-list (list 'x)
 340                       :qualifiers ()
 341                       :specializers (list new-slot-definition-class)))
 342         new-slot-definition-class)))
 343
 344
 345 (defmethod compute-effective-slot-definition ((class mobile-object-class) name direct-slots)
 346   (declare (ignore name))
 347   (let ((effective-slot (call-next-method)))
 348     (set-moving-behavior class effective-slot (first direct-slots) (rest direct-slots))
 349     effective-slot))
 350
 351
 352 (defmethod set-moving-behavior ((class mobile-object-class)
 353                                 (effective-slot mobile-effective-slot-definition)
 354                                 (direct-slot mobile-direct-slot-definition)
 355                                 direct-slots)
 356   (if (slot-definition-moving-behavior direct-slot)
 357       (setf (slot-definition-moving-behavior effective-slot)
 358         (slot-definition-moving-behavior direct-slot))
 359     (set-moving-behavior class effective-slot (first direct-slots) (rest direct-slots))))
 360
 361
 362
 363 (defmethod set-moving-behavior ((class mobile-object-class)
 364                                 (effective-slot mobile-effective-slot-definition)
 365                                 (direct-slot direct-slot-definition)
 366                                 direct-slots)
 367   (declare (ignore direct-slots))
 368   (if (next-method-p)
 369       (call-next-method)
 370     (setf (slot-definition-moving-behavior effective-slot) :ignore)))
 371
 372 (defmethod set-moving-behavior ((class mobile-object-class)
 373                                 (effective-slot mobile-effective-slot-definition)
 374                                 (direct-slot null)
 375                                 direct-slots)
 376   (declare (ignore direct-slots))
 377   (setf (slot-definition-moving-behavior effective-slot) :ignore))
 378
 379
 380 #| this code makes all accesors of mobile-objects pargenerics, thus remotely callable.
 381 But that's pretty inefficient, so I don't use it.
 382 (defmethod initialize-instance :before ((slot-definition mobile-direct-slot-definition)
 383                                           &rest initargs &key readers writers)
 384   (declare (ignore initargs))
 385   (loop for reader in readers
 386       do (ensure-generic-function reader
 387                                   :generic-function-class (find-class 'ncl-gf)
 388                                   :lambda-list '(obj)))
 389   (loop for writer in writers
 390       do (ensure-generic-function writer
 391                                   :generic-function-class (find-class 'ncl-setf)
 392                                   :lambda-list '(new-value obj))))
 393
 394
 395 (defmethod initialize-instance :after ((slot-definition mobile-direct-slot-definition)
 396                                        &rest initargs)
 397   (let ((behavior (member :moving-behavior initargs)))
 398     (when (and behavior
 399                (not (or (member (second behavior) '(:stay :follow :ignore))
 400                         (functionp (second behavior)))))
 401                                         ;does not work, because a functionquoted symbol in the
 402                                         ;defclass macro
 403                                         ;is passed as list to the inititialize-instance form.
 404       (error ":moving-behavior option for slot ~a unknown"
 405              (slot-definition-name slot-definition)))))
 406 |#
 407
 408
 409
 410 ;;; supply mobile-object as default superclass for mobile objects
 411 (defmethod initialize-instance :around ((class mobile-object-class) &rest initargs)
 412   (apply #'call-next-method
 413            class
 414            (if (second (member :direct-superclasses initargs))
 415                initargs
 416              (cons :direct-superclasses
 417                    (cons (list (find-class 'mobile-object))
 418                          initargs)))))
 419
 420 (defmethod reinitialize-instance :around ((class mobile-object-class) &rest initargs)
 421   (apply #'call-next-method
 422            class
 423            (if (second (member :direct-superclasses initargs))
 424                initargs
 425              (cons :direct-superclasses
 426                    (cons (list (find-class 'mobile-object))
 427                          initargs)))))
 428
 429
 430
 431
 432 ;;; generate the methods for packing mobile objects
 433 ;;; -----------------------------------------------
 434
 435 (defmethod finalize-inheritance :after ((class mobile-object-class))
 436   (pack-method class)
 437   (unpack-method class))
 438
 439 (defgeneric pack-slots (obj &optional stream))
 440
 441 (defgeneric unpack-slots (obj initargs))
 442
 443
 444
 445
 446 (defun pack-method (class)
 447   (let ((gf  (ensure-generic-function 'pack-slots)))
 448     (add-method gf
 449                 (make-instance 'standard-method
 450                        :function (compile nil (pack-lambda class))
 451                        :specializers (list class)
 452                        :qualifiers ()
 453                          :lambda-list '(obj &optional stream)))))
 454
 455 (defun pack-lambda (class)
 456   `(lambda (obj &optional stream)
 457      ,@(loop for slot in (class-slots class)
 458            for form = (packform slot)
 459            when form
 460            collect (make-unbound-secure slot form))))
 461
 462
 463 (defun make-unbound-secure (slot form)
 464   (if (slot-definition-initfunction slot)
 465       form
 466   `(if (slot-boundp obj ',(slot-definition-name
 467                            slot))
 468        ,form
 469      (print :unbound stream))))
 470
 471 (defun packform (slot)
 472   (let ((moving-behavior (slot-definition-moving-behavior slot)))
 473     (cond ((eq moving-behavior :ignore) ())
 474           ((eq moving-behavior :stay)
 475            `(pack (slot-value obj ',(slot-definition-name slot)) stream))
 476           ((eq moving-behavior :follow)
 477            `(move-pack (slot-value obj ',(slot-definition-name slot)) stream))
 478           (t                            ; moving-behavior should be a function
 479                                         ; but it's just (list 'function function-name).
 480                                         ;This confuses me a bit, but it still works fine.
 481            `(funcall ,moving-behavior
 482                      (slot-value obj ',(slot-definition-name slot)) stream)))))
 483
 484
 485 (defun unpack-method (class)
 486   (let ((gf  (ensure-generic-function 'unpack-slots)))
 487     (add-method gf
 488                 (make-instance 'standard-method
 489                        :function (compile nil (unpack-lambda class))
 490                        :specializers (list class (find-class t))
 491                        :qualifiers ()
 492                        :lambda-list '(obj initargs)))))
 493
 494 (defun unpack-lambda (class)
 495   `(lambda (obj initargs)
 496      ,@(loop for slot in (class-slots class)
 497            for behavior = (slot-definition-moving-behavior slot)
 498            unless (eq behavior :ignore)
 499            collect (unbound-secure-write slot))))
 500
 501 (defun unbound-secure-write (slot)
 502   (if (slot-definition-initfunction slot)
 503       `(progn
 504          (setf (slot-value obj ',(slot-definition-name slot)) (first initargs))
 505          (setq initargs (rest initargs)))
 506     `(let ((value (prog1 (first initargs)
 507                     (setq initargs (rest initargs)))))
 508        (unless (eq value :unbound)
 509          (setf (slot-value obj ',(slot-definition-name slot))
 510            value)))))
 511
 512
 513 ;;; ---------------------------------------------------------------------------------------
 514 ;;; move-pack packs a form on a stream that, when evaluated, yields an object wtih the same
 515 ;;; structure and content as the original object.
 516 ;;; --------------------------------------------------------------------------------------
 517
 518 (defmethod move-pack :around ((obj t) &optional stream)
 519   (let (temp)
 520     (if (setq temp (assoc obj *pack-forms*))
 521         (print (cdr temp) stream)
 522       (call-next-method))))
 523
 524 (defmethod move-pack ((obj mobile-object) &optional stream)
 525   (let ((reference (gentemp "I")))
 526     (setq *pack-forms* (acons obj reference
 527                               *pack-forms*))
 528     (format stream "(progn (proclaim '(special ~a))
 529                                  (prog1 (setq ~a (make-instance '~S))
 530                                     (unpack-slots ~a (list"
 531             reference reference (class-name (class-of obj)) reference)
 532     (pack-slots obj stream)
 533     (write-string "))))" stream)))
 534
 535 (defmethod move-pack ((proxy proxy) &optional stream)
 536   (pack proxy stream))
 537
 538 (defmethod move-pack ((obj t) &optional stream)
 539   (pack obj stream))
 540
 541 (defmethod move-pack ((obj cons) &optional stream)
 542   (write-string "(cons " stream)
 543   (write-char #\space stream)
 544   (move-pack (car obj) stream)
 545   (write-char #\space stream)
 546   (move-pack (cdr obj) stream)
 547   (write-char #\) stream))
 548
 549 (defmethod move-pack ((struc structure-object) &optional stream)
 550   (let* ((class-name (class-name (class-of struc)))
 551          (class-package (symbol-package class-name)))
 552     (format stream "(~A::MAKE-" (package-name class-package))
 553     (write-string (string class-name) stream)
 554     (write-char #\space stream)
 555     (loop for slot in (class-slots (class-of struc))
 556         for name = (slot-definition-name slot)
 557         do (progn (write-char #\: stream)
 558                   (write-string (string name) stream)
 559                   (write-char #\space  stream)
 560                   (move-pack (funcall (fdefinition (intern (format nil "~a-~a"
 561                                                                    class-name
 562                                                                    name)
 563                                                            class-package))
 564                                  struc)
 565                         stream)))
 566     (write-char #\) stream)))
 567
 568 (defmethod move-pack ((array array) &optional stream)
 569   (write-string "(unpack-array " stream)
 570   (pack (array-dimensions array) stream)
 571   (write-char #\space stream)
 572   (pack (array-element-type array) stream)
 573   (write-char #\space stream)
 574   (loop for i from 0 upto (1- (array-total-size array))
 575       do (progn (move-pack (row-major-aref array i) stream)
 576                 (write-char #\space stream)))
 577   (write-char #\) stream))
 578
 579 ;;;mu = move-unpack
 580 (defun mu (type &rest initargs)
 581   (let ((obj (make-instance type)))
 582     (unpack-slots obj initargs)
 583     obj))
 584
 585
 586
 587 ;;;----------------------------------------
 588 ;;; initialization of ncl-gf's
 589 ;;;----------------------------------------
 590
 591 (defmethod initialize-instance :after ((gf ncl-gf) &rest initargs)
 592   (declare (ignore initargs))
 593   (add-method gf
 594               (make-instance 'standard-method
 595                 :function (compile nil '(lambda (&rest rest)
 596                                          (declare (ignore rest))
 597                                          t))
 598                 :specializers (compute-specializers gf 'proxy)
 599                 :qualifiers '(:test)
 600                 :lambda-list (generic-function-lambda-list gf))))
 601
 602 (defmethod reinitialize-instance :after ((gf ncl-gf) &rest initargs)
 603   (declare (ignore initargs))
 604   (add-method gf
 605               (make-instance 'standard-method
 606                 :function (compile nil '(lambda (&rest rest)
 607                                          (declare (ignore rest))
 608                                          t))
 609                 :specializers (compute-specializers gf 'proxy)
 610                 :qualifiers '(:test)
 611                 :lambda-list (generic-function-lambda-list gf))))
 612
 613
 614
 615 ;;;-----------------------------------------
 616 ;;; other stuff
 617 ;;;-----------------------------------------
 618
 619 ;;; touch must be a pargeneric to work across objspace-boundaries,
 620 ;;; only it doesn't even work then.
 621 ;;(defpargeneric touch :now (future))
 622
 623 ;;; create objects in other objectspaces
 624 (defmethod make-instance :around ((class mobile-object-class) &rest initargs &key location)
 625   (if location
 626       (touch (kernel-send location
 627                           (rmi-message :initargs-b (copy-list initargs)
 628                                         ; lists introduces through the rest argument
 629                                         ; may have dynamic extent, so they must be copied.
 630                                        :class-name (class-name class))))
 631     (call-next-method)))
 632
 633 ;;; determine the location of an object
 634 (defmethod location ((obj t))
 635   *localspace*)
 636
 637 (defmethod location ((obj proxy))
 638   (remote-os obj))
 639
 640
 641
 642
 643
 644
 645 #| old stuff, but I hate throwing it away.
 646
 647 (defun get-optionals (lambda-list)
 648   (loop for non-req in (rest (member '&optional
 649                                      lambda-list))
 650       while (not (member non-req lambda-list-keywords))
 651       collect non-req))
 652
 653 (defun keys-or-restp (lambda-list)
 654   (member '(&key &rest)
 655           lambda-list :test #'(lambda (x y)
 656                                 (member y x))))
 657
 658
 659
 660 (defmethod compute-proxy-lambda ((gf remote-generic-function) lambda-list)
 661   (let ((required (required-arguments gf))
 662         (optionals (mapcar #'first (get-optionals lambda-list)))
 663         (suppliedp-list (mapcar #'third (get-optionals lambda-list)))
 664         (rest-arg (when (keys-or-restp lambda-list)
 665                     (first (last lambda-list)))))
 666     `(lambda ,lambda-list
 667        (apply #'send-now ,(first required)
 668               ',(generic-function-name gf)
 669               ,@(rest required)
 670               ,(non-required-arguments optionals suppliedp-list rest-arg)))))
 671
 672
 673 (defun non-required-arguments (optionals suppliedp-list rest-arg)
 674   (if (endp optionals)
 675       rest-arg
 676     `(if ,(first suppliedp-list)
 677          (cons ,(first optionals) ,(non-required-arguments (rest optionals)
 678                                                            (rest suppliedp-list)
 679                                                            rest-arg))
 680        ,rest-arg)))
 681
 682 (defun compute-lambda-list (gf)
 683   (let* ((optionals (get-optionals (generic-function-lambda-list gf)))
 684          (suppliedp-list (loop for arg in optionals
 685                              collect (gensym (symbol-name arg)))))
 686     (append (required-arguments gf)
 687             (when optionals
 688               '(&optional))
 689             (loop for opt in optionals
 690                 for sup in suppliedp-list
 691                 collect (list opt nil sup))
 692             (when (keys-or-restp  (generic-function-lambda-list gf))
 693               (list '&rest (gensym "REST-"))))))
 694
 695
 696
 697
 698 (defclass proxy (concurrency-obj)
 699   ((remote-address :accessor remote-address
 700                    :initarg :remote-address)
 701    (remote-os :accessor remote-os
 702               :initarg :remote-os)
 703    (master-class-name :accessor master-class-name
 704                       :initarg :master-class-name)))
 705
 706
 707
 708 (defmethod compute-applicable-methods-using-classes ((gf proxy-dispatching-gf) classes)
 709   (if (loop for class in (without-concurrency-obj gf classes)
 710           thereis (eq (class-name class) 'proxy))
 711       (values nil nil)
 712     (call-next-method)))
 713
 714 (defmethod compute-applicable-methods ((gf proxy-dispatching-gf) arguments)
 715   (let* ((proxyp)
 716          (classes (unite-concurrency-obj-and-others
 717                    gf
 718                    (class-of (get-concurrency-obj gf arguments))
 719                    (loop with proxy-class = (find-class 'proxy)
 720                        for arg in (without-concurrency-obj gf arguments)
 721                        collect (if (eq (class-of arg)
 722                                        proxy-class)
 723                                    (progn (setf proxyp t)
 724                                           (find-class (master-class-name arg)))
 725                                  (class-of arg))))))
 726     (if proxyp
 727         (multiple-value-bind (method-list success)
 728             (compute-applicable-methods-using-classes gf classes)
 729           (if success
 730               method-list
 731             (call-next-method)))
 732       (call-next-method))))
 733
 734 (defmethod compute-effective-slot-definition ((class proxy-class) name direct-slots)
 735   (declare (ignore name))
 736   (let ((effsd (call-next-method)))
 737     effsd))
 738
 739
 740 (defmethod  set-correct-behavior ((effsd  effective-remote-slot-definition))
 741   (setf (slot-definition-allocation effsd) :ignore)
 742   (setf (slot-definition-initfunction effsd) ())
 743   (setf (slot-definition-initargs effsd) ()))
 744
 745 (defmethod slot-definition-allocation ((slot effective-remote-slot-definition))
 746   :ignore)                              ;This doesn't work either.
 747
 748 |#
 749
 750
 751
 752