pdefsys.lisp

   1 ;;;-----------------------------------------------------------------------------------
   2 ;;; name       : pdefsys
   3 ;;; description: For netclos to work all object spaces got to have consistent global
   4 ;;;              environments. All definitions in effect in any space have to be also in effect
   5 ;;;              in all others. (You may ommit some defintions in the remote object spaces,
   6 ;;;              but you have then to be sure that they won't be used in those spaces.)
   7 ;;;              The main tool to achieve this is defpsystem, which works like defsystem,
   8 ;;;              but when such a system is loaded, it is loaded into all spaces.
   9 ;;;              The other possibillity is set *defremote-p* to t and use defun etc.. But be
  10 ;;;              careful: This only works in the netclos  package, and it only works
  11 ;;;              immediatly. Definitons aren't automatically send to objects spaces created
  12 ;;;              later. And it won't work with closures (you'll get an error.)
  13 ;;; notes      :
  14 ;;; contact    : me (Michael Trowe)
  15 ;;; copyright  :
  16 ;;; history    :
  17 ;;; contents   : defpsystem and special versions of defun, defclass, defgeneric and defmethod.
  18 ;;;-----------------------------------------------------------------------------------
  19
  20 (in-package nc)
  21
  22 (defvar *defremote-p* nil)
  23
  24 ;; (defmacro defpsystem (name options &rest specifications)
  25 ;;   `(progn (add-system *manager*
  26 ;;                    ',name ',options ',specifications)
  27 ;;        (excl:defsystem ,name ,options ,@specifications)))
  28
  29 ;; (defun load-psystem (name &rest args)
  30 ;;   (let ((system (assoc name (systems *manager*)))
  31 ;;      (*defremote-p* nil))
  32 ;;     (apply #'excl:load-system name args)
  33 ;;     (when (and *master-p* system)
  34 ;;       (loop for space in (spaces *manager*)
  35 ;;        do (kernel-send space
  36 ;;                        (system-loaded-message :system-name name
  37 ;;                                                :load-args args)))
  38 ;;       (setf (cadddr system) :loaded))))
  39
  40 ;; (defun compile-psystem (name)
  41 ;;   (let ((*defremote-p* nil))
  42 ;;     (excl:compile-system name)))
  43
  44 (defmacro defpsystem (name options &rest specifications)
  45   `(progn (add-system *manager*
  46                       ',name ',options ',specifications)
  47           (asdf:defsystem ,name ,options ,@specifications)))
  48
  49 (defun load-psystem (name &rest args)
  50   (let ((system (assoc name (systems *manager*)))
  51         (*defremote-p* nil))
  52     (apply #'asdf:operate 'asdf:load-op name args)
  53     (when (and *master-p* system)
  54       (loop for space in (spaces *manager*)
  55           do (kernel-send space
  56                           (system-loaded-message :system-name name
  57                                                   :load-args args)))
  58       (setf (cadddr system) :loaded))))
  59
  60 (defun compile-psystem (name)
  61   (let ((*defremote-p* nil))
  62     (asdf:operate 'asdf:compile-op name)))
  63
  64
  65
  66 (eval-when (:compile-toplevel :load-toplevel :execute)
  67   (shadow 'defun))
  68
  69 (cl:defmacro defun (&rest rest)
  70   `(progn (eval-when (:execute)
  71             (when (and *manager* *defremote-p*)
  72               (loop for space in (spaces *manager*)
  73                  do (remote-eval space '(cl:defun ,@rest)))))
  74           (cl:defun ,@rest)))
  75
  76 (define-compiler-macro defun (&rest rest)
  77   `(cl:defun ,@rest))
  78
  79 (eval-when (:compile-toplevel :load-toplevel :execute)
  80   (shadow 'defclass))
  81
  82 (cl:defmacro defclass (&rest rest)
  83   `(progn (eval-when (:execute)
  84             (when (and *manager* *defremote-p*)
  85               (loop for space in (spaces *manager*)
  86                   do (remote-eval space '(cl:defclass ,@rest)))))
  87           (cl:defclass ,@rest)))
  88
  89 (define-compiler-macro defclass (&rest rest)
  90   `(cl:defclass ,@rest))
  91
  92 (eval-when (:compile-toplevel :load-toplevel :execute)
  93   (shadow 'defmethod))
  94
  95 (cl:defmacro defmethod (&rest rest)
  96   `(progn (eval-when (:execute)
  97             (when (and *manager* *defremote-p*)
  98               (loop for space in (spaces *manager*)
  99                   do (remote-eval space '(cl:defmethod ,@rest)))))
 100           (cl:defmethod ,@rest)))
 101
 102 (define-compiler-macro defmethod (&rest rest)
 103   `(cl:defmethod ,@rest))
 104
 105 (eval-when (:compile-toplevel :load-toplevel :execute)
 106   (shadow 'defgeneric))
 107
 108 (cl:defmacro defgeneric (&rest rest)
 109   `(progn (eval-when (:execute)
 110             (when (and *manager* *defremote-p*)
 111               (loop for space in (spaces *manager*)
 112                   do (remote-eval space '(cl:defgeneric ,@rest)))))
 113           (cl:defgeneric ,@rest)))
 114
 115 (define-compiler-macro defgeneric (&rest rest)
 116   `(cl:defgeneric ,@rest))
 117
 118
 119
 120
 121