src/c-types-*.lisp: New type for functions which take keyword arguments.

[sod] / src / method-impl.lisp

diff --git a/src/method-impl.lisp b/src/method-impl.lisp
index 4a8249bb8a03aa03eb4472f190308b53cdacf69e..0564d814cfc4cc10a8a2e9efd53045075e4cfd01 100644 (file)
--- a/src/method-impl.lisp
+++ b/src/method-impl.lisp
@@ -7,7 +7,7 @@
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;
 
 ;;;----- Licensing notice ---------------------------------------------------
 ;;;

-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.

 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by
 ;;;
 ;;; SOD is free software; you can redistribute it and/or modify
 ;;; it under the terms of the GNU General Public License as published by


@@ -40,33 +40,20 @@ (defclass basic-message (sod-message)
    inheriting its default behaviour.
 
    The function type protocol is implemented on `basic-message' using slot
    inheriting its default behaviour.
 
    The function type protocol is implemented on `basic-message' using slot

-   reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   reader methods.  The actual values are computed on demand."))

 
 

-(defmethod slot-unbound (class
-                        (message basic-message)
-                        (slot-name (eql 'argument-tail)))
-  (declare (ignore class))
+(define-on-demand-slot basic-message argument-tail (message)

   (let ((seq 0))
   (let ((seq 0))

-    (setf (slot-value message 'argument-tail)
-         (mapcar (lambda (arg)
-                   (if (or (eq arg :ellipsis) (argument-name arg)) arg
-                       (make-argument (make-instance 'temporary-argument
-                                                     :tag (prog1 seq
-                                                            (incf seq)))
-                                      (argument-type arg))))
-                 (c-function-arguments (sod-message-type message))))))
-
-(defmethod slot-unbound (class
-                        (message basic-message)
-                        (slot-name (eql 'no-varargs-tail)))
-  (declare (ignore class))
-  (setf (slot-value message 'no-varargs-tail)
-       (mapcar (lambda (arg)
-                 (if (eq arg :ellipsis)
-                     (make-argument *sod-ap* (c-type va-list))
-                     arg))
-               (sod-message-argument-tail message))))
+    (mapcar (lambda (arg)
+             (if (or (eq arg :ellipsis) (argument-name arg)) arg
+                 (make-argument (make-instance 'temporary-argument
+                                               :tag (prog1 seq
+                                                      (incf seq)))
+                                (argument-type arg))))
+           (c-function-arguments (sod-message-type message)))))
+
+(define-on-demand-slot basic-message no-varargs-tail (message)
+  (reify-variable-argument-tail (sod-message-argument-tail message)))

 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)
 
 (defmethod sod-message-method-class
     ((message basic-message) (class sod-class) pset)


@@ -104,7 +91,7 @@ (defmethod primary-method-class ((message simple-message))
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 
 ;;;--------------------------------------------------------------------------
 ;;; Direct method classes.
 

-(export 'basic-direct-method)
+(export '(basic-direct-method sod-method-role))

 (defclass basic-direct-method (sod-method)
   ((role :initarg :role :type symbol :reader sod-method-role)
    (function-type :type c-function-type :reader sod-method-function-type))
 (defclass basic-direct-method (sod-method)
   ((role :initarg :role :type symbol :reader sod-method-role)
    (function-type :type c-function-type :reader sod-method-function-type))


@@ -120,22 +107,18 @@ (defclass basic-direct-method (sod-method)
    categorization.
 
    The function type protocol is implemented on `basic-direct-method' using
    categorization.
 
    The function type protocol is implemented on `basic-direct-method' using

-   slot reader methods.  The actual values are computed on demand in methods
-   defined on `slot-unbound'."))
+   slot reader methods."))

 
 (defmethod shared-initialize :after
     ((method basic-direct-method) slot-names &key pset)
   (declare (ignore slot-names))
   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 
 
 (defmethod shared-initialize :after
     ((method basic-direct-method) slot-names &key pset)
   (declare (ignore slot-names))
   (default-slot (method 'role) (get-property pset :role :keyword nil)))
 

-(defmethod slot-unbound
-    (class (method basic-direct-method) (slot-name (eql 'function-type)))
-  (declare (ignore class))
+(define-on-demand-slot basic-direct-method function-type (method)

   (let ((type (sod-method-type method)))
   (let ((type (sod-method-type method)))

-    (setf (slot-value method 'function-type)
-         (c-type (fun (lisp (c-type-subtype type))
-                      ("me" (* (class (sod-method-class method))))
-                      . (c-function-arguments type))))))
+    (c-type (fun (lisp (c-type-subtype type))
+                ("me" (* (class (sod-method-class method))))
+                . (c-function-arguments type)))))

 
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method
 
 (defmethod sod-method-function-name ((method basic-direct-method))
   (with-slots ((class %class) role message) method


@@ -160,11 +143,8 @@ (defmethod check-method-type ((method daemon-direct-method)
                              (message sod-message)
                              (type c-function-type))
   (with-slots ((msgtype %type)) message
                              (message sod-message)
                              (type c-function-type))
   (with-slots ((msgtype %type)) message

-    (unless (c-type-equal-p (c-type-subtype type) (c-type void))
-      (error "Method return type ~A must be `void'" (c-type-subtype type)))
-    (unless (argument-lists-compatible-p (c-function-arguments msgtype)
-                                        (c-function-arguments type))
-      (error "Method arguments ~A don't match message ~A" type msgtype))))
+    (check-method-return-type type c-type-void)
+    (check-method-argument-lists type msgtype)))

 
 (export 'delegating-direct-method)
 (defclass delegating-direct-method (basic-direct-method)
 
 (export 'delegating-direct-method)
 (defclass delegating-direct-method (basic-direct-method)


@@ -184,50 +164,41 @@ (defclass delegating-direct-method (basic-direct-method)
    its `next_method' function if necessary.)
 
    The function type protocol is implemented on `delegating-direct-method'
    its `next_method' function if necessary.)
 
    The function type protocol is implemented on `delegating-direct-method'

-   using slot reader methods.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using slot reader methods.."))

 
 

-(defmethod slot-unbound (class
-                        (method delegating-direct-method)
-                        (slot-name (eql 'next-method-type)))
-  (declare (ignore class))
+(define-on-demand-slot delegating-direct-method next-method-type (method)

   (let* ((message (sod-method-message method))
         (return-type (c-type-subtype (sod-message-type message)))
         (msgargs (sod-message-argument-tail message))
         (arguments (if (varargs-message-p message)
   (let* ((message (sod-method-message method))
         (return-type (c-type-subtype (sod-message-type message)))
         (msgargs (sod-message-argument-tail message))
         (arguments (if (varargs-message-p message)

-                       (cons (make-argument *sod-master-ap*
-                                            (c-type va-list))
+                       (cons (make-argument *sod-master-ap* c-type-va-list)

                              (butlast msgargs))
                        msgargs)))
                              (butlast msgargs))
                        msgargs)))

-    (setf (slot-value method 'next-method-type)
-         (c-type (fun (lisp return-type)
-                      ("me" (* (class (sod-method-class method))))
-                      . arguments)))))
-
-(defmethod slot-unbound (class
-                        (method delegating-direct-method)
-                        (slot-name (eql 'function-type)))
-  (declare (ignore class))
+    (c-type (fun (lisp return-type)
+                ("me" (* (class (sod-method-class method))))
+                . arguments))))
+
+(define-on-demand-slot delegating-direct-method function-type (method)

   (let* ((message (sod-method-message method))
         (type (sod-method-type method))
         (method-args (c-function-arguments type)))
   (let* ((message (sod-method-message method))
         (type (sod-method-type method))
         (method-args (c-function-arguments type)))

-    (setf (slot-value method 'function-type)
-         (c-type (fun (lisp (c-type-subtype type))
-                      ("me" (* (class (sod-method-class method))))
-                      ("next_method" (* (lisp (commentify-function-type
-                                               (sod-method-next-method-type
-                                                method)))))
-                      .
-                      (if (varargs-message-p message)
-                          (cons (make-argument *sod-master-ap*
-                                               (c-type va-list))
-                                method-args)
-                          method-args))))))
+    (c-type (fun (lisp (c-type-subtype type))
+                ("me" (* (class (sod-method-class method))))
+                ("next_method" (* (lisp (commentify-function-type
+                                         (sod-method-next-method-type
+                                          method)))))
+                .
+                (if (varargs-message-p message)
+                    (cons (make-argument *sod-master-ap* c-type-va-list)
+                          method-args)
+                    method-args)))))

 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 
 
 ;;;--------------------------------------------------------------------------
 ;;; Effective method classes.
 

-(export 'basic-effective-method)
+(export '(basic-effective-method
+         effective-method-around-methods effective-method-before-methods
+         effective-method-after-methods))

 (defclass basic-effective-method (effective-method)
   ((around-methods :initarg :around-methods :initform nil
                   :type list :reader effective-method-around-methods)
 (defclass basic-effective-method (effective-method)
   ((around-methods :initarg :around-methods :initform nil
                   :type list :reader effective-method-around-methods)


@@ -246,17 +217,12 @@ (defclass basic-effective-method (effective-method)
    correctly.
 
    The argument names protocol is implemented on `basic-effective-method'
    correctly.
 
    The argument names protocol is implemented on `basic-effective-method'

-   using a slot reader method.  The actual values are computed on demand in
-   methods defined on `slot-unbound'."))
+   using a slot reader method."))

 
 

-(defmethod slot-unbound (class
-                        (method basic-effective-method)
-                        (slot-name (eql 'basic-argument-names)))
-  (declare (ignore class))
+(define-on-demand-slot basic-effective-method basic-argument-names (method)

   (let ((message (effective-method-message method)))
   (let ((message (effective-method-message method)))

-    (setf (slot-value method 'basic-argument-names)
-         (mapcar #'argument-name
-                 (sod-message-no-varargs-tail message)))))
+    (mapcar #'argument-name
+           (sod-message-no-varargs-tail message))))

 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))
 
 (defmethod effective-method-function-name ((method effective-method))
   (let* ((class (effective-method-class method))


@@ -267,11 +233,8 @@ (defmethod effective-method-function-name ((method effective-method))
            (sod-class-nickname message-class)
            (sod-message-name message))))
 
            (sod-class-nickname message-class)
            (sod-message-name message))))
 

-(defmethod slot-unbound
-    (class (method basic-effective-method) (slot-name (eql 'functions)))
-  (declare (ignore class))
-  (setf (slot-value method 'functions)
-       (compute-method-entry-functions method)))
+(define-on-demand-slot basic-effective-method functions (method)
+  (compute-method-entry-functions method))

 
 (export 'simple-effective-method)
 (defclass simple-effective-method (basic-effective-method)
 
 (export 'simple-effective-method)
 (defclass simple-effective-method (basic-effective-method)


@@ -303,7 +266,7 @@ (defmethod shared-initialize :after
   (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target
   (declare (ignore slot-names))
   (with-slots (message target) codegen
     (setf target

-         (if (eq (c-type-subtype (sod-message-type message)) (c-type void))
+         (if (eq (c-type-subtype (sod-message-type message)) c-type-void)

              :void
              :return))))
 
              :void
              :return))))
 


@@ -367,7 +330,7 @@ (defmethod method-entry-function-name
                (sod-class-nickname message-class)
                (sod-message-name message)
                (sod-class-nickname chain-head))
                (sod-class-nickname message-class)
                (sod-message-name message)
                (sod-class-nickname chain-head))

-       0)))
+       *null-pointer*)))

 
 (defmethod method-entry-slot-name ((entry method-entry))
   (let* ((method (method-entry-effective-method entry))
 
 (defmethod method-entry-slot-name ((entry method-entry))
   (let* ((method (method-entry-effective-method entry))


@@ -450,10 +413,9 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
         ;; Effective method function details.
         (emf-name (effective-method-function-name method))
         (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))
         ;; Effective method function details.
         (emf-name (effective-method-function-name method))
         (ilayout-type (c-type (* (struct (ilayout-struct-tag class)))))

-        (emf-arg-tail (sod-message-no-varargs-tail message))

         (emf-type (c-type (fun (lisp return-type)
                                ("sod__obj" (lisp ilayout-type))
         (emf-type (c-type (fun (lisp return-type)
                                ("sod__obj" (lisp ilayout-type))

-                               . emf-arg-tail))))
+                               . entry-args))))

 
     (flet ((setup-entry (tail)
             (let ((head (sod-class-chain-head tail)))
 
     (flet ((setup-entry (tail)
             (let ((head (sod-class-chain-head tail)))


@@ -468,29 +430,43 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                    (type (c-type (fun (lisp return-type)
                                       ("me" (* (class tail)))
                                       . entry-args))))
                    (type (c-type (fun (lisp return-type)
                                       ("me" (* (class tail)))
                                       . entry-args))))

-              (codegen-pop-function codegen name type)
+              (codegen-pop-function codegen name type
+               "~@(~@[~A ~]entry~) function ~:_~
+                for method `~A.~A' ~:_~
+                via chain headed by `~A' ~:_~
+                defined on `~A'."
+               (if parm-n "Indirect argument-tail" nil)
+               (sod-class-nickname message-class)
+               (sod-message-name message)
+               head class)

 
               ;; If this is a varargs method then we've made the
               ;; `:valist' role.  Also make the `nil' role.
               (when parm-n
 
               ;; If this is a varargs method then we've made the
               ;; `:valist' role.  Also make the `nil' role.
               (when parm-n

-                (let ((call (make-call-inst name
-                                            (cons "me"
-                                                  (mapcar #'argument-name
-                                                          entry-args))))
+                (let ((call (apply #'make-call-inst name "me"
+                                   (mapcar #'argument-name entry-args)))

                       (main (method-entry-function-name method head nil))
                       (main-type (c-type (fun (lisp return-type)
                                               ("me" (* (class tail)))
                                               . raw-entry-args))))
                   (codegen-push codegen)
                       (main (method-entry-function-name method head nil))
                       (main-type (c-type (fun (lisp return-type)
                                               ("me" (* (class tail)))
                                               . raw-entry-args))))
                   (codegen-push codegen)

-                  (ensure-var codegen *sod-ap* (c-type va-list))
-                  (emit-inst codegen
-                             (make-va-start-inst *sod-ap*
-                                                 (argument-name parm-n)))
+                  (ensure-var codegen *sod-ap* c-type-va-list)

                   (convert-stmts codegen entry-target return-type
                                  (lambda (target)
                   (convert-stmts codegen entry-target return-type
                                  (lambda (target)

-                                   (deliver-expr codegen target call)))
-                  (emit-inst codegen (make-va-end-inst *sod-ap*))
-                  (codegen-pop-function codegen main main-type))))))
+                                   (deliver-call codegen :void "va_start"
+                                                 *sod-ap* parm-n)
+                                   (deliver-expr codegen target call)
+                                   (deliver-call codegen :void "va_end"
+                                                 *sod-ap*)))
+                  (codegen-pop-function codegen main main-type
+                   "Variable-length argument list ~:_~
+                    entry function ~:_~
+                    for method `~A.~A' ~:_~
+                    via chain headed by `~A' ~:_~
+                    defined on `~A'."
+               (sod-class-nickname message-class)
+               (sod-message-name message)
+               head class))))))

 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)
 
       ;; Generate the method body.  We'll work out what to do with it later.
       (codegen-push codegen)


@@ -524,11 +500,15 @@ (defmethod compute-method-entry-functions ((method basic-effective-method))
                 ;; function and call it a lot.
                 (codegen-build-function codegen emf-name emf-type vars
                  (nconc insts (and result
                 ;; function and call it a lot.
                 (codegen-build-function codegen emf-name emf-type vars
                  (nconc insts (and result

-                                   (list (make-return-inst result)))))
-
-                (let ((call (make-call-inst emf-name
-                             (cons "sod__obj" (mapcar #'argument-name
-                                                      emf-arg-tail)))))
+                                   (list (make-return-inst result))))
+                 "Effective method function ~:_for `~A.~A' ~:_~
+                  defined on `~A'."
+                 (sod-class-nickname message-class)
+                 (sod-message-name message)
+                 (effective-method-class method))
+
+                (let ((call (apply #'make-call-inst emf-name "sod__obj"
+                                   (mapcar #'argument-name entry-args))))

                   (dolist (tail chain-tails)
                     (setup-entry tail)
                     (deliver-expr codegen entry-target call)
                   (dolist (tail chain-tails)
                     (setup-entry tail)
                     (deliver-expr codegen entry-target call)


@@ -570,7 +550,7 @@ (defclass standard-effective-method (simple-effective-method) ()
 (defmethod primary-method-class ((message standard-message))
   'delegating-direct-method)
 
 (defmethod primary-method-class ((message standard-message))
   'delegating-direct-method)
 

-(defmethod message-effective-method-class ((message standard-message))
+(defmethod sod-message-effective-method-class ((message standard-message))

   'standard-effective-method)
 
 (defmethod simple-method-body
   'standard-effective-method)
 
 (defmethod simple-method-body