ncl-macros.lisp

   1 ;;-----------------------------------------------------------------------------------
   2 ;;; name       : ncl-macros
   3 ;;; description: all the macros needed for netclos
   4 ;;; notes      :
   5 ;;; contact    : me (Michael Trowe)
   6 ;;; copyright  :
   7 ;;; history    :
   8 ;;; contents   :
   9 ;;;-----------------------------------------------------------------------------------
  10
  11 (in-package nc)
  12
  13 (defstruct request message-id)
  14
  15 (defun fetch-names (args)
  16   (loop for arg in args
  17       collect (if (listp arg)
  18                   (first arg)
  19                 arg)))
  20
  21 (defmacro defmessage (name args &key receive-action request-p process-p)
  22   (if request-p
  23       (create-request name (fetch-names args) args receive-action process-p)
  24     (create-operation name (fetch-names args) args  receive-action process-p)))
  25
  26 (defun create-request (name arg-names args body process-p)
  27   (let* ((sym (gensym "message-id"))
  28          (body `(kernel-send *calling-os*
  29                              (reply-message :content ,body
  30                                             :message-id ,sym))))
  31     `(progn
  32        ,(create-struct name arg-names :super 'request)
  33        ,(create-defun name (cons sym arg-names) body process-p)
  34        ,(create-pack name (cons 'message-id arg-names) (cons 'message-id args)))))
  35
  36 (defun create-operation  (name arg-names args body process-p)
  37   `(progn
  38      ,(create-struct name arg-names)
  39      ,(create-defun name arg-names body process-p)
  40      ,(create-pack name arg-names args)))
  41
  42
  43 (defun create-struct (name args &key super)
  44   (if super
  45        `(defstruct (,name
  46                     (:constructor ,(intern (format nil "~a-MESSAGE" name)))
  47                     (:include ,super))
  48           ,@args)
  49      `(defstruct (,name
  50                   (:constructor ,(intern (format nil "~a-MESSAGE" name))))
  51         ,@args)))
  52
  53 (defun create-defun (name arg-names body process-p)
  54   `(defun ,name ,arg-names ,(if process-p
  55                                 `(acl-compat-mp:process-run-function ,(format nil "receiving ~a" name)
  56                                                           #'(lambda (*calling-os*)
  57                                                               ,body)
  58                                                           *calling-os*)
  59                               body)))
  60
  61 (defvar *pack-forms* ())
  62
  63 (defun create-pack (name arg-names args)
  64   `(defmethod pack ((message ,name) &optional stream)
  65      (let ((*pack-forms*))
  66        (write-string ,(concatenate 'string "("  (write-to-string name) " ") stream)
  67        ,@(loop for arg in args
  68              for arg-name in arg-names
  69              for packfunc = (if (and (listp arg)
  70                                      (eq (second arg) :packing))
  71                                 (third arg)
  72                               'pack)
  73              collect `(,packfunc (,(intern
  74                                     (format nil "~a-~a" name arg-name))
  75                                   message)
  76                                  stream))
  77        (write-char #\) stream))))
  78
  79 ;;; mit *thee-agg zum testen von env
  80 #|
  81 (defun create-pack (name arg-names args)
  82   `(defmethod pack ((message ,name) &optional stream)
  83      (let ((*pack-forms*))
  84        (format stream
  85                 "(let ((mks::*the-aggregate* 'pol) (declare (special mks::*the-aggregate*))")
  86        (write-string ,(concatenate 'string "("  (write-to-string name) " ") stream)
  87        ,@(loop for arg in args
  88              for arg-name in arg-names
  89              for packfunc = (if (and (listp arg)
  90                                      (eq (second arg) :packing))
  91                                 (third arg)
  92                               'pack)
  93              collect `(,packfunc (,(intern
  94                                     (format nil "~a-~a" name arg-name))
  95                                   message)
  96                                  stream))
  97        (write-char #\) stream)
  98        (write-char #\) stream)
  99        )))
 100 |#
 101 #|
 102 (shadow 'defgeneric)
 103
 104 (defmacro defgeneric (name second &rest rest)
 105   (if (member second '(:past :now :future))
 106       `(defpargeneric ,name ,second ,@rest)
 107     `(common-lisp:defgeneric ,name ,second ,@rest)))
 108 |#
 109
 110
 111 (defmacro defpargeneric (name send-func lambda-list &rest options)
 112   ;; I wanted to use defgeneric, but you can't add your own keyword arguments then.
 113   ;; So now there is no source-file-recording and fewer compile-time error-checking.
 114   `(progn (when (and *manager* *defremote-p*)
 115             (loop for space in (spaces *manager*)
 116                 do (remote-eval space
 117                                 '(let ((*defremote-p* nil))
 118                                   (defpargeneric ,name ,send-func ,lambda-list ,@options)))))
 119           (ensure-generic-function
 120            ',name
 121            :lambda-list ',lambda-list
 122            :generic-function-class (find-class ',(compute-gf-class
 123                                                   name
 124                                                   (second (assoc :generic-function-class
 125                                                                  options))))
 126            :send-func ,(compute-send-func send-func)
 127            ,@(compute-options options))))
 128
 129 (defun make-args (lambda-list)
 130   (loop for arg in lambda-list
 131       unless (member arg lambda-list-keywords)
 132       collect arg))
 133
 134 (defun compute-send-func (name)
 135   (if (member name '(:past :now :future))
 136       (list 'function (intern (format nil "SEND-~a" name) :nc))))
 137
 138 (defun compute-options (optionlist)
 139   (loop for opt in optionlist
 140       unless (eq (first opt) :generic-function-class)
 141       append opt))
 142
 143 (defun compute-gf-class (name class)
 144   (if (and (listp name) (eq (first name) 'setf))
 145       (cond ((not class) 'ncl-setf)
 146             ((and (subtypep class 'sending-gf) (subtypep class 'setf-gf)) class)
 147             (t (error "a generic-function-class used in defpargeneric for a setf form must be a subclass of sending-gf and setf-gf")))
 148      (cond ((not class) 'ncl-gf)
 149             ((subtypep class 'sending-gf) class)
 150             (t (error "a generic-function-class used in defpargeneric must be a subclass of sending-gf")))))
 151
 152 #|
 153 I want to supply automatic creation of packing methods for structures here
 154
 155 (shadow 'defstruct)
 156
 157 (defmacro defstruct (name &rest rest)
 158   (let ((class-name (cond ((listp name) (first name))
 159                         (t name))))))
 160
 161 |#