src/c-types-*.lisp: New type for functions which take keyword arguments.

[sod] / src / c-types-parse.lisp

diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp
index e1a7dcd..6a622b7 100644 (file)
--- a/src/c-types-parse.lisp
+++ b/src/c-types-parse.lisp
@@ -302,7 +302,7 @@
 ;;; `parse-declarator' will be of this form.
 
 (export 'parse-declarator)
-(defun parse-declarator (scanner base-type &key kernel abstractp)
+(defun parse-declarator (scanner base-type &key kernel abstractp keywordp)
   "Parse a C declarator, returning a pair (C-TYPE . NAME).
 
    The SCANNER is a token scanner to read from.  The BASE-TYPE is the type
@@ -315,6 +315,9 @@
    defaults to matching a simple identifier `:id'.  This might, e.g., be
    (? :id) to parse an `abstract declarator' which has optional names.
 
+   If KEYWORDP is true, then a keyword argument list is permitted in
+   function declarations.
+
    There's an annoying ambiguity in the syntax, if an empty KERNEL is
    permitted.  In this case, you must ensure that ABSTRACTP is true so that
    the appropriate heuristic can be applied.  As a convenience, if ABSTRACTP
@@ -348,12 +351,18 @@
                                                         'qualifier)))))))
                     (mapcar #'ds-label quals))))
 
+              (disallow-keyword-functions (type)
+                (when (typep type 'c-keyword-function-type)
+                  (error "Functions with keyword arguments are only ~
+                          allowed at top-level.")))
+
               (star ()
                 ;; Prefix: `*' qualifiers
 
                 (parse (seq (#\* (quals (qualifiers)))
                          (preop "*" (state 9)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                             (make-pointer-type type quals)))
                                  (cdr state))))))
@@ -405,24 +414,50 @@
                 (parse (seq ((dtor (arg-decl t)))
                          (make-argument (cdr dtor) (car dtor)))))
 
+              (kw-argument ()
+                ;; kw-argument ::= type declspec [= c-fragment]
+
+                (parse (seq ((dtor (arg-decl nil))
+                             (dflt (? (when (eq (token-type scanner) #\=)
+                                        (parse-delimited-fragment
+                                         scanner #\= '(#\, #\))
+                                         :keep-end t)))))
+                         (make-argument (cdr dtor) (car dtor) dflt))))
+
               (argument-list ()
                 ;; argument-list ::=
                 ;;     [argument [`,' argument]* [`,' argument-tail]]
                 ;;   | argument-tail
                 ;;
-                ;; argument-tail ::= `...'
+                ;; argument-tail ::= `...' | keyword-tail
+                ;;
+                ;; keyword-tail ::= `?' [kw-argument [`,' kw-argument]*]
+                ;;
+                ;; kw-argument ::= argument [= c-fragment]
                 ;;
                 ;; The possibility of a trailing `,' `...' means that we
                 ;; can't use the standard `list' parser.  Note that, unlike
                 ;; `real' C, we allow an ellipsis even if there are no
                 ;; explicit arguments.
 
-                (let ((args nil))
+                (let ((args nil)
+                      (keys nil)
+                      (keysp nil))
                   (loop
                     (when (eq (token-type scanner) :ellipsis)
                       (push :ellipsis args)
                       (scanner-step scanner)
                       (return))
+                    (when (and keywordp (eq (token-type scanner) #\?))
+                      (setf keysp t)
+                      (scanner-step scanner)
+                      (multiple-value-bind (arg winp consumedp)
+                          (parse (list (:min 0) (kw-argument) #\,))
+                        (declare (ignore consumedp))
+                        (unless winp
+                          (return-from argument-list (values arg nil t)))
+                        (setf keys arg)
+                        (return)))
                     (multiple-value-bind (arg winp consumedp)
                         (argument)
                       (unless winp
@@ -433,11 +468,16 @@
                     (unless (eq (token-type scanner) #\,)
                       (return))
                     (scanner-step scanner))
-                  (values (let ((rargs (nreverse args)))
-                            (lambda (ret)
-                              (make-function-type ret rargs)))
+                  (values (let ((rargs (nreverse args))
+                                (rkeys (nreverse keys)))
+                            (if keysp
+                                (lambda (ret)
+                                  (make-keyword-function-type
+                                   ret rargs rkeys))
+                                (lambda (ret)
+                                  (make-function-type ret rargs))))
                           t
-                          args)))
+                          (or args keysp))))
 
               (postfix-lparen ()
                 ;; Postfix: `(' argument-list `)'
@@ -445,6 +485,7 @@
                 (parse (seq (#\( (make (argument-list)) #\))
                          (postop "()" (state 10)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                             (funcall make type)))
                                  (cdr state))))))
@@ -462,6 +503,7 @@
                 (parse (seq ((dims (list (:min 1) (dimension))))
                          (postop "[]" (state 10)
                            (cons (lambda (type)
+                                   (disallow-keyword-functions type)
                                    (funcall (car state)
                                             (make-array-type type dims)))
                                  (cdr state)))))))