Let's start with the new functionality.
You can define messages which are meant to be given keyword arguments,
and methods which retrieve and (presumably) act on those keywords. The
behaviour is as in Common Lisp: the acceptable keywords for a message
sent to an object are precisely those keywords acceptable to any
applicable method, and those listed in the message definition itself.
The Sod translator takes care of picking keyword argument lists apart
and passing actual arguments to the direct methods; arguments can have
default values (and each direct method can have different defaults),
and/or find out whether a keyword was actually provided. The only picky
rule is that if two methods (or a method and the message itself) each
define an argument with the same keyword, then those arguments must also
have the same type.
The new code -- and there's quite a lot of it -- mostly concerns itself
with coping with messages and methods which accept keyword arguments,
and generating the proper functions and instructions for gathering them
and passing them about. This is rather annoying and fiddly.
In particular, it seems as if I ought to be able to have factored the
existing machinery much better than I actually did if only I were more
clever, so that this new stuff could slot in neatly; instead, it looks
as if I just turned the program upside-down and shook hard, which is
pretty accurate really.
effective-method-basic-argument-names generic
effective-method-class generic
effective-method-function-name generic
+ effective-method-keywords generic
effective-method-message generic
ensure-ilayout-var function
inst-chain-head generic
inst-expr generic
invoke-delegation-chain function
invoke-method function
+ keyword-message-p function
make-convert-to-ilayout-inst function
make-method-entries generic
make-trampoline function
compute-cpl
sod-class
compute-effective-method-body
+ basic-effective-method t t
simple-effective-method t t
compute-effective-methods
sod-class
effective-method
effective-method-function-name
effective-method
+effective-method-keywords
+ effective-method
effective-method-message
effective-method
effective-slot-class
basic-direct-method t
c-function-type t
c-keyword-function-type t
+ effective-method t
method-codegen t
module t
sequencer t
\end{enumerate}
Keyword arguments are provided as a general feature for C functions.
+However, Sod has special support for messages which accept keyword arguments
+(\xref{sec:concepts.methods.keywords}).
%%%--------------------------------------------------------------------------
\section{Messages and methods} \label{sec:concepts.methods}
$M$ is a more (resp.\ less) specific superclass of~$C$ than the class
defining $N$.
-\subsection{The standard method combination}
-\label{sec:concepts.methods.standard}
-
+\subsubsection{The standard method combination}
The default method combination is called the \emph{standard method
combination}; other method combinations are useful occasionally for special
effects. The standard method combination accepts four direct method roles,
@|CALL_NEXT_METHOD| will pass along the updated values, rather than the
original ones.
-\subsection{Aggregating method combinations}
-\label{sec:concepts.methods.aggregating}
-
+\subsubsection{Aggregating method combinations}
A number of other method combinations are provided. They are called
`aggregating' method combinations because, instead of invoking just the most
specific primary method, as the standard method combination does, they invoke
There is also a @|custom| aggregating method combination, which is described
in \xref{sec:fixme.custom-aggregating-method-combination}.
+
+\subsection{Messages with keyword arguments}
+\label{sec:concepts.methods.keywords}
+
+A message or a direct method may declare that it accepts keyword arguments.
+A message which accepts keyword arguments is called a \emph{keyword message};
+a direct method which accepts keyword arguments is called a \emph{keyword
+method}.
+
+While method combinations may set their own rules, usually keyword methods
+can only be defined on keyword messages, and all methods defined on a keyword
+message must be keyword methods. The direct methods defined on a keyword
+message may differ in the keywords they accept, both from each other, and
+from the message. If two superclasses of some common class both define
+keyword methods on the same message, and the methods both accept a keyword
+argument with the same name, then these two keyword arguments must also have
+the same type. Different applicable methods may declare keyword arguments
+with the same name but different defaults; see below.
+
+The keyword arguments acceptable in a message sent to an object are the
+keywords listed in the message definition, together with all of the keywords
+accepted by any applicable method. There is no easy way to determine at
+runtime whether a particular keyword is acceptable in a message to a given
+instance.
+
+At runtime, a direct method which accepts one or more keyword arguments
+receives an additional argument named @|suppliedp|. This argument is a small
+structure. For each keyword argument named $k$ accepted by the direct
+method, @|suppliedp| contains a one-bit-wide bitfield member of type
+@|unsigned|, also named $k$. If a keyword argument named $k$ was passed in
+the message, then @|suppliedp.$k$| is one, and $k$ contains the argument
+value; otherwise @|suppliedp.$k$| is zero, and $k$ contains the default value
+from the direct method definition if there was one, or an unspecified value
+otherwise.
+
%%%--------------------------------------------------------------------------
\section{Metaclasses} \label{sec:concepts.metaclasses}
%%%--------------------------------------------------------------------------
\section{Method combination} \label{sec:layout.methods}
-\begin{describe}{cls}{effective-method () \&key :message :class}
+\begin{describe}{cls}{effective-method () \&key :message :class :keywords}
\end{describe}
\begin{describe*}
{\dhead{gf}{effective-method-message @<method> @> @<message>}
- \dhead{gf}{effective-method-class @<method> @> @<class>}}
+ \dhead{gf}{effective-method-class @<method> @> @<class>}
+ \dhead{gf}{effective-method-keywords @<method> @> @<list>}}
\end{describe*}
\begin{describe}{gf}
\begin{describe}{fun}{varargs-message-p @<message> @> @<generalized-boolean>}
\end{describe}
+\begin{describe}{fun}{keyword-message-p @<message> @> @<generalized-boolean>}
+\end{describe}
+
\begin{describe}{gf}{method-entry-function-type @<entry> @> @<c-type>}
\end{describe}
The concrete types described in \xref{sec:structures.common} and
\ref{sec:structures.root} are declared by the header file @|<sod/sod.h>|.
-The definitions described in sections \ref{sec:structures.layout} are defined
-in the header file generated by the containing module.
+The definitions described in \xref{sec:structures.layout} are defined in the
+header file generated by the containing module.
%%%--------------------------------------------------------------------------
\section{Common instance structure} \label{sec:structures.common}
\begin{prog}
@<type>_0 $m$(@<type>_1 @<arg>_1, $\ldots$, @<type>_n @<arg>_n, \dots);
\end{prog}
+or a standard message which takes keyword arguments, defined as
+\begin{prog}
+ @<type>_0 $m$(\=@<type>_1 @<arg>_1, $\ldots$, @<type>_n @<arg>_n? \+ \\
+ @<type>_{n+1} @<kw>_{n+1} @[= @<dflt>_{n+1}@], $\ldots$,
+ @<type>_m @<kw>_m @[= @<dflt>_m@]);
+\end{prog}
two entry points are defined: the usual `main' entry point which accepts a
variable number of arguments, and a `valist' entry point which accepts an
argument of type @|va_list| in place of the variable portion of the argument
-list.
+list or keywords.
\begin{prog}
@<type>_0 $m$($C$ *me, @<type>_1 @<arg>_1, $\ldots$,
@<type>_n @<arg>_n, \dots); \\
which makes sending the message $m$ to an instance of (any subclass of) $C$
somewhat less ugly.
-If $m$ takes a variable number of arguments, the macro is more complicated
-and is only available in compilers advertising C99 support, but the effect is
-the same. For each variable-argument message, there is also an additional
-macro for calling the `valist' entry point.
+If $m$ takes a variable number of arguments, or keyword arguments, the macro
+is more complicated and is only available in compilers advertising C99
+support, but the effect is the same. For each variable-argument message,
+there is also an additional macro for calling the `valist' entry point.
\begin{prog}
\#define $C$_$m$__v(@<me>, $\ldots$, @<sod__ap>)
@<me>@->_vt@->$c$.$m$__v(@<me>, $\ldots$, @<sod__ap>)
\subsubsection{Declarators}
\begin{grammar}
-<declarator>$[k]$ ::= @<pointer>^* <primary-declarator>$[k]$
+<declarator>$[k, a]$ ::= @<pointer>^* <primary-declarator>$[k, a]$
-<primary-declarator>$[k]$ ::= $k$
-\alt "(" <primary-declarator>$[k]$ ")"
-\alt <primary-declarator>$[k]$ @<declarator-suffix>
+<primary-declarator>$[k, a]$ ::= $k$
+\alt "(" <primary-declarator>$[k, a]$ ")"
+\alt <primary-declarator>$[k, a]$ @<declarator-suffix>$[a]$
<pointer> ::= "*" @<qualifier>^*
-<declarator-suffix> ::= "[" <c-fragment> "]"
-\alt "(" <arguments> ")"
+<declarator-suffix>$[a]$ ::= "[" <c-fragment> "]"
+\alt "(" $a$ ")"
<argument-list> ::= $\epsilon$ | "..."
\alt <list>$[\mbox{@<argument>}]$ @["," "..."@]
<argument> ::= @<declaration-specifier>^+ <argument-declarator>
-<argument-declarator> ::= <declarator>$[\mbox{@<identifier> @! $\epsilon$}]$
+<argument-declarator> ::=
+ <declarator>$[\mbox{@<identifier> @! $\epsilon$}, \mbox{@<argument-list>}]$
-<simple-declarator> ::= <declarator>$[\mbox{@<identifier>}]$
-
-<dotted-name> ::= <identifier> "." <identifier>
+<simple-declarator> ::=
+ <declarator>$[\mbox{@<identifier>}, \mbox{@<argument-list>}]$
\end{grammar}
The declarator syntax is taken from C, but with some differences.
The remaining differences are (I hope) a matter of presentation rather than
substance.
+There is additional syntax to support messages and methods which accept
+keyword arguments.
+
+\begin{grammar}
+<keyword-argument> ::= <argument> @["=" <c-fragment>@]
+
+<keyword-argument-list> ::=
+ @[<list>$[\mbox{@<argument>}]$@]
+ "?" @[<list>$[\mbox{@<keyword-argument>}]$@]
+
+<method-argument-list> ::= <argument-list> @! <keyword-argument-list>
+
+<dotted-name> ::= <identifier> "." <identifier>
+
+<keyword-declarator>$[k]$ ::=
+ <declarator>$[k, \mbox{@<method-argument-list>}]$
+\end{grammar}
+
\subsection{Class definitions} \label{sec:syntax.module.class}
.IB an ,
.B ...);
.PP
+or a standard message which takes keyword arguments,
+defined as
+.IP
+.I tr
+.IB m ( \c
+.I t1
+.IB a1 ,
+.RB ... ,
+.I tn
+.IB an ?\&
+.IR tn +1
+.IR kn +1
+.RB [ =
+.IR dn +1] \c
+.B ,
+.I tm
+.I km
+.RB [ =
+.IR dm ] \c
+);
+.PP
two entry points are defined:
the usual `main' entry point
which accepts a variable number of
and a `valist' entry point
which accepts an argument of type
.B va_list
-in place of the variable portion of the argument list.
+in place of the variable portion of the argument list
+or keywords.
.IP
.I tr
.BI (* m )( \c
If
.I m
takes a variable number of arguments,
+or keyword arguments,
the macro is more complicated
and is only available in compilers advertising C99 support,
but the effect is the same.
"Signal an error unless METHOD-TYPE and MESSAGE-TYPE have matching argument
lists.
- This checks that the two types have matching lists of arguments."
+ This checks that (a) the two types have matching lists of mandatory
+ arguments, and (b) that either both or neither types accept keyword
+ arguments."
+ (let ((message-keywords-p (typep message-type 'c-keyword-function-type))
+ (method-keywords-p (typep method-type 'c-keyword-function-type)))
+ (cond (message-keywords-p
+ (unless method-keywords-p
+ (error "Method must declare a keyword argument list")))
+ (method-keywords-p
+ (error "Method must not declare a keyword argument list"))))
(unless (argument-lists-compatible-p (c-function-arguments message-type)
(c-function-arguments method-type))
(error "Method arguments ~A don't match message ~A"
(class :vtmsgs :start) (class :vtmsgs :end)
(class :vtables :start) (class :vtables :end)
(class :vtable-externs) (class :vtable-externs-after)
- (class :methods :start) (class :methods) (class :methods :end)
+ (class :methods :start) (class :methods :defs)
+ (class :methods) (class :methods :end)
(class :ichains :start) (class :ichains :end)
(class :ilayout :start) (class :ilayout :slots) (class :ilayout :end)
(class :conversions)
;; We need each message's method entry type for this, so we need to dig it
;; out of the vtmsgs structure. Indeed, the vtmsgs for this class contains
;; entries for precisely the messages we want to make macros for.
- (when (some #'varargs-message-p (sod-class-messages class))
+ (when (some (lambda (message)
+ (or (keyword-message-p message)
+ (varargs-message-p message)))
+ (sod-class-messages class))
(one-off-output 'varargs-macros sequencer :early-decls
(lambda (stream)
(format stream
(princ "extern " stream)
(pprint-c-type (commentify-function-type type) stream
(sod-method-function-name method))
- (format stream ";~%"))))))
+ (format stream ";~%")))
+ ((class :methods :defs)
+ (let* ((type (sod-method-type method))
+ (keys (and (typep type 'c-keyword-function-type)
+ (c-function-keywords type))))
+ (when keys
+ (format stream "struct ~A {~%~
+ ~{ unsigned ~A : 1;~%~}~
+ };~2%"
+ (direct-method-suppliedp-struct-tag method)
+ (mapcar #'argument-name keys))))))))
(defmethod hook-output progn ((vtable vtable) (reason (eql :h)) sequencer)
(with-slots ((class %class) chain-head chain-tail) vtable
(with-slots ((class %class) functions) method
(sequence-output (stream sequencer)
((class :effective-methods)
+ (let* ((keys (effective-method-keywords method))
+ (message (effective-method-message method))
+ (msg-class (sod-message-class message)))
+ (when keys
+ (format-banner-comment stream "Keyword argument structure ~:_~
+ for `~A.~A' ~:_on class `~A'."
+ (sod-class-nickname msg-class)
+ (sod-message-name message)
+ class)
+ (format stream "~&struct ~A {~%"
+ (effective-method-keyword-struct-tag method))
+ (format stream "~{ unsigned ~A__suppliedp : 1;~%~}"
+ (mapcar #'argument-name keys))
+ (dolist (key keys)
+ (write-string " " stream)
+ (pprint-c-type (argument-type key) stream (argument-name key))
+ (format stream ";~%"))
+ (format stream "};~2%")))
(dolist (func functions)
(write func :stream stream :escape nil :circle nil))))))
(make-instance 'temporary-name :tag "sod__tmp_ap"))
(defparameter *sod-tmp-val*
(make-instance 'temporary-name :tag "sod__t"))
+(defparameter *sod-keywords*
+ (make-instance 'temporary-name :tag "sod__kw"))
+(defparameter *sod-key-pointer*
+ (make-instance 'temporary-name :tag "sod__keys"))
(export '*null-pointer*)
(defparameter *null-pointer* "NULL")
(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 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))))))
+
(export '(basic-effective-method
effective-method-around-methods effective-method-before-methods
effective-method-after-methods))
(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.
(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-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)
+ (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)
;;;--------------------------------------------------------------------------
;;; Effective methods and entries.
-(export '(effective-method effective-method-message effective-method-class))
+(export '(effective-method
+ effective-method-message effective-method-class
+ effective-method-keywords))
(defclass effective-method ()
((message :initarg :message :type sod-message
:reader effective-method-message)
- (%class :initarg :class :type sod-class :reader effective-method-class))
+ (%class :initarg :class :type sod-class :reader effective-method-class)
+ (keywords :type list :reader effective-method-keywords))
(:documentation
"The behaviour invoked by sending a message to an instance of a class.
This is not a useful class by itself. Message classes are expected to
define their own effective-method classes.
- An effective method class must accept a `:direct-methods' initarg, which
+ An effective method class may accept a `:direct-methods' initarg, which
will be a list of applicable methods sorted in most-to-least specific
- order. (Either that or you have to add an overriding method to
- `compute-sod-effective-method'."))
+ order."))
(export 'sod-message-effective-method-class)
(defgeneric sod-message-effective-method-class (message)
(:documentation
"Return the C function name for the direct method."))
+(export 'keyword-message-p)
+(defun keyword-message-p (message)
+ "Answer whether the MESSAGE accepts a keyword arguments.
+
+ Dealing with keyword messages is rather fiddly, so this is useful to
+ know."
+ (typep (sod-message-type message) 'c-keyword-function-type))
+
(export 'varargs-message-p)
(defun varargs-message-p (message)
"Answer whether the MESSAGE accepts a variable-length argument list.
"Return a list of argument names to be passed to direct methods.
The argument names are constructed from the message's arguments returned
- by `sod-message-no-varargs-tail'. The basic arguments are the ones
- immediately derived from the programmer's explicitly stated arguments; the
- `me' argument is not included, and neither are more exotic arguments added
- as part of the method delegation protocol."))
+ by `sod-message-argument-tail', with any ellipsis replaced by an explicit
+ `va_list' argument. The basic arguments are the ones immediately derived
+ from the programmer's explicitly stated arguments; the `me' argument is
+ not included, and neither are more exotic arguments added as part of the
+ method delegation protocol."))
;;;--------------------------------------------------------------------------
;;; Code generation.
Writes the function body to the code generator. It can (obviously)
generate auxiliary functions if it needs to.
- The arguments are as specified by the `sod-message-no-varargs-tail', with
- an additional argument `sod__obj' of type pointer-to-ilayout. The code
- should deliver the result (if any) to the TARGET."))
+ The arguments are as determined by agreement with the generic function
+ `compute-method-entry-functions'; usually this will be as specified by the
+ `sod-message-argument-tail', with any variable-argument tail reified to a
+ `va_list', and an additional argument `sod__obj' of type pointer-to-
+ ilayout. The code should deliver the result (if any) to the TARGET."))
(export 'simple-method-body)
(defgeneric simple-method-body (method codegen target)
;;; Utilities.
+(defvar *keyword-struct-disposition* :unset
+ "The current state of the keyword structure.
+
+ This can be one of four values.
+
+ * `:unset' -- the top-level default, mostly because I can't leave it
+ unbound and write this documentation. Nothing that matters should see
+ this state.
+
+ * `:local' -- the structure itself is in a local variable `sod__kw'.
+ This is used in the top-level effective method.
+
+ * `:pointer' -- the structure is pointed to by the local variable
+ `sod__kw'. This is used by delegation-chain trampolines.
+
+ * `:null' -- there is in fact no structure because none of the
+ applicable methods actually define any keywords.")
+
+(defun keyword-access (name &optional suffix)
+ "Return an lvalue designating a named member of the keyword struct.
+
+ If a non-nil SUFFIX is provided, then the member is named NAMESUFFIX."
+ (flet ((mem (op)
+ (format nil "~A~A~A~@[~A~]" *sod-keywords* op name suffix)))
+ (ecase *keyword-struct-disposition*
+ (:local (mem "."))
+ (:pointer (mem "->")))))
+
+(let ((kw-addr (format nil "&~A" *sod-keywords*)))
+ (defun keyword-struct-pointer ()
+ "Return a pointer to the keyword structure."
+ (ecase *keyword-struct-disposition*
+ (:local kw-addr)
+ (:pointer *sod-keywords*)
+ (:null *null-pointer*))))
+
(export 'invoke-method)
(defun invoke-method (codegen target arguments-tail direct-method)
"Emit code to invoke DIRECT-METHOD, passing it ARGUMENTS-TAIL.
(let* ((message (sod-method-message direct-method))
(class (sod-method-class direct-method))
(function (sod-method-function-name direct-method))
- (arguments (cons (format nil "&sod__obj->~A.~A"
- (sod-class-nickname
- (sod-class-chain-head class))
- (sod-class-nickname class))
- arguments-tail)))
- (if (varargs-message-p message)
- (convert-stmts codegen target
- (c-type-subtype (sod-method-type direct-method))
- (lambda (var)
- (ensure-var codegen *sod-tmp-ap* c-type-va-list)
- (deliver-call codegen :void "va_copy"
- *sod-tmp-ap* *sod-ap*)
- (apply #'deliver-call codegen var
- function arguments)
- (deliver-call codegen :void "va_end" *sod-tmp-ap*)))
- (apply #'deliver-call codegen target function arguments))))
+ (type (sod-method-type direct-method))
+ (keywordsp (keyword-message-p message))
+ (keywords (and keywordsp (c-function-keywords type)))
+ (arguments (append (list (format nil "&sod__obj->~A.~A"
+ (sod-class-nickname
+ (sod-class-chain-head class))
+ (sod-class-nickname class)))
+ arguments-tail
+ (mapcar (lambda (arg)
+ (let ((name (argument-name arg))
+ (default (argument-default arg)))
+ (if default
+ (make-cond-inst
+ (keyword-access name
+ "__suppliedp")
+ (keyword-access name)
+ default)
+ (keyword-access name))))
+ keywords))))
+ (cond ((varargs-message-p message)
+ (convert-stmts codegen target (c-type-subtype type)
+ (lambda (var)
+ (ensure-var codegen *sod-tmp-ap* c-type-va-list)
+ (deliver-call codegen :void "va_copy"
+ *sod-tmp-ap* *sod-ap*)
+ (apply #'deliver-call codegen var
+ function arguments)
+ (deliver-call codegen :void "va_end"
+ *sod-tmp-ap*))))
+ (keywords
+ (let ((tag (direct-method-suppliedp-struct-tag direct-method)))
+ (with-temporary-var (codegen spvar (c-type (struct tag)))
+ (dolist (arg keywords)
+ (let ((name (argument-name arg)))
+ (deliver-expr codegen (format nil "~A.~A" spvar name)
+ (keyword-access name "__suppliedp"))))
+ (setf arguments (list* (car arguments) spvar
+ (cdr arguments)))
+ (apply #'deliver-call codegen target function arguments))))
+ (t
+ (apply #'deliver-call codegen target function arguments)))))
(export 'ensure-ilayout-var)
(defun ensure-ilayout-var (codegen super)
(method (codegen-method codegen))
(return-type (c-type-subtype message-type))
(raw-args (sod-message-argument-tail message))
- (arguments (if (varargs-message-p message)
- (cons (make-argument *sod-ap* c-type-va-list)
- (butlast raw-args))
- raw-args)))
+ (arguments (cond ((varargs-message-p message)
+ (cons (make-argument *sod-ap* c-type-va-list)
+ (butlast raw-args)))
+ ((keyword-message-p message)
+ (cons (make-argument *sod-key-pointer*
+ (c-type (* (void :const))))
+ raw-args))))
+ (*keyword-struct-disposition* t))
(codegen-push codegen)
(ensure-ilayout-var codegen super)
+ (when (and (keyword-message-p message)
+ (not (eq *keyword-struct-disposition* :null)))
+ (let ((tag (effective-method-keyword-struct-tag method)))
+ (ensure-var codegen *sod-keywords* (c-type (* (struct tag :const)))
+ *sod-key-pointer*)))
(funcall body (codegen-target codegen))
(codegen-pop-function codegen (temporary-function)
(c-type (fun (lisp return-type)
nil."
(let* ((message (codegen-message codegen))
- (argument-tail (if (varargs-message-p message)
- (cons *sod-tmp-ap* basic-tail)
- basic-tail)))
+ (argument-tail (cond ((varargs-message-p message)
+ (cons *sod-tmp-ap* basic-tail))
+ ((keyword-message-p message)
+ (cons (keyword-struct-pointer) basic-tail))
+ (t basic-tail))))
(labels ((next-trampoline (method chain)
(if (or kernel chain)
(make-trampoline codegen (sod-method-class method)
;; names.
(parse-declarator
scanner base-type
+ :keywordp t
:kernel (parser ()
(seq ((name-a :id)
(name-b (? (seq (#\. (id :id)) id))))
::=
.<
.IR declaration-specifier \*+
-.I simple-declarator
+.IR keyword-declarator [ identifier ]
+.<
.RI [ method-body ]
.br
.I method-item
::=
.<
.IR declaration-specifier \*+
-.IR declarator [ dotted-name ]
+.IR keyword-declarator [ dotted-name ]
+.<
.I method-body
.br
.I method-body
.BR "double complex" ,
.B "long double complex"
.PP
-.IR declarator [ k ]
+.IR declarator [ k ", " a ]
::=
.IR pointer \**
-.IR primary-declarator [ k ]
+.IR primary-declarator [ k ", " a ]
.br
-.IR primary-declarator [ k ]
+.IR primary-declarator [ k ", " a ]
::=
.I k
.|
.B (
-.IR primary-declarator [ k ]
+.IR primary-declarator [ k ", " a ]
.B )
.|
-.IR primary-declarator [ k ]
-.IR declarator-suffix
+.IR primary-declarator [ k ", " a ]
+.IR declarator-suffix [ a ]
.br
.I pointer
::=
.B *
.IR qualifier \**
.br
-.I declarator-suffix
+.IR declarator-suffix [ a ]
::=
.B [
.I c-fragment
.B ]
.|
.B (
-.I argument-list
+.I a
.B )
.br
.I argument-list
.br
.I argument-declarator
::=
-.IR declarator [ identifier " | \*e]"
+.IR declarator [ identifier " | \*e, " argument-list ]
.br
.I simple-declarator
::=
-.IR declarator [ identifier ]
+.IR declarator [ identifier ", " argument-list ]
+.br
+.I keyword-argument
+::=
+.I argument
+.RB [ =
+.IR c-fragment ]
+.br
+.I keyword-argument-list
+::=
+.I argument-list
+.B ?\&
+.I keyword-argument-list
+.br
+.I method-argument-list
+::=
+.I argument-list
+|
+.I keyword-argument-list
.br
.I dotted-name
::=
.I identifier
.B .\&
.I identifier
+.br
+.IR keyword-declarator [ k ]
+::=
+.IR declarator [ k ", " method-argument-list ]
.
.\"--------------------------------------------------------------------------
.SH SEE ALSO
~mdw / sod / commitdiff