src/class-make-{proto,impl}.lisp: Don't always add initializers to classes.

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

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 7884518..e5ead1b 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -226,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.
 


@@ -242,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)


@@ -265,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)


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


@@ -317,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)))


@@ -574,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))))