X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/0e7cdea08f8c635a46e66bd0a96bb6f12b907bbc..243cffbf70b9e0155a17563a66efbb6bf34c820c:/src/c-types-impl.lisp?ds=sidebyside diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index 56eee89..5bd9703 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -130,74 +130,61 @@ `(make-simple-type ,head (list ,@tail)))) (export 'define-simple-c-type) -(defmacro define-simple-c-type (names 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) + (defctype ,names ,type :export ,export) (define-c-type-syntax ,(car names) (&rest quals) `(make-simple-type ,',type (list ,@quals)))))) ;; Built-in C types. -(export '(void - float double long-double - float-complex double-complex long-double-complex - float-imaginary double-imaginary long-double-imaginary - va-list size-t ptrdiff-t wchar-t - char unsigned-char uchar signed-char schar - int signed signed-int sint unsigned unsigned-int uint - short signed-short short-int signed-short-int sshort - unsigned-short unsigned-short-int ushort - long signed-long long-int signed-long-int slong - unsigned-long unsigned-long-int ulong - long-long signed-long-long long-long-int signed-long-long-int - unsigned-long-long unsigned-long-long-int llong sllong ullong)) - -(define-simple-c-type void "void") - -(define-simple-c-type char "char") -(define-simple-c-type (unsigned-char uchar) "unsigned char") -(define-simple-c-type (signed-char schar) "signed char") -(define-simple-c-type wchar-t "wchar-t") - -(define-simple-c-type (int signed signed-int sint) "int") -(define-simple-c-type (unsigned unsigned-int uint) "unsigned") +(define-simple-c-type void "void" :export t) + +(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 (int signed signed-int sint) "int" :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) - "short") + "short" :export t) (define-simple-c-type (unsigned-short unsigned-short-int ushort) - "unsigned short") + "unsigned short" :export t) (define-simple-c-type (long signed-long long-int signed-long-int slong) - "long") + "long" :export t) (define-simple-c-type (unsigned-long unsigned-long-int ulong) - "unsigned long") + "unsigned long" :export t) (define-simple-c-type (long-long signed-long-long long-long-int signed-long-long-int llong sllong) - "long long") + "long long" :export t) (define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong) - "unsigned long long") + "unsigned long long" :export t) -(define-simple-c-type float "float") -(define-simple-c-type double "double") -(define-simple-c-type long-double "long double") +(define-simple-c-type float "float" :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") +(define-simple-c-type bool "_Bool" :export t) -(define-simple-c-type float-complex "float _Complex") -(define-simple-c-type double-complex "double _Complex") -(define-simple-c-type long-double-complex "long double _Complex") +(define-simple-c-type float-complex "float _Complex" :export t) +(define-simple-c-type double-complex "double _Complex" :export t) +(define-simple-c-type long-double-complex "long double _Complex" :export t) -(define-simple-c-type float-imaginary "float _Imaginary") -(define-simple-c-type double-imaginary "double _Imaginary") -(define-simple-c-type long-double-imaginary "long double _Imaginary") +(define-simple-c-type float-imaginary "float _Imaginary" :export t) +(define-simple-c-type double-imaginary "double _Imaginary" :export t) +(define-simple-c-type long-double-imaginary + "long double _Imaginary" :export t) -(define-simple-c-type va-list "va_list") -(define-simple-c-type size-t "size_t") -(define-simple-c-type ptrdiff-t "ptrdiff_t") +(define-simple-c-type va-list "va_list" :export t) +(define-simple-c-type size-t "size_t" :export t) +(define-simple-c-type ptrdiff-t "ptrdiff_t" :export t) ;;;-------------------------------------------------------------------------- ;;; Tagged types (enums, structs and unions). @@ -415,7 +402,7 @@ ;; Function arguments. -(defun arguments-lists-equal-p (list-a list-b) +(defun argument-lists-equal-p (list-a list-b) "Return whether LIST-A and LIST-B match. They must have the same number of arguments, and each argument must have @@ -424,8 +411,9 @@ (every (lambda (arg-a arg-b) (if (eq arg-a :ellipsis) (eq arg-b :ellipsis) - (c-type-equal-p (argument-type arg-a) - (argument-type arg-b)))) + (and (argumentp arg-a) (argumentp arg-b) + (c-type-equal-p (argument-type arg-a) + (argument-type arg-b))))) list-a list-b))) ;; Class definition. @@ -463,32 +451,62 @@ (defmethod c-type-equal-p and ((type-a c-function-type) (type-b c-function-type)) (and (c-type-equal-p (c-type-subtype type-a) (c-type-subtype type-b)) - (arguments-lists-equal-p (c-function-arguments type-a) - (c-function-arguments type-b)))) + (argument-lists-equal-p (c-function-arguments type-a) + (c-function-arguments type-b)))) ;; C syntax output protocol. +(export 'pprint-c-function-type) +(defun pprint-c-function-type (return-type stream print-args print-kernel) + "Common top-level printing for function types. + + Prints RETURN-TYPE (KERNEL(ARGS)), where RETURN-TYPE is the actual return + type, and ARGS and KERNEL are whatever is printed by the PRINT-ARGS and + PRINT-KERNEL functions. + + The PRINT-KERNEL function is the standard such thing for the + `pprint-c-type' protocol; PRINT-ARGS accepts just an output stream." + (pprint-c-type return-type stream + (lambda (stream prio spacep) + (maybe-in-parens (stream (> prio 2)) + (when spacep (c-type-space stream)) + (funcall print-kernel stream 2 nil) + (pprint-indent :block 4 stream) + (pprint-newline :linear stream) + (pprint-logical-block + (stream nil :prefix "(" :suffix ")") + (funcall print-args stream)))))) + +(export 'pprint-argument-list) +(defun pprint-argument-list (args stream) + "Print an argument list. + + The ARGS is a list of `argument' objects, optionally containing an + `:ellipsis' marker. The output is written to STREAM. + + Returns non-nil if any arguments were actually printed." + (let ((anyp nil)) + (pprint-logical-block (stream nil) + (dolist (arg args) + (if anyp + (format stream ", ~_") + (setf anyp t)) + (etypecase arg + ((member :ellipsis) + (write-string "..." stream)) + (argument + (pprint-logical-block (stream nil) + (pprint-c-type (argument-type arg) stream + (argument-name arg))))))) + anyp)) + (let ((void-arglist (list (make-argument nil c-type-void)))) (defmethod pprint-c-type ((type c-function-type) stream kernel) - (pprint-c-type (c-type-subtype type) stream - (lambda (stream prio spacep) - (maybe-in-parens (stream (> prio 2)) - (when spacep (c-type-space stream)) - (funcall kernel stream 2 nil) - (pprint-indent :block 4 stream) - (pprint-logical-block - (stream nil :prefix "(" :suffix ")") - (let ((firstp t)) - (dolist (arg (or (c-function-arguments type) - void-arglist)) - (if firstp - (setf firstp nil) - (format stream ", ~_")) - (if (eq arg :ellipsis) - (write-string "..." stream) - (pprint-c-type (argument-type arg) - stream - (argument-name arg))))))))))) + (let ((args (or (c-function-arguments type) void-arglist))) + (pprint-c-function-type (c-type-subtype type) stream + (lambda (stream) + (pprint-argument-list args stream)) + kernel)))) ;; S-expression notation protocol. @@ -496,13 +514,13 @@ (stream (type c-function-type) &optional colon atsign) (declare (ignore colon atsign)) (format stream "~:@<~ - FUN ~@_~:I~/sod:print-c-type/~ - ~{ ~_~:<~S ~@_~/sod:print-c-type/~:>~}~ + FUN ~@_~:I~ + ~/sod:print-c-type/~:[~; ~]~:*~_~ + ~<~@{~:<~S ~@_~/sod:print-c-type/~:>~^ ~_~}~:>~ ~:>" (c-type-subtype type) (mapcar (lambda (arg) - (if (eq arg :ellipsis) - arg + (if (eq arg :ellipsis) arg (list (argument-name arg) (argument-type arg)))) (c-function-arguments type)))) @@ -552,8 +570,7 @@ That is, with each argument name passed through `commentify-argument-name'." (mapcar (lambda (arg) - (if (eq arg :ellipsis) - arg + (if (eq arg :ellipsis) arg (make-argument (commentify-argument-name (argument-name arg)) (argument-type arg)))) arguments))