;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
`(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 va-list size-t ptrdiff-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" :export t)
-(define-simple-c-type void "void")
+(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 char "char")
-(define-simple-c-type (unsigned-char uchar) "unsigned char")
-(define-simple-c-type (signed-char schar) "signed char")
-
-(define-simple-c-type (int signed signed-int sint) "int")
-(define-simple-c-type (unsigned unsigned-int uint) "unsigned")
+(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" :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 float "float")
-(define-simple-c-type double "double")
-(define-simple-c-type long-double "long double")
+(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 va-list "va_list")
-(define-simple-c-type size-t "size_t")
-(define-simple-c-type ptrdiff-t "ptrdiff_t")
+(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" :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).
;; 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
(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.
(export '(c-function-type c-function-arguments))
(defclass c-function-type (c-type)
((subtype :initarg :subtype :type c-type :reader c-type-subtype)
- (arguments :initarg :arguments :type list :reader c-function-arguments))
+ (arguments :type list :reader c-function-arguments))
(:documentation
"C function types. The subtype is the return type, as implied by the C
syntax for function declarations."))
+(defmethod shared-initialize :after
+ ((type c-function-type) slot-names &key (arguments nil argsp))
+ (declare (ignore slot-names))
+ (when argsp
+ (setf (slot-value type 'arguments)
+ (if (and arguments
+ (null (cdr arguments))
+ (not (eq (car arguments) :ellipsis))
+ (eq (argument-type (car arguments)) c-type-void))
+ nil
+ arguments))))
+
;; Constructor function.
(export 'make-function-type)
(defun make-function-type (subtype arguments)
"Return a new function type, returning SUBTYPE and accepting ARGUMENTS."
(make-instance 'c-function-type :subtype subtype
- :arguments (if (and arguments
- (null (cdr arguments))
- (not (eq (car arguments) :ellipsis))
- (eq (argument-type (car arguments))
- c-type-void))
- nil
- arguments)))
+ :arguments arguments))
;; Comparison protocol.
(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-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.
~:>"
(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))))
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))
~mdw / sod / blobdiff