;;;----- 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
(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.
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)
(call-next-method)
(primary-method-class message)))
+(defmethod primary-method-class ((message simple-message))
+ 'basic-direct-method)
+
;;;--------------------------------------------------------------------------
;;; 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))
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" (* (class (sod-method-class method))))
+ . method-args))))
(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))))
(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)
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))
- (type (sod-message-type message)))
- (setf (slot-value method 'next-method-type)
- (c-type (fun (lisp (c-type-subtype type))
- ("me" (* (class (sod-method-class method))))
- .
- (c-function-arguments type))))))
-
-(defmethod slot-unbound (class
- (method delegating-direct-method)
- (slot-name (eql 'function-type)))
- (declare (ignore class))
+ (return-type (c-type-subtype (sod-message-type message)))
+ (msgargs (sod-message-argument-tail message))
+ (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))))
+ . 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" (* (class (sod-method-class method))))
+ . method-args))))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
-(export 'basic-effective-method)
+(defmethod method-keyword-argument-lists
+ ((method effective-method) direct-methods)
+ (with-slots (message) method
+ (and (keyword-message-p message)
+ (mapcar (lambda (m)
+ (let ((type (sod-method-type m)))
+ (cons (c-function-keywords type)
+ (format nil "method for ~A on ~A (at ~A)"
+ message
+ (sod-method-class m)
+ (file-location m)))))
+ 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
+ (merge-keyword-lists (method-keyword-argument-lists
+ method direct-methods)))))
+
+(export '(basic-effective-method
+ effective-method-around-methods effective-method-before-methods
+ effective-method-after-methods))
(defclass basic-effective-method (effective-method)
((around-methods :initarg :around-methods :initform nil
:type list :reader effective-method-around-methods)
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)
- (subst *sod-master-ap* *sod-ap*
- (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))
(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)
(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))))
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))
- (voidp (eq return-type (c-type void)))
(basic-tail (effective-method-basic-argument-names method)))
(flet ((method-kernel (target)
(dolist (before before-methods)
(invoke-method codegen :void basic-tail before))
- (if (or voidp (null after-methods))
+ (if (null after-methods)
(funcall body target)
(convert-stmts codegen target return-type
(lambda (target)
(funcall body target)
(dolist (after (reverse after-methods))
(invoke-method codegen :void
- after basic-tail)))))))
+ basic-tail after)))))))
(invoke-delegation-chain codegen target basic-tail
around-methods #'method-kernel)))))
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)))))
+ . 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)))
+
+ ;; 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))))
+
+ ;; 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)
+ (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)))))
+
+ ;; 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))
-(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))
+ ;; Finish off the table loop.
+ (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))
: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)))))
+ (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* 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))
+ (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
+ "~@(~@[~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" (* (class tail)))
+ . 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)
- (let* ((result (if (eq return-type (c-type void)) nil
+ (let* ((result (if (eq return-type c-type-void) nil
(temporary-var codegen return-type)))
(emf-target (or result :void)))
(compute-effective-method-body method codegen emf-target)
(dolist (tail chain-tails)
(setup-entry tail)
(dolist (var vars)
- (ensure-var codegen (inst-name var)
- (inst-type var) (inst-init var)))
- (when parm-n (varargs-prologue))
+ (if (typep var 'var-inst)
+ (ensure-var codegen (inst-name var)
+ (inst-type var) (inst-init var))
+ (emit-decl codegen var)))
(emit-insts codegen insts)
- (when parm-n (varargs-epilogue))
(deliver-expr codegen entry-target result)
(finish-entry tail)))
;; 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))
(defmethod compute-effective-method-body
((method simple-effective-method) codegen target)
- (with-slots (message basic-argument-names primary-methods) method
- (basic-effective-method-body codegen target method
- (lambda (target)
- (simple-method-body method
- codegen
- target)))))
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target))))
;;;--------------------------------------------------------------------------
;;; Standard method combination.
(defclass standard-message (simple-message)
()
(:documentation
- "Message class for standard method combination.
+ "Message class for standard method combinations.
Standard method combination is a simple method combination where the
primary methods are invoked as a delegation chain, from most- to
(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
~mdw / sod / blobdiff