X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/11e41ddf86b4ee793f44fc0e39cb4c1869335b14..9e91c8e7b5fcdeb6389ac7ccbcd9c77348c4493a:/src/method-impl.lisp diff --git a/src/method-impl.lisp b/src/method-impl.lisp index b9543fd..0564d81 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 @@ -53,11 +53,7 @@ (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))) + (reify-variable-argument-tail (sod-message-argument-tail message))) (defmethod sod-message-method-class ((message basic-message) (class sod-class) pset) @@ -147,11 +143,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) @@ -178,8 +171,7 @@ (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))) (c-type (fun (lisp return-type) @@ -197,8 +189,7 @@ method))))) . (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) method-args) method-args))))) @@ -275,7 +266,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)))) @@ -339,7 +330,7 @@ (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)) @@ -422,10 +413,9 @@ ;; 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-arg-tail)))) + . entry-args)))) (flet ((setup-entry (tail) (let ((head (sod-class-chain-head tail))) @@ -440,29 +430,43 @@ (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 - (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) - (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) - (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) @@ -496,11 +500,15 @@ ;; 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) @@ -542,7 +550,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