X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/01778b39c53316dda3f757c49276d034039ee9cb..2c6153373f927d948a74b283ebb16330af8ee49a:/src/c-types-impl.lisp

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index e87964c..e5ead1b 100644
--- 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 (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)
@@ -291,6 +292,19 @@
 (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).
 
@@ -589,22 +603,38 @@
     list))
 
 (export 'merge-keyword-lists)
-(defun merge-keyword-lists (lists)
+(defun merge-keyword-lists (whatfn 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.
 
-   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.
@@ -614,23 +644,28 @@
     ;; 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)
-		(setf (gethash name argmap) (cons what arg))
+		(setf (gethash name argmap) (cons reportfn 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)
-		    (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))