X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/3aab0efa423fe20713c8cc02e8aabdf7fe84056b..e895be217c3be6769708da17c9ae87cb22db040e:/src/method-impl.lisp diff --git a/src/method-impl.lisp b/src/method-impl.lisp index db1e8d6..c1e1b24 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -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. @@ -52,13 +51,6 @@ (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) (let ((role (get-property pset :role :keyword nil))) @@ -68,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) () @@ -118,11 +115,53 @@ (declare (ignore slot-names)) (default-slot (method 'role) (get-property pset :role :keyword nil))) +(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 ((type (sod-method-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" (* (class (sod-method-class method)))) - . (c-function-arguments 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 %class) role message) method @@ -147,11 +186,8 @@ (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) @@ -177,35 +213,93 @@ (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))) + (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" (* (class (sod-method-class method)))) + ("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))) + (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" (* (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))))) + ("me" (lisp (sod-message-receiver-type + message (sod-method-class method)))) + . method-args)))) ;;;-------------------------------------------------------------------------- ;;; Effective method classes. +(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-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) @@ -227,9 +321,9 @@ using a slot reader method.")) (define-on-demand-slot basic-effective-method basic-argument-names (method) - (let ((message (effective-method-message method))) - (mapcar #'argument-name - (sod-message-no-varargs-tail message)))) + (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)) @@ -350,13 +444,179 @@ (let* ((method (method-entry-effective-method entry)) (message (effective-method-message method)) (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) (sod-message-argument-tail message)) - (:valist (sod-message-no-varargs-tail message))))) + ((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)))) + ("me" (lisp (sod-message-receiver-type + message (method-entry-chain-tail entry)))) . 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)) @@ -368,7 +628,9 @@ :chain-head chain-head :chain-tail chain-tail) entries))) - (when (varargs-message-p message) (make :valist)) + (when (or (varargs-message-p message) + (keyword-message-p message)) + (make :valist)) (make nil) entries))) @@ -411,15 +673,22 @@ (mapcar #'car (sod-class-chains class)))) (n-entries (length chain-tails)) - (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)))) + (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))))) + (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)))) @@ -429,13 +698,15 @@ (codegen-push codegen) (ensure-var codegen "sod__obj" ilayout-type (make-convert-to-ilayout-inst class - head "me")))) + head "me")) + (deliver-call codegen :void "SOD__IGNORE" "sod__obj"))) (finish-entry (tail) (let* ((head (sod-class-chain-head tail)) + (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 "~@(~@[~A ~]entry~) function ~:_~ @@ -447,14 +718,14 @@ (sod-message-name message) head class) - ;; If this is a varargs method then we've made the + ;; 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" (* (class tail))) + ("me" (lisp my-type)) . raw-entry-args)))) (codegen-push codegen) (ensure-var codegen *sod-ap* c-type-va-list) @@ -523,9 +794,61 @@ (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))