X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/b4aab8d4d82563222e22d59e7ba46e3dd5d82332..b7fcf94152e4c1938fbca55d13b1e6a64b694bd6:/src/c-types-impl.lisp

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index cea3057..719e610 100644
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -66,17 +66,76 @@
 		 (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)))
 
 ;;;--------------------------------------------------------------------------
+;;; Storage specifiers.
+
+(defmethod c-type-equal-p :around
+    ((type-a c-storage-specifiers-type) (type-b c-type))
+  "Ignore storage specifiers when comparing C types."
+  (c-type-equal-p (c-type-subtype type-a) type-b))
+
+(defmethod c-type-equal-p :around
+    ((type-a c-type) (type-b c-storage-specifiers-type))
+  "Ignore storage specifiers when comparing C types."
+  (c-type-equal-p type-a (c-type-subtype type-b)))
+
+(defun make-storage-specifiers-type (subtype specifiers)
+  "Construct a type based on SUBTYPE, carrying the storage SPECIFIERS."
+  (if (null specifiers) subtype
+      (make-or-intern-c-type 'c-storage-specifiers-type subtype
+			     :specifiers specifiers
+			     :subtype subtype)))
+
+(defmethod pprint-c-type ((type c-storage-specifiers-type) stream kernel)
+  (dolist (spec (c-type-specifiers type))
+    (pprint-c-storage-specifier spec stream)
+    (write-char #\space stream)
+    (pprint-newline :miser stream))
+  (pprint-c-type (c-type-subtype type) stream kernel))
+
+(defmethod print-c-type
+    (stream (type c-storage-specifiers-type) &optional colon atsign)
+  (declare (ignore colon atsign))
+  (format stream "~:@<SPECS ~@_~:I~/sod:print-c-type/~
+			    ~{ ~_~/sod:print-c-storage-specifier/~}~:>"
+	  (c-type-subtype type) (c-type-specifiers type)))
+
+(export 'specs)
+(define-c-type-syntax specs (subtype &rest specifiers)
+  `(make-storage-specifiers-type
+    ,(expand-c-type-spec subtype)
+    (list ,@(mapcar #'expand-c-storage-specifier specifiers))))
+
+;;;--------------------------------------------------------------------------
 ;;; Simple C types.
 
 ;; Class definition.
@@ -106,8 +165,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)))
 
@@ -130,74 +189,61 @@
     `(make-simple-type ,head (list ,@tail))))
 
 (export 'define-simple-c-type)
-(defmacro define-simple-c-type (names type)
+(defmacro define-simple-c-type (names type &key export)
   "Define each of NAMES to be a simple type called TYPE."
   (let ((names (if (listp names) names (list names))))
     `(progn
        (setf (gethash ,type *simple-type-map*) ',(car names))
-       (defctype ,names ,type)
+       (defctype ,names ,type :export ,export)
        (define-c-type-syntax ,(car names) (&rest quals)
 	 `(make-simple-type ,',type (list ,@quals))))))
 
 ;; Built-in C types.
 
-(export '(void
-	  float double long-double
-	  float-complex double-complex long-double-complex
-	  float-imaginary double-imaginary long-double-imaginary
-	  va-list size-t ptrdiff-t wchar-t
-	  char unsigned-char uchar signed-char schar
-	  int signed signed-int sint unsigned unsigned-int uint
-	  short signed-short short-int signed-short-int sshort
-	  unsigned-short unsigned-short-int ushort
-	  long signed-long long-int signed-long-int slong
-	  unsigned-long unsigned-long-int ulong
-	  long-long signed-long-long long-long-int signed-long-long-int
-	  unsigned-long-long unsigned-long-long-int llong sllong ullong))
-
-(define-simple-c-type void "void")
-
-(define-simple-c-type char "char")
-(define-simple-c-type (unsigned-char uchar) "unsigned char")
-(define-simple-c-type (signed-char schar) "signed char")
-(define-simple-c-type wchar-t "wchar-t")
-
-(define-simple-c-type (int signed signed-int sint) "int")
-(define-simple-c-type (unsigned unsigned-int uint) "unsigned")
+(define-simple-c-type void "void" :export t)
+
+(define-simple-c-type char "char" :export t)
+(define-simple-c-type (unsigned-char uchar) "unsigned char" :export t)
+(define-simple-c-type (signed-char schar) "signed char" :export t)
+(define-simple-c-type wchar-t "wchar-t" :export t)
+
+(define-simple-c-type (int signed signed-int sint) "int" :export t)
+(define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
 
 (define-simple-c-type (short signed-short short-int signed-short-int sshort)
-  "short")
+  "short" :export t)
 (define-simple-c-type (unsigned-short unsigned-short-int ushort)
-  "unsigned short")
+  "unsigned short" :export t)
 
 (define-simple-c-type (long signed-long long-int signed-long-int slong)
-  "long")
+  "long" :export t)
 (define-simple-c-type (unsigned-long unsigned-long-int ulong)
-  "unsigned long")
+  "unsigned long" :export t)
 
 (define-simple-c-type (long-long signed-long-long long-long-int
 		       signed-long-long-int llong sllong)
-  "long long")
+  "long long" :export t)
 (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
-  "unsigned long long")
+  "unsigned long long" :export t)
 
-(define-simple-c-type float "float")
-(define-simple-c-type double "double")
-(define-simple-c-type long-double "long double")
+(define-simple-c-type float "float" :export t)
+(define-simple-c-type double "double" :export t)
+(define-simple-c-type long-double "long double" :export t)
 
-(define-simple-c-type bool "_Bool")
+(define-simple-c-type bool "_Bool" :export t)
 
-(define-simple-c-type float-complex "float _Complex")
-(define-simple-c-type double-complex "double _Complex")
-(define-simple-c-type long-double-complex "long double _Complex")
+(define-simple-c-type float-complex "float _Complex" :export t)
+(define-simple-c-type double-complex "double _Complex" :export t)
+(define-simple-c-type long-double-complex "long double _Complex" :export t)
 
-(define-simple-c-type float-imaginary "float _Imaginary")
-(define-simple-c-type double-imaginary "double _Imaginary")
-(define-simple-c-type long-double-imaginary "long double _Imaginary")
+(define-simple-c-type float-imaginary "float _Imaginary" :export t)
+(define-simple-c-type double-imaginary "double _Imaginary" :export t)
+(define-simple-c-type long-double-imaginary
+    "long double _Imaginary" :export t)
 
-(define-simple-c-type va-list "va_list")
-(define-simple-c-type size-t "size_t")
-(define-simple-c-type ptrdiff-t "ptrdiff_t")
+(define-simple-c-type va-list "va_list" :export t)
+(define-simple-c-type size-t "size_t" :export t)
+(define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 
 ;;;--------------------------------------------------------------------------
 ;;; Tagged types (enums, structs and unions).
@@ -261,8 +307,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)))
@@ -277,6 +323,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.
@@ -291,12 +386,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.
 
@@ -311,8 +403,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.