src/c-types-{impl,parse}.lisp: Support C11 `_Atomic'.

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

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 9257bf2..d0d4a74 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -66,12 +66,31 @@
                 (assert (gethash k map))))
             *c-type-intern-map*)))
 
+(defun make-or-intern-c-type (new-type-class base-types &rest initargs)
+  "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS.
+
+   If all of the BASE-TYPES are interned, then use `intern-c-type' to
+   construct the new type; otherwise just make a new one with
+   `make-instance'.  BASE-TYPES may be a singleton type, or a sequence of
+   types."
+  (apply (if (if (typep base-types 'sequence)
+                (every (lambda (type)
+                         (gethash type *c-type-intern-map*))
+                       base-types)
+                (gethash base-types *c-type-intern-map*))
+            #'intern-c-type #'make-instance)
+        new-type-class
+        initargs))
+
+;;;--------------------------------------------------------------------------
+;;; Qualifiers.
+
+(defmethod c-qualifier-keyword ((qualifier (eql :atomic))) "_Atomic")
+
 (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers)
   (let ((initargs (instance-initargs type)))
     (remf initargs :qualifiers)
-    (apply (if (gethash type *c-type-intern-map*)
-              #'intern-c-type #'make-instance)
-          (class-of type)
+    (apply #'make-or-intern-c-type (class-of type) type
           :qualifiers (canonify-qualifiers
                        (append qualifiers (c-type-qualifiers type)))
           initargs)))
@@ -106,8 +125,8 @@
 
 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
   (pprint-logical-block (stream nil)
-    (format stream "~{~(~A~) ~@_~}~A"
-           (c-type-qualifiers type)
+    (format stream "~{~A ~@_~}~A"
+           (c-type-qualifier-keywords type)
            (c-type-name type))
     (funcall kernel stream 0 t)))
 
@@ -248,8 +267,8 @@
 
 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
   (pprint-logical-block (stream nil)
-    (format stream "~{~(~A~) ~@_~}~(~A~) ~A"
-           (c-type-qualifiers type)
+    (format stream "~{~A ~@_~}~(~A~) ~A"
+           (c-type-qualifier-keywords type)
            (c-tagged-type-kind type)
            (c-type-tag type))
     (funcall kernel stream 0 t)))
@@ -264,6 +283,55 @@
          (c-type-qualifiers type)))
 
 ;;;--------------------------------------------------------------------------
+;;; Atomic types.
+
+;; Class definition.
+
+(export 'c-atomic-type)
+(defclass c-atomic-type (qualifiable-c-type)
+  ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
+  (:documentation "C atomic types."))
+
+;; Constructor function.
+
+(export 'make-atomic-type)
+(defun make-atomic-type (subtype &optional qualifiers)
+  "Return a (maybe distinguished) atomic type."
+  (make-or-intern-c-type 'c-atomic-type subtype
+                        :subtype subtype
+                        :qualifiers (canonify-qualifiers qualifiers)))
+
+;; Comparison protocol.
+
+(defmethod c-type-equal-p and ((type-a c-atomic-type) (type-b c-atomic-type))
+  (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)))
+
+;; C-syntax output protocol.
+
+(defmethod pprint-c-type ((type c-atomic-type) stream kernel)
+  (pprint-logical-block (stream nil)
+    (format stream "~{~A ~@_~}" (c-type-qualifier-keywords type))
+    (write-string "_Atomic(" stream)
+    (pprint-indent :current 0 stream)
+    (pprint-c-type (c-type-subtype type) stream
+                  (lambda (stream prio spacep)
+                    (declare (ignore stream prio spacep))))
+    (write-char #\) stream)))
+
+;; S-expression notation protocol.
+
+(defmethod print-c-type (stream (type c-atomic-type) &optional colon atsign)
+  (declare (ignore colon atsign))
+  (format stream "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
+         (c-type-subtype type)
+         (c-type-qualifiers type)))
+
+(export 'atomic)
+(define-c-type-syntax atomic (sub &rest quals)
+  "Return the type of atomic SUB."
+  `(make-atomic-type ,(expand-c-type-spec sub) (list ,@quals)))
+
+;;;--------------------------------------------------------------------------
 ;;; Pointer types.
 
 ;; Class definition.
@@ -278,12 +346,9 @@
 (export 'make-pointer-type)
 (defun make-pointer-type (subtype &optional qualifiers)
   "Return a (maybe distinguished) pointer type."
-  (let ((canonical (canonify-qualifiers qualifiers)))
-    (funcall (if (gethash subtype *c-type-intern-map*)
-                #'intern-c-type #'make-instance)
-            'c-pointer-type
-            :subtype subtype
-            :qualifiers canonical)))
+  (make-or-intern-c-type 'c-pointer-type subtype
+                        :subtype subtype
+                        :qualifiers (canonify-qualifiers qualifiers)))
 
 ;; Comparison protocol.
 
@@ -298,8 +363,8 @@
                 (lambda (stream prio spacep)
                   (when spacep (c-type-space stream))
                   (maybe-in-parens (stream (> prio 1))
-                    (format stream "*~{~(~A~)~^ ~@_~}"
-                            (c-type-qualifiers type))
+                    (format stream "*~{~A~^ ~@_~}"
+                            (c-type-qualifier-keywords type))
                     (funcall kernel stream 1 (c-type-qualifiers type))))))
 
 ;; S-expression notation protocol.