X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/4307347660f48628e307f299eb4fac58ba35fd1a..e895be217c3be6769708da17c9ae87cb22db040e:/src/method-impl.lisp diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 963f2fe..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,9 +51,6 @@ (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) (let ((role (get-property pset :role :keyword nil))) @@ -64,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) () @@ -153,9 +154,15 @@ (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)))) + ("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 (format nil "~A__~@[~(~A~)_~]method_~A__~A" class role @@ -217,7 +224,8 @@ (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) @@ -242,31 +250,56 @@ (t (push next-method-arg method-args))) (c-type (fun (lisp (c-type-subtype type)) - ("me" (* (class (sod-method-class method)))) + ("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. - (with-slots (message keywords) method - (setf keywords (and (keyword-message-p message) - (merge-keyword-lists - (mapcar (lambda (m) - (let ((type (sod-method-type m))) - (cons (c-function-keywords type) - (format nil "method for ~A on ~A" - message - (sod-method-class m))))) - direct-methods)))))) + ;; 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) @@ -288,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)) @@ -418,7 +451,8 @@ ((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) @@ -498,6 +532,38 @@ 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. @@ -519,20 +585,6 @@ (setf tab-act (namecheck "v->kw" key-name (codegen-pop-block codegen) tab-act)))) - ;; Deal with the special `kw.' keywords read via varargs. - (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.va_list" - (codegen-pop-block codegen) va-act)) - ;; Finish up the varargs loop. (emit-banner codegen "Parse keywords from the variable-length tail.") (codegen-push codegen) @@ -543,23 +595,8 @@ (emit-inst codegen (make-if-inst "ap" (make-block-inst nil (list loop))))) - ;; 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)) - - (emit-banner codegen "Parse keywords from the argument table.") - (codegen-push codegen) - (convert "aap" (c-type (* va-list))) - (call :void name "kw" "aap" *null-pointer* 0) - (setf tab-act (namecheck "v->kw" "kw.va_list" - (codegen-pop-block codegen) tab-act)) - ;; 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++")) @@ -648,7 +685,10 @@ ;; 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)))) @@ -658,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 ~:_~ @@ -683,7 +725,7 @@ (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) @@ -789,14 +831,24 @@ (*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 compute-method-entry-functions - ((method simple-effective-method)) - (if (effective-method-primary-methods 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))