X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4c3d168fcdd02d012f742a7b38ed52b9779c3f3c..e895be217c3be6769708da17c9ae87cb22db040e:/src/method-impl.lisp diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 6508f57..c1e1b24 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -30,8 +30,7 @@ (export 'basic-message) (defclass basic-message (sod-message) - ((argument-tail :type list :reader sod-message-argument-tail) - (no-varargs-tail :type list :reader sod-message-no-varargs-tail)) + ((argument-tail :type list :reader sod-message-argument-tail)) (:documentation "Base class for built-in message classes. @@ -40,33 +39,17 @@ 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))))) (defmethod sod-message-method-class ((message basic-message) (class sod-class) pset) @@ -77,6 +60,11 @@ ((nil) (error "How odd: a primary method slipped through the net")) (t (error "Unknown method role ~A" role))))) +(defmethod sod-message-receiver-type ((message sod-message) + (class sod-class)) + (c-type (* (class class + (and (sod-message-readonly-p message) :const))))) + (export 'simple-message) (defclass simple-message (basic-message) () @@ -104,7 +92,7 @@ ;;;-------------------------------------------------------------------------- ;;; 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)) @@ -120,25 +108,63 @@ 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)) - (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)))))) +(defun direct-method-suppliedp-struct-tag (direct-method) + (with-slots ((class %class) role message) direct-method + (format nil "~A__~@[~(~A~)_~]suppliedp_~A__~A" + class role + (sod-class-nickname (sod-message-class message)) + (sod-message-name message)))) + +(defun effective-method-keyword-struct-tag (effective-method) + (with-slots ((class %class) message) effective-method + (format nil "~A__keywords_~A__~A" + class + (sod-class-nickname (sod-message-class message)) + (sod-message-name message)))) + +(defun fix-up-keyword-method-args (method args) + "Adjust the ARGS to include METHOD's `suppliedp' and keyword arguments. + + Return the adjusted list. The `suppliedp' argument, if any, is prepended + to the list; the keyword arguments are added to the end. + + (The input ARGS list is not actually modified.)" + (let* ((type (sod-method-type method)) + (keys (c-function-keywords type)) + (tag (direct-method-suppliedp-struct-tag method))) + (append (and keys + (list (make-argument "suppliedp" (c-type (struct tag))))) + args + (mapcar (lambda (key) + (make-argument (argument-name key) + (argument-type key))) + keys)))) + +(define-on-demand-slot basic-direct-method function-type (method) + (let* ((message (sod-method-message method)) + (type (sod-method-type method)) + (method-args (c-function-arguments type))) + (when (keyword-message-p message) + (setf method-args (fix-up-keyword-method-args method method-args))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (lisp (sod-message-receiver-type + message (sod-method-class method)))) + . method-args)))) + +(defmethod sod-method-description ((method basic-direct-method)) + (with-slots (role) method + (if role (string-downcase role) + "primary"))) (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,12 +185,9 @@ (defmethod check-method-type ((method daemon-direct-method) (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)))) + (with-slots ((msgtype %type)) message + (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) @@ -184,50 +207,99 @@ 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) - (cons (make-argument *sod-master-ap* - (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)) + (arguments (cond ((varargs-message-p message) + (cons (make-argument *sod-master-ap* + c-type-va-list) + (butlast msgargs))) + ((keyword-message-p message) + (cons (make-argument *sod-keywords* + (c-type (* (void :const)))) + msgargs)) + (t + msgargs)))) + (c-type (fun (lisp return-type) + ("me" (lisp (sod-message-receiver-type + message (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)))))) + (method-args (c-function-arguments type)) + (next-method-arg (make-argument + "next_method" + (make-pointer-type + (commentify-function-type + (sod-method-next-method-type method)))))) + (cond ((varargs-message-p message) + (push (make-argument *sod-master-ap* c-type-va-list) + method-args) + (push next-method-arg method-args)) + ((keyword-message-p message) + (push (make-argument *sod-keywords* (c-type (* (void :const)))) + method-args) + (push next-method-arg method-args) + (setf method-args + (fix-up-keyword-method-args method method-args))) + (t + (push next-method-arg method-args))) + (c-type (fun (lisp (c-type-subtype type)) + ("me" (lisp (sod-message-receiver-type + message (sod-method-class method)))) + . method-args)))) ;;;-------------------------------------------------------------------------- ;;; Effective method classes. -(export 'basic-effective-method) +(defmethod sod-message-keyword-argument-lists + ((message sod-message) (class sod-class) direct-methods state) + (and (keyword-message-p message) + (cons (cons (lambda (arg) + (let ((class (sod-message-class message))) + (info-with-location + message "Type `~A' declared in message ~ + definition in `~A' (here)" + (argument-type arg) class) + (report-inheritance-path state class))) + (c-function-keywords (sod-message-type message))) + (mapcar (lambda (method) + (cons (lambda (arg) + (let ((class (sod-method-class method))) + (info-with-location + method "Type `~A' declared in ~A direct ~ + method of `~A' (defined here)" + (argument-type arg) + (sod-method-description method) class) + (report-inheritance-path state class))) + (c-function-keywords (sod-method-type method)))) + direct-methods)))) + +(defmethod sod-message-check-methods + ((message sod-message) (class sod-class) direct-methods) + (compute-effective-method-keyword-arguments message class direct-methods)) + +(defmethod shared-initialize :after + ((method effective-method) slot-names &key direct-methods) + (declare (ignore slot-names)) + + ;; Set the keyword argument list. Blame the class as a whole for mismatch + ;; errors, because they're fundamentally a non-local problem about the + ;; class construction. + (with-slots ((class %class) message keywords) method + (setf keywords + (compute-effective-method-keyword-arguments message + class + direct-methods)))) + +(export '(basic-effective-method + effective-method-around-methods effective-method-before-methods + effective-method-after-methods effective-method-functions)) (defclass basic-effective-method (effective-method) ((around-methods :initarg :around-methods :initform nil :type list :reader effective-method-around-methods) @@ -246,17 +318,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'.")) - -(defmethod slot-unbound (class - (method basic-effective-method) - (slot-name (eql 'basic-argument-names))) - (declare (ignore class)) - (let ((message (effective-method-message method))) - (setf (slot-value method 'basic-argument-names) - (mapcar #'argument-name - (sod-message-no-varargs-tail message))))) + using a slot reader method.")) + +(define-on-demand-slot basic-effective-method basic-argument-names (method) + (let* ((message (effective-method-message method)) + (raw-tail (sod-message-argument-tail message))) + (mapcar #'argument-name (reify-variable-argument-tail raw-tail)))) (defmethod effective-method-function-name ((method effective-method)) (let* ((class (effective-method-class method)) @@ -267,11 +334,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) @@ -303,7 +367,7 @@ (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)))) @@ -323,7 +387,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)) @@ -355,33 +420,219 @@ effective method out into its own function.") (defmethod method-entry-function-name - ((method effective-method) (chain-head sod-class)) + ((method effective-method) (chain-head sod-class) role) (let* ((class (effective-method-class method)) (message (effective-method-message method)) (message-class (sod-message-class message))) (if (or (not (slot-boundp method 'functions)) (slot-value method 'functions)) - (format nil "~A__mentry_~A__~A__chain_~A" - class + (format nil "~A__mentry~@[__~(~A~)~]_~A__~A__chain_~A" + class role (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)) + (message (effective-method-message method)) + (name (sod-message-name message)) + (role (method-entry-role entry))) + (method-entry-slot-name-by-role entry role name))) (defmethod method-entry-function-type ((entry method-entry)) (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) - (type (sod-message-type message))) + (type (sod-message-type message)) + (keywordsp (keyword-message-p message)) + (raw-tail (append (sod-message-argument-tail message) + (and keywordsp (list :ellipsis)))) + (tail (ecase (method-entry-role entry) + ((nil) raw-tail) + (:valist (reify-variable-argument-tail raw-tail))))) (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (method-entry-chain-tail entry)))) - . (sod-message-argument-tail message))))) + ("me" (lisp (sod-message-receiver-type + message (method-entry-chain-tail entry)))) + . tail)))) -(defmethod make-method-entry ((method basic-effective-method) - (chain-head sod-class) (chain-tail sod-class)) - (make-instance 'method-entry - :method method - :chain-head chain-head - :chain-tail chain-tail)) +(defgeneric effective-method-keyword-parser-function-name (method) + (:documentation + "Return the name of the keyword-parsing function for an effective METHOD. + + See `make-keyword-parser-function' for details of what this function + actually does.")) + +(defmethod effective-method-keyword-parser-function-name + ((method basic-effective-method)) + (with-slots ((class %class) message) method + (format nil "~A__kwparse_~A__~A" + class + (sod-class-nickname (sod-message-class message)) + (sod-message-name message)))) + +(defun make-keyword-parser-function (codegen method tag set keywords) + "Construct and return a keyword-argument parsing function. + + The function is contributed to the CODEGEN, with the name constructed from + the effective METHOD. It will populate an argument structure with the + given TAG. In case of error, it will mention the name SET in its report. + The KEYWORDS are a list of `argument' objects naming the keywords to be + accepted. + + The generated function has the signature + + void NAME(struct TAG *kw, va_list *ap, struct kwval *v, size_t n) + + It assumes that AP includes the first keyword name. (This makes it + different from the keyword-parsing functions generated by the + `KWSET_PARSEFN' macro, but this interface is slightly more convenient and + we don't need to cope with functions which accept no required + arguments.)" + + ;; Let's start, then. + (codegen-push codegen) + + ;; Set up the local variables we'll need. + (macrolet ((var (name type) + `(ensure-var codegen ,name (c-type ,type)))) + (var "k" const-string) + (var "aap" (* va-list)) + (var "t" (* (struct "kwtab" :const))) + (var "vv" (* (struct "kwval" :const))) + (var "nn" size-t)) + + (flet ((call (target func &rest args) + ;; Call FUNC with ARGS; return result in TARGET. + + (apply #'deliver-call codegen target func args)) + + (convert (target type) + ;; Fetch the object of TYPE pointed to by `v->val', and store it + ;; in TARGET. + + (deliver-expr codegen target + (format nil "*(~A)v->val" + (make-pointer-type (qualify-c-type + type (list :const)))))) + + (namecheck (var name conseq alt) + ;; Return an instruction: if VAR matches the string NAME then do + ;; CONSEQ; otherwise do ALT. + + (make-if-inst (make-call-inst "!strcmp" + var (prin1-to-string name)) + conseq alt))) + + ;; Prepare the main parsing loops. We're going to construct them both at + ;; the same time. They're not quite similar enough for it to be + ;; worthwhile abstracting this further, but carving up the keywords is + ;; too tedious to write out more than once. + (let ((va-act (make-expr-inst (make-call-inst "kw_unknown" set "k"))) + (tab-act (make-expr-inst (make-call-inst "kw_unknown" + set "v->kw"))) + (name (effective-method-keyword-parser-function-name method))) + + ;; Deal with the special `kw.' keywords read via varargs. We're + ;; building the dispatch up backwards, so if we do these first, they + ;; get checked last, which priviliges the function-specific arguments + ;; over these special effects. + (codegen-push codegen) + (call "vv" "va_arg" "*ap" (c-type (* (struct "kwval" :const)))) + (call "nn" "va_arg" "*ap" c-type-size-t) + (call :void name "kw" *null-pointer* "vv" "nn") + (setf va-act (namecheck "k" "kw.tab" + (codegen-pop-block codegen) va-act)) + + (codegen-push codegen) + (call "aap" "va_arg" "*ap" (c-type (* va-list))) + (call :void name "kw" "aap" *null-pointer* 0) + (setf va-act (namecheck "k" "kw.valist" + (codegen-pop-block codegen) va-act)) + + ;; Deal with the special `kw.' keywords read from a table. + (codegen-push codegen) + (deliver-expr codegen "t" + (format nil "(~A)v->val" + (c-type (* (struct "kwtab" :const))))) + (call :void name "kw" *null-pointer* "t->v" "t->n") + (setf tab-act (namecheck "v->kw" "kw.tab" + (codegen-pop-block codegen) tab-act)) + + (codegen-push codegen) + (convert "aap" (c-type (* va-list))) + (call :void name "kw" "aap" *null-pointer* 0) + (setf tab-act (namecheck "v->kw" "kw.valist" + (codegen-pop-block codegen) tab-act)) + + ;; Work through the keywords. We're going to be building up the + ;; conditional dispatch from the end, so reverse the (nicely sorted) + ;; list before processing it. + (dolist (key (reverse keywords)) + (let* ((key-name (argument-name key)) + (key-type (argument-type key))) + + ;; Handle the varargs case. + (codegen-push codegen) + (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1) + (call (format nil "kw->~A" key-name) "va_arg" "*ap" key-type) + (setf va-act (namecheck "k" key-name + (codegen-pop-block codegen) va-act)) + + ;; Handle the table case. + (codegen-push codegen) + (deliver-expr codegen (format nil "kw->~A__suppliedp" key-name) 1) + (convert (format nil "kw->~A" key-name) key-type) + (setf tab-act (namecheck "v->kw" key-name + (codegen-pop-block codegen) tab-act)))) + + ;; Finish up the varargs loop. + (emit-banner codegen "Parse keywords from the variable-length tail.") + (codegen-push codegen) + (call "k" "va_arg" "*ap" c-type-const-string) + (emit-inst codegen (make-if-inst "!k" (make-break-inst))) + (emit-inst codegen va-act) + (let ((loop (make-for-inst nil nil nil (codegen-pop-block codegen)))) + (emit-inst codegen + (make-if-inst "ap" (make-block-inst nil (list loop))))) + + ;; Finish off the table loop. + (emit-banner codegen "Parse keywords from the argument table.") + (codegen-push codegen) + (emit-inst codegen tab-act) + (emit-inst codegen (make-expr-inst "v++")) + (emit-inst codegen (make-expr-inst "n--")) + (emit-inst codegen (make-while-inst "n" (codegen-pop-block codegen))) + + ;; Wrap the whole lot up with a nice bow. + (let ((message (effective-method-message method))) + (codegen-pop-function codegen name + (c-type (fun void + ("kw" (* (struct tag))) + ("ap" (* va-list)) + ("v" (* (struct "kwval" :const))) + ("n" size-t))) + "Keyword parsing for `~A.~A' on class `~A'." + (sod-class-nickname + (sod-message-class message)) + (sod-message-name message) + (effective-method-class method)))))) + +(defmethod make-method-entries ((method basic-effective-method) + (chain-head sod-class) + (chain-tail sod-class)) + (let ((entries nil) + (message (effective-method-message method))) + (flet ((make (role) + (push (make-instance 'method-entry + :method method :role role + :chain-head chain-head + :chain-tail chain-tail) + entries))) + (when (or (varargs-message-p message) + (keyword-message-p message)) + (make :valist)) + (make nil) + entries))) (defmethod compute-method-entry-functions ((method basic-effective-method)) @@ -416,53 +667,84 @@ :class class :method method)) - ;; Effective method function details. - (emf-name (effective-method-function-name method)) - (ilayout-type (c-type (* (struct (ilayout-struct-tag class))))) - (emf-arg-tail (mapcar (lambda (arg) - (if (eq (argument-name arg) *sod-ap*) - (make-argument *sod-master-ap* - (c-type va-list)) - arg)) - (sod-message-no-varargs-tail message))) - (emf-type (c-type (fun (lisp return-type) - ("sod__obj" (lisp ilayout-type)) - . (sod-message-no-varargs-tail message)))) - ;; Method entry details. (chain-tails (remove-if-not (lambda (super) (sod-subclass-p super message-class)) (mapcar #'car (sod-class-chains class)))) (n-entries (length chain-tails)) - (entry-args (sod-message-argument-tail message)) - (parm-n (do ((prev "me" (car args)) - (args entry-args (cdr args))) - ((endp args) nil) - (when (eq (car args) :ellipsis) - (return prev)))) - (entry-target (codegen-target codegen))) + (raw-entry-args (append (sod-message-argument-tail message) + (and (keyword-message-p message) + (list :ellipsis)))) + (entry-args (reify-variable-argument-tail raw-entry-args)) + (parm-n (let ((tail (last (cons (make-argument "me" c-type-void) + raw-entry-args) 2))) + (and tail (eq (cadr tail) :ellipsis) + (argument-name (car tail))))) + (entry-target (codegen-target codegen)) + + ;; Effective method function details. + (emf-name (effective-method-function-name method)) + (ilayout-type (c-type (* (struct (ilayout-struct-tag class) + (and (sod-message-readonly-p + message) + :const))))) + (emf-type (c-type (fun (lisp return-type) + ("sod__obj" (lisp ilayout-type)) + . entry-args)))) (flet ((setup-entry (tail) (let ((head (sod-class-chain-head tail))) (codegen-push codegen) (ensure-var codegen "sod__obj" ilayout-type (make-convert-to-ilayout-inst class - head "me")))) - (varargs-prologue () - (ensure-var codegen *sod-master-ap* (c-type va-list)) - (emit-inst codegen - (make-va-start-inst *sod-master-ap* - (argument-name parm-n)))) - (varargs-epilogue () - (emit-inst codegen (make-va-end-inst *sod-master-ap*))) + head "me")) + (deliver-call codegen :void "SOD__IGNORE" "sod__obj"))) (finish-entry (tail) (let* ((head (sod-class-chain-head tail)) - (name (method-entry-function-name method head)) + (my-type (sod-message-receiver-type message tail)) + (role (if parm-n :valist nil)) + (name (method-entry-function-name method head role)) (type (c-type (fun (lisp return-type) - ("me" (* (class tail))) + ("me" (lisp my-type)) . 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 or keyword method then we've made the + ;; `:valist' role. Also make the `nil' role. + (when parm-n + (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" (lisp my-type)) + . raw-entry-args)))) + (codegen-push codegen) + (ensure-var codegen *sod-ap* c-type-va-list) + (convert-stmts codegen entry-target return-type + (lambda (target) + (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) @@ -485,9 +767,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))) @@ -498,29 +778,77 @@ ;; 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) - (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)))) -(defmethod compute-method-entry-functions - ((method simple-effective-method)) - (if (effective-method-primary-methods method) +(defmethod compute-effective-method-body :around + ((method basic-effective-method) codegen target) + (let* ((message (effective-method-message method)) + (keywordsp (keyword-message-p message)) + (keywords (effective-method-keywords method)) + (ap-addr (format nil "&~A" *sod-tmp-ap*)) + (set (format nil "\"~A:~A.~A\"" + (sod-class-name (effective-method-class method)) + (sod-class-nickname (sod-message-class message)) + (sod-message-name message)))) + (labels ((call (target func &rest args) + (apply #'deliver-call codegen target func args)) + (parse-keywords (body) + (ensure-var codegen *sod-tmp-ap* c-type-va-list) + (call :void "va_copy" *sod-tmp-ap* *sod-ap*) + (funcall body) + (call :void "va_end" *sod-tmp-ap*))) + (cond ((not keywordsp) + (call-next-method)) + ((null keywords) + (let ((*keyword-struct-disposition* :null)) + (parse-keywords (lambda () + (with-temporary-var + (codegen kw c-type-const-string) + (call kw "va_arg" + *sod-tmp-ap* c-type-const-string) + (call :void "kw_parseempty" set + kw ap-addr *null-pointer* 0)))) + (call-next-method))) + (t + (let* ((name + (effective-method-keyword-parser-function-name method)) + (tag (effective-method-keyword-struct-tag method)) + (kw-addr (format nil "&~A" *sod-keywords*)) + (*keyword-struct-disposition* :local)) + (ensure-var codegen *sod-keywords* (c-type (struct tag))) + (make-keyword-parser-function codegen method tag set keywords) + (emit-insts codegen + (mapcar (lambda (keyword) + (make-set-inst + (format nil "~A.~A__suppliedp" + *sod-keywords* + (argument-name keyword)) + 0)) + keywords)) + (parse-keywords (lambda () + (call :void name kw-addr ap-addr + *null-pointer* 0))) + (call-next-method))))))) + +(defmethod effective-method-live-p ((method simple-effective-method)) + (effective-method-primary-methods method)) + +(defmethod compute-method-entry-functions :around ((method effective-method)) + (if (effective-method-live-p method) (call-next-method) nil)) @@ -552,7 +880,7 @@ (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