(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.
(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)))
(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)))))
+ . method-args))))
(defmethod sod-method-function-name ((method basic-direct-method))
(with-slots ((class %class) role message) method
(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))))
. 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)))))
+ . method-args))))
;;;--------------------------------------------------------------------------
;;; Effective method classes.
+(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))
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))
(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))))
. 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))
+
+ ;; 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))
: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)))
(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.
(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))
(role (if parm-n :valist nil))
(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"
(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))
~mdw / sod / blobdiff