X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/ced609b8c5cc865f25cf5cce91a3d7dc9c85bdee..c6b4ed992d81518f240509e6ab212d8fe705485a:/src/c-types-impl.lisp diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index 16351a3..e5ead1b 100644 --- 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." - (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 @@ -66,17 +81,96 @@ (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) - (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))) ;;;-------------------------------------------------------------------------- +;;; 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 "~:@" + (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. @@ -106,14 +200,14 @@ (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. -(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) @@ -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." - (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. @@ -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 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) @@ -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 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) @@ -186,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). @@ -223,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))) @@ -248,8 +367,8 @@ (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))) @@ -264,6 +383,55 @@ (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 "~:@" + (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. @@ -278,12 +446,9 @@ (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. @@ -298,8 +463,8 @@ (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. @@ -434,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))))