X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/b6f84c5704b54f0393144d8a0753a69158437cc0..c6b4ed992d81518f240509e6ab212d8fe705485a:/src/c-types-impl.lisp diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index 7884518..e5ead1b 100644 --- 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." - (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. @@ -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 (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) @@ -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 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) @@ -280,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). @@ -317,7 +342,7 @@ `(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))) @@ -574,58 +599,79 @@ (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) -(defun merge-keyword-lists (lists) +(defun merge-keyword-lists (whatfn 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. - 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 (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 ((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) - (setf (gethash name argmap) (cons arg what)) + (setf (gethash name argmap) (cons reportfn 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) - (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)) - (push (car item) result)) + (push (cdr item) result)) argmap) (fix-and-check-keyword-argument-list result))))