lib/sod-hosted.c (sod_makev): Use two statements rather than tricky expression.

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

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 16351a3..e5ead1b 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -35,7 +35,22 @@
 (defun intern-c-type (class &rest initargs)
   "If the CLASS and INITARGS have already been interned, then return the
    existing object; otherwise make a new one."
 (defun intern-c-type (class &rest initargs)
   "If the CLASS and INITARGS have already been interned, then return the
    existing object; otherwise make a new one."

-  (let ((list (cons class initargs)))
+  (let ((list (cons (typecase class
+                     ;; Canonify the class object; we'd prefer a name.
+                     (standard-class (class-name class))
+                     (t class))
+                   (let ((alist nil) (plist initargs))
+                     ;; Canonify the initargs.  Arrange for them to be in
+                     ;; ascending order by name.  This is annoying because
+                     ;; a plist isn't a readily sortable sequence.
+                     (loop
+                       (when (null plist) (return))
+                       (let ((name (pop plist)) (value (pop plist)))
+                         (push (cons name value) alist)))
+                     (dolist (assoc (sort alist #'string> :key #'car))
+                       (push (cdr assoc) plist)
+                       (push (car assoc) plist))
+                     plist))))

     (or (gethash list *c-type-intern-map*)
        (let ((new (apply #'make-instance class initargs)))
          (setf (gethash new *c-type-intern-map*) t
     (or (gethash list *c-type-intern-map*)
        (let ((new (apply #'make-instance class initargs)))
          (setf (gethash new *c-type-intern-map*) t


@@ -66,17 +81,96 @@
                 (assert (gethash k map))))
             *c-type-intern-map*)))
 
                 (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)
 (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)))
 
 ;;;--------------------------------------------------------------------------
           :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))))
+
+;;;--------------------------------------------------------------------------
+;;; Some storage specifiers.
+
+(export 'alignas-storage-specifier)
+(defclass alignas-storage-specifier ()
+  ((alignment :initarg :alignment :reader spec-alignment)))
+
+(export 'alignas)
+(define-c-storage-specifier-syntax alignas (alignment)
+  `(make-instance 'alignas-storage-specifier :alignment ,alignment))
+
+(defmethod print-c-storage-specifier
+    (stream (spec alignas-storage-specifier) &optional colon atsign)
+  (declare (ignore colon atsign))
+  (format stream "~:@<~S ~_~S~:>" 'alignas (spec-alignment spec)))
+
+(defmethod pprint-c-storage-specifier
+    ((spec alignas-storage-specifier) stream)
+  (format stream "_Alignas(~A)" (spec-alignment spec)))
+
+;;;--------------------------------------------------------------------------

 ;;; Simple C types.
 
 ;; Class definition.
 ;;; Simple C types.
 
 ;; Class definition.


@@ -106,14 +200,14 @@
 
 (defmethod pprint-c-type ((type simple-c-type) stream kernel)
   (pprint-logical-block (stream nil)
 
 (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)))
 
 ;; S-expression notation protocol.
 
            (c-type-name type))
     (funcall kernel stream 0 t)))
 
 ;; S-expression notation protocol.
 

-(defparameter *simple-type-map* (make-hash-table)
+(defparameter *simple-type-map* (make-hash-table :test #'equal)

   "Hash table mapping strings of C syntax to symbolic names.")
 
 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
   "Hash table mapping strings of C syntax to symbolic names.")
 
 (defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)


@@ -132,12 +226,23 @@
 (export 'define-simple-c-type)
 (defmacro define-simple-c-type (names type &key export)
   "Define each of NAMES to be a simple type called TYPE."
 (export 'define-simple-c-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 :export ,export)
-       (define-c-type-syntax ,(car names) (&rest quals)
-        `(make-simple-type ,',type (list ,@quals))))))
+  (let ((names (if (listp names) names (list names)))
+       (types (if (listp type) type (list type))))
+    (with-gensyms (type name)
+      `(progn
+        (dolist (,type ',types)
+          (setf (gethash ,type *simple-type-map*) ',(car names)))
+        (dolist (,name ',names)
+          (setf (gethash ,name *simple-type-map*) ,(car types)))
+        (defctype ,names ,(car types) :export ,export)
+        (define-c-type-syntax ,(car names) (&rest quals)
+          `(make-simple-type ,',(car types) (list ,@quals)))))))
+
+(export 'find-simple-c-type)
+(defun find-simple-c-type (name)
+  "Return the `simple-c-type' with the given NAME, or nil."
+  (aand (gethash name *simple-type-map*)
+       (make-simple-type (gethash it *simple-type-map*))))

 
 ;; Built-in C types.
 
 
 ;; Built-in C types.
 


@@ -146,9 +251,10 @@
 (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 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 wchar-t "wchar_t" :export t)

 
 

-(define-simple-c-type (int signed signed-int sint) "int" :export t)
+(define-simple-c-type (int signed signed-int sint)
+  ("int" "signed") :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)
 (define-simple-c-type (unsigned unsigned-int uint) "unsigned" :export t)
 
 (define-simple-c-type (short signed-short short-int signed-short-int sshort)


@@ -171,7 +277,7 @@
 (define-simple-c-type double "double" :export t)
 (define-simple-c-type long-double "long double" :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" :export t)
+(define-simple-c-type bool ("_Bool" "bool") :export t)

 
 (define-simple-c-type float-complex "float _Complex" :export t)
 (define-simple-c-type double-complex "double _Complex" :export t)
 
 (define-simple-c-type float-complex "float _Complex" :export t)
 (define-simple-c-type double-complex "double _Complex" :export t)


@@ -186,6 +292,19 @@
 (define-simple-c-type size-t "size_t" :export t)
 (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 
 (define-simple-c-type size-t "size_t" :export t)
 (define-simple-c-type ptrdiff-t "ptrdiff_t" :export t)
 

+(macrolet ((define-cross-product-types (&rest pieces)
+            `(progn
+               ,@(mapcar (lambda (row)
+                           (let* ((c-name (apply #'concatenate 'string row))
+                                  (lisp-name (intern
+                                              (frob-identifier c-name))))
+                             `(define-simple-c-type ,lisp-name ,c-name
+                                                    :export t)))
+                         (apply #'cross-product pieces)))))
+  (define-cross-product-types ("int" "uint") ("" "_least" "_fast")
+                             ("8" "16" "32" "64") "_t")
+  (define-cross-product-types ("int" "uint") ("ptr" "max") "_t"))
+

 ;;;--------------------------------------------------------------------------
 ;;; Tagged types (enums, structs and unions).
 
 ;;;--------------------------------------------------------------------------
 ;;; Tagged types (enums, structs and unions).
 


@@ -223,7 +342,7 @@
               `(progn
                  (export '(,type ,kind ,constructor))
                  (defclass ,type (tagged-c-type) ()
               `(progn
                  (export '(,type ,kind ,constructor))
                  (defclass ,type (tagged-c-type) ()

-                   (:documentation ,(format nil "C ~a types." what)))
+                   (:documentation ,(format nil "C ~A types." what)))

                  (defmethod c-tagged-type-kind ((type ,type))
                    ',keyword)
                  (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
                  (defmethod c-tagged-type-kind ((type ,type))
                    ',keyword)
                  (defmethod kind-c-tagged-type ((kind (eql ',keyword)))


@@ -248,8 +367,8 @@
 
 (defmethod pprint-c-type ((type tagged-c-type) stream kernel)
   (pprint-logical-block (stream nil)
 
 (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)))
            (c-tagged-type-kind type)
            (c-type-tag type))
     (funcall kernel stream 0 t)))


@@ -264,6 +383,55 @@
          (c-type-qualifiers type)))
 
 ;;;--------------------------------------------------------------------------
          (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.
 ;;; Pointer types.
 
 ;; Class definition.


@@ -278,12 +446,9 @@
 (export 'make-pointer-type)
 (defun make-pointer-type (subtype &optional qualifiers)
   "Return a (maybe distinguished) pointer type."
 (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.
 
 
 ;; Comparison protocol.
 


@@ -298,8 +463,8 @@
                 (lambda (stream prio spacep)
                   (when spacep (c-type-space stream))
                   (maybe-in-parens (stream (> prio 1))
                 (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.
                     (funcall kernel stream 1 (c-type-qualifiers type))))))
 
 ;; S-expression notation protocol.


@@ -434,58 +599,79 @@
        (let ((this-name (argument-name this))
              (prev-name (argument-name prev)))
          (when (string= this-name prev-name)
        (let ((this-name (argument-name this))
              (prev-name (argument-name prev)))
          (when (string= this-name prev-name)

-           (error "Duplicate keyword argument name `~A'." this-name)))))
+           (error "Duplicate keyword argument name `~A'" this-name)))))

     list))
 
 (export 'merge-keyword-lists)
     list))
 
 (export 'merge-keyword-lists)

-(defun merge-keyword-lists (lists)
+(defun merge-keyword-lists (whatfn lists)

   "Return the union of keyword argument lists.
 
   "Return the union of keyword argument lists.
 

-   The LISTS parameter consists of pairs (ARGS . WHAT), where ARGS is a list
-   of `argument' objects, and WHAT is either nil or a printable object
-   describing the origin of the corresponding argument list suitable for
-   quoting in an error message.
+   The WHATFN is either nil or a designator for a function (see below).
+
+   The LISTS parameter consists of pairs (REPORTFN . ARGS), where REPORTFN is
+   either nil or a designator for a function (see below); and and ARGS is a
+   list of `argument' objects.

 
    The resulting list contains exactly one argument for each distinct
    argument name appearing in the input lists; this argument will contain the
    default value corresponding to the name's earliest occurrence in the input
    LISTS.
 
 
    The resulting list contains exactly one argument for each distinct
    argument name appearing in the input lists; this argument will contain the
    default value corresponding to the name's earliest occurrence in the input
    LISTS.
 

-   If the same name appears in multiple input lists with different types, an
-   error is signalled; this error will quote the origins of a representative
-   conflicting pair of arguments."
+   If the same name appears in multiple input lists with different types, a
+   continuable error is signalled.
+
+   The WHATFN function is given no arguments, and is expected to return a
+   file location (or other object convertible with `file-location'), and a
+   string (or other printable object) describing the site at which the
+   keyword argument lists are being merged or nil; a mismatch error will be
+   reported as being at the location returned by WHATFN, and the description
+   will be included in the error message.  A nil WHATFN is equivalent to a
+   function which returns a nil location and description, though this is
+   considered poor practice.
+
+   The REPORTFN is given a single argument ARG, which is one of the
+   conflicting `argument' objects found in the REPORTFN's corresponding
+   argument list: the REPORTFN is expected to issue additional `info'
+   messages to help the user diagnose the problem.  The (common) name of the
+   argument has already been reported.  A nil REPORTFN is equivalent to one
+   which does nothing, though this is considered poor practice."

 
   ;; The easy way through all of this is with a hash table mapping argument
 
   ;; The easy way through all of this is with a hash table mapping argument

-  ;; names to (ARGUMENT . WHAT) pairs.
+  ;; names to (WHAT . ARG) pairs.

 
   (let ((argmap (make-hash-table :test #'equal)))
 
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)
 
   (let ((argmap (make-hash-table :test #'equal)))
 
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)

-      (let ((args (car item))
-           (what (cdr item)))
+      (let ((reportfn (car item))
+           (args (cdr item)))

        (dolist (arg args)
          (let* ((name (argument-name arg))
                 (other-item (gethash name argmap)))
            (if (null other-item)
        (dolist (arg args)
          (let* ((name (argument-name arg))
                 (other-item (gethash name argmap)))
            (if (null other-item)

-               (setf (gethash name argmap) (cons arg what))
+               (setf (gethash name argmap) (cons reportfn arg))

                (let* ((type (argument-type arg))
                (let* ((type (argument-type arg))

-                      (other (car other-item))
-                      (other-type (argument-type other))
-                      (other-what (cdr other-item)))
+                      (other-reportfn (car other-item))
+                      (other (cdr other-item))
+                      (other-type (argument-type other)))

                  (unless (c-type-equal-p type other-type)
                  (unless (c-type-equal-p type other-type)

-                   (error "Type mismatch for keyword argument `~A': ~
-                           ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]."
-                          name
-                          type what
-                          other-type other-what))))))))
+                   (multiple-value-bind (floc desc)
+                       (if whatfn (funcall whatfn) (values nil nil))
+                     (cerror*-with-location floc
+                                            "Type mismatch for keyword ~
+                                             argument `~A'~@[ in ~A~]"
+                                            name desc)
+                     (when reportfn
+                       (funcall reportfn arg))
+                     (when other-reportfn
+                       (funcall other-reportfn other))))))))))

 
     ;; Now it's just a matter of picking the arguments out again.
     (let ((result nil))
       (maphash (lambda (name item)
                 (declare (ignore name))
 
     ;; Now it's just a matter of picking the arguments out again.
     (let ((result nil))
       (maphash (lambda (name item)
                 (declare (ignore name))

-                (push (car item) result))
+                (push (cdr item) result))

               argmap)
       (fix-and-check-keyword-argument-list result))))
 
               argmap)
       (fix-and-check-keyword-argument-list result))))