From 4307347660f48628e307f299eb4fac58ba35fd1a Mon Sep 17 00:00:00 2001 Message-Id: <4307347660f48628e307f299eb4fac58ba35fd1a.1715954571.git.mdw@distorted.org.uk> From: Mark Wooding Date: Tue, 15 Dec 2015 19:15:23 +0000 Subject: [PATCH] New feature: messages with keyword arguments! Organization: Straylight/Edgeware From: Mark Wooding 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. --- doc/SYMBOLS | 6 + doc/concepts.tex | 45 +++++- doc/layout.tex | 8 +- doc/structures.tex | 20 ++- doc/syntax.tex | 38 +++-- lib/sod-structs.3 | 25 ++- src/class-make-impl.lisp | 11 +- src/class-output.lisp | 38 ++++- src/codegen-proto.lisp | 4 + src/method-impl.lisp | 324 ++++++++++++++++++++++++++++++++++++--- src/method-proto.lisp | 155 ++++++++++++++----- src/module-parse.lisp | 1 + src/sod-module.5 | 48 ++++-- 13 files changed, 623 insertions(+), 100 deletions(-) diff --git a/doc/SYMBOLS b/doc/SYMBOLS index 0833022..1dc1b28 100644 --- a/doc/SYMBOLS +++ b/doc/SYMBOLS @@ -479,6 +479,7 @@ method-proto.lisp 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 @@ -486,6 +487,7 @@ method-proto.lisp 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 @@ -827,6 +829,7 @@ compute-chains compute-cpl sod-class compute-effective-method-body + basic-effective-method t t simple-effective-method t t compute-effective-methods sod-class @@ -873,6 +876,8 @@ effective-method-class effective-method effective-method-function-name effective-method +effective-method-keywords + effective-method effective-method-message effective-method effective-slot-class @@ -1289,6 +1294,7 @@ cl:shared-initialize basic-direct-method t c-function-type t c-keyword-function-type t + effective-method t method-codegen t module t sequencer t diff --git a/doc/concepts.tex b/doc/concepts.tex index 8a8eb02..89dcd8f 100644 --- a/doc/concepts.tex +++ b/doc/concepts.tex @@ -469,6 +469,8 @@ Keyword arguments can be provided in three ways. \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} @@ -535,9 +537,7 @@ another, $N$, with respect to a receiving class~$C$, if the class defining $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, @@ -634,9 +634,7 @@ arguments. If the method body has overwritten its formal arguments, then @|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 @@ -679,6 +677,41 @@ The aggregating method combinations provided are as follows. 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} diff --git a/doc/layout.tex b/doc/layout.tex index a807edf..e4ffe10 100644 --- a/doc/layout.tex +++ b/doc/layout.tex @@ -213,12 +213,13 @@ %%%-------------------------------------------------------------------------- \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 @ @> @} - \dhead{gf}{effective-method-class @ @> @}} + \dhead{gf}{effective-method-class @ @> @} + \dhead{gf}{effective-method-keywords @ @> @}} \end{describe*} \begin{describe}{gf} @@ -273,6 +274,9 @@ \begin{describe}{fun}{varargs-message-p @ @> @} \end{describe} +\begin{describe}{fun}{keyword-message-p @ @> @} +\end{describe} + \begin{describe}{gf}{method-entry-function-type @ @> @} \end{describe} diff --git a/doc/structures.tex b/doc/structures.tex index 9c0451e..0b6be0a 100644 --- a/doc/structures.tex +++ b/doc/structures.tex @@ -32,8 +32,8 @@ works very differently from the standard @|SodObject| described here. The concrete types described in \xref{sec:structures.common} and \ref{sec:structures.root} are declared by the header file @||. -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} @@ -526,10 +526,16 @@ defined as \begin{prog} @_0 $m$(@_1 @_1, $\ldots$, @_n @_n, \dots); \end{prog} +or a standard message which takes keyword arguments, defined as +\begin{prog} + @_0 $m$(\=@_1 @_1, $\ldots$, @_n @_n? \+ \\ + @_{n+1} @_{n+1} @[= @_{n+1}@], $\ldots$, + @_m @_m @[= @_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} @_0 $m$($C$ *me, @_1 @_1, $\ldots$, @_n @_n, \dots); \\ @@ -550,10 +556,10 @@ For each message $m$ directly defined by $C$ there is a macro definition 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(@, $\ldots$, @) @@->_vt@->$c$.$m$__v(@, $\ldots$, @) diff --git a/doc/syntax.tex b/doc/syntax.tex index 5f8c89e..1090262 100644 --- a/doc/syntax.tex +++ b/doc/syntax.tex @@ -493,27 +493,27 @@ All of these have their usual C meanings. \subsubsection{Declarators} \begin{grammar} -$[k]$ ::= @^* $[k]$ +$[k, a]$ ::= @^* $[k, a]$ -$[k]$ ::= $k$ -\alt "(" $[k]$ ")" -\alt $[k]$ @ +$[k, a]$ ::= $k$ +\alt "(" $[k, a]$ ")" +\alt $[k, a]$ @$[a]$ ::= "*" @^* - ::= "[" "]" -\alt "(" ")" +$[a]$ ::= "[" "]" +\alt "(" $a$ ")" ::= $\epsilon$ | "..." \alt $[\mbox{@}]$ @["," "..."@] ::= @^+ - ::= $[\mbox{@ @! $\epsilon$}]$ + ::= + $[\mbox{@ @! $\epsilon$}, \mbox{@}]$ - ::= $[\mbox{@}]$ - - ::= "." + ::= + $[\mbox{@}, \mbox{@}]$ \end{grammar} The declarator syntax is taken from C, but with some differences. @@ -528,6 +528,24 @@ 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} + ::= @["=" @] + + ::= + @[$[\mbox{@}]$@] + "?" @[$[\mbox{@}]$@] + + ::= @! + + ::= "." + +$[k]$ ::= + $[k, \mbox{@}]$ +\end{grammar} + \subsection{Class definitions} \label{sec:syntax.module.class} diff --git a/lib/sod-structs.3 b/lib/sod-structs.3 index a6c9db2..0ef69ca 100644 --- a/lib/sod-structs.3 +++ b/lib/sod-structs.3 @@ -893,6 +893,27 @@ defined as .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 @@ -900,7 +921,8 @@ arguments, 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 @@ -950,6 +972,7 @@ somewhat less ugly. 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. diff --git a/src/class-make-impl.lisp b/src/class-make-impl.lisp index ed6189f..5b8baf0 100644 --- a/src/class-make-impl.lisp +++ b/src/class-make-impl.lisp @@ -243,7 +243,16 @@ (defun check-method-argument-lists (method-type message-type) "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" diff --git a/src/class-output.lisp b/src/class-output.lisp index 09f7e9f..abe5132 100644 --- a/src/class-output.lisp +++ b/src/class-output.lisp @@ -68,7 +68,8 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer) (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) @@ -139,7 +140,10 @@ (defmethod hook-output progn ((class sod-class) (reason (eql :h)) sequencer) ;; 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 @@ -288,7 +292,17 @@ (defmethod hook-output progn (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 @@ -486,6 +500,24 @@ (defmethod hook-output progn (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)))))) diff --git a/src/codegen-proto.lisp b/src/codegen-proto.lisp index 831b23c..856e44e 100644 --- a/src/codegen-proto.lisp +++ b/src/codegen-proto.lisp @@ -66,6 +66,10 @@ (defparameter *sod-tmp-ap* (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") diff --git a/src/method-impl.lisp b/src/method-impl.lisp index 0564d81..963f2fe 100644 --- a/src/method-impl.lisp +++ b/src/method-impl.lisp @@ -114,11 +114,47 @@ (defmethod shared-initialize :after (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 @@ -170,10 +206,16 @@ (define-on-demand-slot delegating-direct-method next-method-type (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)))) @@ -181,21 +223,47 @@ (define-on-demand-slot delegating-direct-method next-method-type (method) (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)) @@ -343,13 +411,175 @@ (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)) + (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)) @@ -361,7 +591,9 @@ (defmethod make-method-entries ((method basic-effective-method) :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))) @@ -404,10 +636,14 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) (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. @@ -440,7 +676,7 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) (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" @@ -516,6 +752,48 @@ (defmethod compute-method-entry-functions ((method basic-effective-method)) (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) diff --git a/src/method-proto.lisp b/src/method-proto.lisp index e0d8742..629e8a7 100644 --- a/src/method-proto.lisp +++ b/src/method-proto.lisp @@ -28,11 +28,14 @@ (cl:in-package #:sod) ;;;-------------------------------------------------------------------------- ;;; 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. @@ -42,10 +45,9 @@ (defclass effective-method () 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) @@ -174,6 +176,14 @@ (defgeneric sod-method-function-name (method) (: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. @@ -209,10 +219,11 @@ (defgeneric effective-method-basic-argument-names (method) "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. @@ -243,9 +254,11 @@ (defgeneric compute-effective-method-body (method codegen target) 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) @@ -267,6 +280,42 @@ (definst convert-to-ilayout (stream :export t) ;;; 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. @@ -283,22 +332,47 @@ (defun invoke-method (codegen target arguments-tail direct-method) (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) @@ -337,12 +411,21 @@ (defun make-trampoline (codegen super body) (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) @@ -406,9 +489,11 @@ (defun invoke-delegation-chain (codegen target basic-tail chain kernel) 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) diff --git a/src/module-parse.lisp b/src/module-parse.lisp index 9522085..a458922 100644 --- a/src/module-parse.lisp +++ b/src/module-parse.lisp @@ -220,6 +220,7 @@ (defun parse-class-body (scanner pset name supers) ;; names. (parse-declarator scanner base-type + :keywordp t :kernel (parser () (seq ((name-a :id) (name-b (? (seq (#\. (id :id)) id)))) diff --git a/src/sod-module.5 b/src/sod-module.5 index 21a9fee..2ffe671 100644 --- a/src/sod-module.5 +++ b/src/sod-module.5 @@ -583,14 +583,16 @@ class-definition ::= .< .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 @@ -809,35 +811,35 @@ and one of the following, up to reordering. .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 @@ -856,17 +858,39 @@ and one of the following, up to reordering. .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]