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 e87964c..e5ead1b 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -253,7 +253,8 @@
 (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 (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 (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)


@@ -291,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).
 


@@ -589,22 +603,38 @@
     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 (WHAT . ARGS), where WHAT is either
-   nil or a printable object describing the origin of this argument list
-   suitable for inclusion in an error message, and ARGS is a list of
-   `argument' objects.
+   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
   ;; names to (WHAT . ARG) pairs.
 
   ;; The easy way through all of this is with a hash table mapping argument
   ;; names to (WHAT . ARG) pairs.


@@ -614,23 +644,28 @@
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)
     ;; Set up the table.  When we find a duplicate, check that the types
     ;; match.
     (dolist (item lists)

-      (let ((what (car 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)
            (args (cdr item)))
        (dolist (arg args)
          (let* ((name (argument-name arg))
                 (other-item (gethash name argmap)))
            (if (null other-item)

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

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

-                      (other-what (car other-item))
+                      (other-reportfn (car other-item))

                       (other (cdr other-item))
                       (other-type (argument-type other)))
                  (unless (c-type-equal-p type other-type)
                       (other (cdr other-item))
                       (other-type (argument-type other)))
                  (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))
 
     ;; Now it's just a matter of picking the arguments out again.
     (let ((result nil))