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)))
+(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))
+ (tail (ecase (method-entry-role entry)
+ ((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))))
- . (sod-message-argument-tail message)))))
-
-(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))
+ . tail))))
+
+(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 (varargs-message-p message) (make :valist))
+ (make nil)
+ entries)))
(defmethod compute-method-entry-functions ((method basic-effective-method))
(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))
(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))
+ (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)
(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)))
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))))