X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/b426ab51d0598242a4c2b57d563341db66d71f7b..1f7d590d9c7b87442c8d8b6424ed4f769d377692:/src/method-impl.lisp diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 46f268b..6c9b28d 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -40,33 +40,24 @@ 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)) - (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) + (mapcar (lambda (arg) + (if (eq arg :ellipsis) + (make-argument *sod-ap* (c-type va-list)) + arg)) + (sod-message-argument-tail message))) (defmethod sod-message-method-class ((message basic-message) (class sod-class) pset) @@ -120,25 +111,21 @@ 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 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))) - (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 role message) method + (with-slots ((class %class) role message) method (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role (sod-class-nickname (sod-message-class message)) (sod-message-name message)))) @@ -159,7 +146,7 @@ (defmethod check-method-type ((method daemon-direct-method) (message sod-message) (type c-function-type)) - (with-slots ((msgtype type)) message + (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) @@ -184,13 +171,9 @@ 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)) @@ -199,30 +182,25 @@ (c-type va-list)) (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))) - (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. @@ -246,17 +224,12 @@ 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))) - (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)) @@ -267,11 +240,8 @@ (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) @@ -323,7 +293,8 @@ returned by the outermost `around' method -- or, if there are none, delivered by the BODY -- is finally delivered to the TARGET." - (with-slots (message class before-methods after-methods around-methods) + (with-slots (message (class %class) + before-methods after-methods around-methods) method (let* ((message-type (sod-message-type message)) (return-type (c-type-subtype message-type)) @@ -380,7 +351,8 @@ (message (effective-method-message method)) (type (sod-message-type message)) (tail (ecase (method-entry-role entry) - ((nil) (sod-message-argument-tail message))))) + ((nil) (sod-message-argument-tail message)) + (:valist (sod-message-no-varargs-tail message))))) (c-type (fun (lisp (c-type-subtype type)) ("me" (* (class (method-entry-chain-tail entry)))) . tail)))) @@ -396,6 +368,7 @@ :chain-head chain-head :chain-tail chain-tail) entries))) + (when (varargs-message-p message) (make :valist)) (make nil) entries))) @@ -438,8 +411,9 @@ (mapcar #'car (sod-class-chains class)))) (n-entries (length chain-tails)) - (entry-args (sod-message-argument-tail message)) - (parm-n (let ((tail (last entry-args 2))) + (raw-entry-args (sod-message-argument-tail message)) + (entry-args (sod-message-no-varargs-tail message)) + (parm-n (let ((tail (last raw-entry-args 2))) (and tail (eq (cadr tail) :ellipsis) (car tail)))) (entry-target (codegen-target codegen)) @@ -457,20 +431,36 @@ (ensure-var codegen "sod__obj" ilayout-type (make-convert-to-ilayout-inst class head "me")))) - (varargs-prologue () - (ensure-var codegen *sod-ap* (c-type va-list)) - (emit-inst codegen - (make-va-start-inst *sod-ap* - (argument-name parm-n)))) - (varargs-epilogue () - (emit-inst codegen (make-va-end-inst *sod-ap*))) (finish-entry (tail) (let* ((head (sod-class-chain-head tail)) - (name (method-entry-function-name method head nil)) + (role (if parm-n :valist nil)) + (name (method-entry-function-name method head role)) (type (c-type (fun (lisp return-type) ("me" (* (class tail))) . entry-args)))) - (codegen-pop-function codegen name type)))) + (codegen-pop-function codegen name type) + + ;; 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)))) + (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))) + (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)))))) ;; Generate the method body. We'll work out what to do with it later. (codegen-push codegen) @@ -493,9 +483,7 @@ (ensure-var codegen (inst-name var) (inst-type var) (inst-init var)) (emit-decl codegen var))) - (when parm-n (varargs-prologue)) (emit-insts codegen insts) - (when parm-n (varargs-epilogue)) (deliver-expr codegen entry-target result) (finish-entry tail))) @@ -513,15 +501,7 @@ emf-arg-tail))))) (dolist (tail chain-tails) (setup-entry tail) - (cond (parm-n - (varargs-prologue) - (convert-stmts codegen entry-target return-type - (lambda (target) - (deliver-expr codegen - target call) - (varargs-epilogue)))) - (t - (deliver-expr codegen entry-target call))) + (deliver-expr codegen entry-target call) (finish-entry tail))))))) (codegen-functions codegen))))