c-types-proto.lisp (canonify-qualifiers): Delete `nil' entries.

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

diff --git a/src/c-types-parse.lisp b/src/c-types-parse.lisp
index 2c0e725..d0b3d41 100644 (file)
--- a/src/c-types-parse.lisp
+++ b/src/c-types-parse.lisp
@@ -68,9 +68,9 @@
   ;; Despite the fact that it looks pretty trivial, this can't be done with
   ;; `defstruct' for the simple reason that we add more methods to the
   ;; accessor functions later.
   ;; Despite the fact that it looks pretty trivial, this can't be done with
   ;; `defstruct' for the simple reason that we add more methods to the
   ;; accessor functions later.

-  ((label :type keyword :initarg :label :reader ds-label)
+  ((%label :type keyword :initarg :label :reader ds-label)

    (name :type string :initarg :name :reader ds-name)
    (name :type string :initarg :name :reader ds-name)

-   (kind :type (member type complexity sign size qualifier)
+   (kind :type (member %type complexity sign size qualifier %specs)

         :initarg :kind :reader ds-kind)
    (taggedp :type boolean :initarg :taggedp
            :initform nil :reader ds-taggedp))
         :initarg :kind :reader ds-kind)
    (taggedp :type boolean :initarg :taggedp
            :initform nil :reader ds-taggedp))


@@ -89,23 +89,21 @@
 
 (defparameter *declspec-map*
   (let ((map (make-hash-table :test #'equal)))
 
 (defparameter *declspec-map*
   (let ((map (make-hash-table :test #'equal)))

-    (dolist (item '((type :void :char :int :float :double
-                         (:bool :compat "_Bool"))
+    (dolist (item '((%type :char :int :float :double)

                    (complexity (:complex :compat "_Complex")
                                (:imaginary :compat "_Imaginary"))
                    ((type :taggedp t) :enum :struct :union)
                    (size :short :long (:long-long :name "long long"))
                    (sign :signed :unsigned)
                    (complexity (:complex :compat "_Complex")
                                (:imaginary :compat "_Imaginary"))
                    ((type :taggedp t) :enum :struct :union)
                    (size :short :long (:long-long :name "long long"))
                    (sign :signed :unsigned)

-                   (qualifier :const :restrict :volatile)))
+                   (qualifier :const :restrict :volatile
+                              (:atomic :compat "_Atomic"))))

       (destructuring-bind (kind &key (taggedp nil))
          (let ((spec (car item)))
            (if (consp spec) spec (list spec)))
        (dolist (spec (cdr item))
          (destructuring-bind (label
       (destructuring-bind (kind &key (taggedp nil))
          (let ((spec (car item)))
            (if (consp spec) spec (list spec)))
        (dolist (spec (cdr item))
          (destructuring-bind (label

-                              &key
-                              (name (string-downcase label))
-                              compat
-                              (taggedp taggedp))
+                              &key (name (string-downcase label))
+                                   compat (taggedp taggedp))

              (if (consp spec) spec (list spec))
            (let ((ds (make-instance 'declspec
                                     :label label
              (if (consp spec) spec (list spec))
            (let ((ds (make-instance 'declspec
                                     :label label


@@ -119,19 +117,27 @@
     map)
   "Maps symbolic labels and textual names to `declspec' instances.")
 
     map)
   "Maps symbolic labels and textual names to `declspec' instances.")
 

+(defclass storespec ()
+  ((spec :initarg :spec :reader ds-spec))
+  (:documentation "Carrier for a storage specifier."))
+
+(defmethod ds-label ((spec storespec)) spec)
+(defmethod ds-kind ((spec storespec)) '%specs)
+

 (defmethod ds-label ((ty c-type)) :c-type)
 (defmethod ds-name ((ty c-type)) (princ-to-string ty))
 (defmethod ds-label ((ty c-type)) :c-type)
 (defmethod ds-name ((ty c-type)) (princ-to-string ty))

-(defmethod ds-kind ((ty c-type)) 'type)
+(defmethod ds-kind ((ty c-type)) '%type)

 
 ;; A collection of declaration specifiers, and how to merge them together.
 
 (defclass declspecs ()
   ;; This could have been done with `defstruct' just as well, but a
   ;; `defclass' can be tweaked interactively, which is a win at the moment.
 
 ;; A collection of declaration specifiers, and how to merge them together.
 
 (defclass declspecs ()
   ;; This could have been done with `defstruct' just as well, but a
   ;; `defclass' can be tweaked interactively, which is a win at the moment.

-  ((type :initform nil :initarg :type :reader ds-type)
+  ((%type :initform nil :initarg :type :reader ds-type)

    (complexity :initform nil :initarg :complexity :reader ds-complexity)
    (sign :initform nil :initarg :sign :reader ds-sign)
    (size :initform nil :initarg :size :reader ds-size)
    (complexity :initform nil :initarg :complexity :reader ds-complexity)
    (sign :initform nil :initarg :sign :reader ds-sign)
    (size :initform nil :initarg :size :reader ds-size)

+   (%specs :initform nil :initarg :specs :reader ds-specs)

    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
   (:documentation "Represents a collection of declaration specifiers.
 
    (qualifier :initform nil :initarg :qualifiers :reader ds-qualifiers))
   (:documentation "Represents a collection of declaration specifiers.
 


@@ -186,6 +192,7 @@
                      ((and (eq (ds-label old) :long) (eq ds old))
                       (values t (gethash :long-long *declspec-map*)))
                      (t (values nil nil))))
                      ((and (eq (ds-label old) :long) (eq ds old))
                       (values t (gethash :long-long *declspec-map*)))
                      (t (values nil nil))))

+         (specs (values t (adjoin (ds-spec ds) old)))

          (t (values (not old) ds)))
       (if ok
          (let ((copy (copy-instance specs)))
          (t (values (not old) ds)))
       (if ok
          (let ((copy (copy-instance specs)))


@@ -195,30 +202,34 @@
 
 (defun declspecs-type (specs)
   "Convert `declspecs' SPECS into a standalone C type object."
 
 (defun declspecs-type (specs)
   "Convert `declspecs' SPECS into a standalone C type object."

-  (let ((type (ds-type specs))
-       (size (ds-size specs))
-       (sign (ds-sign specs))
-       (cplx (ds-complexity specs))
-       (quals (mapcar #'ds-label (ds-qualifiers specs))))
-    (cond ((typep type 'c-type)
-          (qualify-c-type type quals))
-         ((or type size sign cplx)
-          (when (and sign (eq (ds-label sign) :signed)
-                     (eq (ds-label type) :int))
-            (setf sign nil))
-          (cond ((and (or (null type) (eq (ds-label type) :int))
-                      (or size sign))
-                 (setf type nil))
-                ((null type)
-                 (setf type (gethash :int *declspec-map*))))
-          (make-simple-type (format nil "~{~@[~A~^ ~]~}"
-                                    (mapcar #'ds-name
-                                            (remove nil
-                                                    (list sign cplx
-                                                          size type))))
-                            quals))
-         (t
-          nil))))
+  (let* ((base-type (ds-type specs))
+        (size (ds-size specs))
+        (sign (ds-sign specs))
+        (cplx (ds-complexity specs))
+        (quals (mapcar #'ds-label (ds-qualifiers specs)))
+        (specs (ds-specs specs))
+        (type (cond ((typep base-type 'c-type)
+                     (qualify-c-type base-type quals))
+                    ((or base-type size sign cplx)
+                     (when (and sign (eq (ds-label sign) :signed)
+                                (eq (ds-label base-type) :int))
+                       (setf sign nil))
+                     (cond ((and (or (null base-type)
+                                     (eq (ds-label base-type) :int))
+                                 (or size sign))
+                            (setf base-type nil))
+                           ((null base-type)
+                            (setf base-type (gethash :int *declspec-map*))))
+                     (let* ((things (list sign cplx size base-type))
+                            (stripped (remove nil things))
+                            (names (mapcar #'ds-name stripped)))
+                       (make-simple-type (format nil "~{~A~^ ~}" names)
+                                         quals)))
+                    (t
+                     nil))))
+    (cond ((null type) nil)
+         ((null specs) type)
+         (t (make-storage-specifiers-type type specs)))))

 
 ;; Parsing declaration specifiers.
 
 
 ;; Parsing declaration specifiers.
 


@@ -244,9 +255,10 @@
   ;; Turns out to be easier to do this by hand.
   (let ((ds (and (eq (token-type scanner) :id)
                 (let ((kw (token-value scanner)))
   ;; Turns out to be easier to do this by hand.
   (let ((ds (and (eq (token-type scanner) :id)
                 (let ((kw (token-value scanner)))

-                  (or (and (boundp '*module-type-map*)
+                  (or (gethash kw *declspec-map*)
+                      (and (boundp '*module-type-map*)

                            (gethash kw *module-type-map*))
                            (gethash kw *module-type-map*))

-                      (gethash kw *declspec-map*))))))
+                      (find-simple-c-type kw))))))

     (cond ((or (not ds) (and predicate (not (funcall predicate ds))))
           (values (list indicator) nil nil))
          ((and (typep ds 'declspec) (ds-taggedp ds))
     (cond ((or (not ds) (and predicate (not (funcall predicate ds))))
           (values (list indicator) nil nil))
          ((and (typep ds 'declspec) (ds-taggedp ds))


@@ -261,6 +273,34 @@
           (scanner-step scanner)
           (values ds t t)))))
 
           (scanner-step scanner)
           (values ds t t)))))
 

+(define-pluggable-parser complex-declspec atomic-typepsec (scanner)
+  ;; `atomic' `(' type-name `)'
+  ;; `_Atomic' `(' type-name `)'
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (peek (seq ((nil (or "atomic" "_Atomic"))
+                      #\(
+                      (decls (parse-c-type scanner))
+                      (subtype (parse-declarator scanner decls
+                                                 :kernel (parse-empty)
+                                                 :abstractp t))
+                      #\))
+                  (make-atomic-type (car subtype)))))))
+
+(define-pluggable-parser complex-declspec alignas (scanner)
+  ;; `alignas' `(' fragment `)'
+  ;; `_Alignas' `(' fragment `)'
+  (with-parser-context (token-scanner-context :scanner scanner)
+    (parse (peek (seq ((nil (or "alignas" "_Alignas"))
+                      (nil (lisp (values #\(
+                                         (eq (token-type scanner) #\()
+                                         nil)))
+                      (nil (commit))
+                      (frag (parse-delimited-fragment scanner #\( #\))))
+                  (make-instance 'storespec
+                                 :spec (make-instance
+                                        'alignas-storage-specifier
+                                        :alignment frag)))))))
+

 (defun scan-and-merge-declspec (scanner specs)
   "Scan a declaration specifier and merge it with SPECS.
 
 (defun scan-and-merge-declspec (scanner specs)
   "Scan a declaration specifier and merge it with SPECS.
 


@@ -308,7 +348,7 @@
 ;;; `parse-declarator' will be of this form.
 
 (export 'parse-declarator)
 ;;; `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
   "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


@@ -321,10 +361,23 @@
    defaults to matching a simple identifier `:id'.  This might, e.g., be
    (? :id) to parse an `abstract declarator' which has optional names.
 
    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
    is true then `(? :id)' is used as the default KERNEL."
    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
    is true then `(? :id)' is used as the default KERNEL."

+
+  ;; This is a bit confusing.  This is a strangely-shaped operator grammer,
+  ;; which wouldn't be so bad, but the `values' being operated on are pairs
+  ;; of the form (FUNC . NAME).  The NAME is whatever the KERNEL parser
+  ;; produces as its result, and will be passed out unchanged.  The FUNC is a
+  ;; type-constructor function which will be eventually be applied to the
+  ;; input BASE-TYPE, but we can't calculate the actual result as we go along
+  ;; because of the rather annoying inside-out nature of the declarator
+  ;; syntax.
+

   (with-parser-context (token-scanner-context :scanner scanner)
     (let ((kernel-parser (cond (kernel kernel)
                               (abstractp (parser () (? :id)))
   (with-parser-context (token-scanner-context :scanner scanner)
     (let ((kernel-parser (cond (kernel kernel)
                               (abstractp (parser () (? :id)))


@@ -344,12 +397,18 @@
                                                         'qualifier)))))))
                     (mapcar #'ds-label quals))))
 
                                                         '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)
               (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))))))
                                    (funcall (car state)
                                             (make-pointer-type type quals)))
                                  (cdr state))))))


@@ -389,26 +448,64 @@
                 (parse (seq ((name (funcall kernel-parser)))
                          (cons #'identity name))))
 
                 (parse (seq ((name (funcall kernel-parser)))
                          (cons #'identity name))))
 

+              (arg-decl (abstractp)
+                (parse (seq ((base-type (parse-c-type scanner))
+                             (dtor (parse-declarator scanner base-type
+                                                     :abstractp abstractp)))
+                         dtor)))
+
+              (argument ()
+                ;; argument ::= type abstract-declspec
+
+                (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-list ::=
+                ;;     [argument [`,' argument]* [`,' 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.
 
                 ;;
                 ;; 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))
                   (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)
                     (multiple-value-bind (arg winp consumedp)

-                        (parse (seq ((base-type (parse-c-type scanner))
-                                     (dtor (parse-declarator scanner
-                                                             base-type
-                                                             :abstractp t)))
-                                 (make-argument (cdr dtor) (car dtor))))
+                        (argument)

                       (unless winp
                         (if (or consumedp args)
                             (return-from argument-list (values arg nil t))
                       (unless winp
                         (if (or consumedp args)
                             (return-from argument-list (values arg nil t))


@@ -417,16 +514,26 @@
                     (unless (eq (token-type scanner) #\,)
                       (return))
                     (scanner-step scanner))
                     (unless (eq (token-type scanner) #\,)
                       (return))
                     (scanner-step scanner))

-                  (values (nreverse args) t args)))
+                  (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
+                          (or args keysp))))

 
               (postfix-lparen ()
                 ;; Postfix: `(' argument-list `)'
 
 
               (postfix-lparen ()
                 ;; Postfix: `(' argument-list `)'
 

-                (parse (seq (#\( (args (argument-list)) #\))
+                (parse (seq (#\( (make (argument-list)) #\))

                          (postop "()" (state 10)
                            (cons (lambda (type)
                          (postop "()" (state 10)
                            (cons (lambda (type)

+                                   (disallow-keyword-functions type)

                                    (funcall (car state)
                                    (funcall (car state)

-                                            (make-function-type type args)))
+                                            (funcall make type)))

                                  (cdr state))))))
 
               (dimension ()
                                  (cdr state))))))
 
               (dimension ()


@@ -442,6 +549,7 @@
                 (parse (seq ((dims (list (:min 1) (dimension))))
                          (postop "[]" (state 10)
                            (cons (lambda (type)
                 (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)))))))
                                    (funcall (car state)
                                             (make-array-type type dims)))
                                  (cdr state)))))))


@@ -463,6 +571,9 @@
                              (or (postfix-lparen)
                                  (lbracket)
                                  (when nestedp (seq (#\)) (rparen #\))))))))
                              (or (postfix-lparen)
                                  (lbracket)
                                  (when nestedp (seq (#\)) (rparen #\))))))))

-                (cons (funcall (car value) base-type) (cdr value))))))))
+                (cons (wrap-c-type (lambda (type)
+                                     (funcall (car value) type))
+                                   base-type)
+                      (cdr value))))))))

 
 ;;;----- That's all, folks --------------------------------------------------
 
 ;;;----- That's all, folks --------------------------------------------------