X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/blobdiff_plain/4d89d941ae5c674e85ae5402361cb893c07ce65b..ae0f15ee8427fa91cfd1945bfded847032cb8a25:/src/c-types-impl.lisp diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp index be2c055..d0d4a74 100644 --- a/src/c-types-impl.lisp +++ b/src/c-types-impl.lisp @@ -7,7 +7,7 @@ ;;;----- 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 @@ -66,12 +66,31 @@ (defun check-type-intern-map () (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))) @@ -106,8 +125,8 @@ (defmethod c-type-equal-p and (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))) @@ -130,59 +149,61 @@ (defmethod expand-c-type-form ((head string) tail) `(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") +(define-simple-c-type void "void" :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 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") -(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") -(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 va-list "va_list") -(define-simple-c-type size-t "size_t") -(define-simple-c-type ptrdiff-t "ptrdiff_t") +(define-simple-c-type 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 long-double-complex "long double _Complex" :export 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). @@ -246,8 +267,8 @@ (defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type)) (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))) @@ -261,6 +282,55 @@ (defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign) (c-type-tag type) (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. @@ -276,12 +346,9 @@ (defclass c-pointer-type (qualifiable-c-type) (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. @@ -296,8 +363,8 @@ (defmethod pprint-c-type ((type c-pointer-type) stream kernel) (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. @@ -400,7 +467,7 @@ (c-type-alias [] array vec) ;; 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 @@ -409,8 +476,9 @@ (defun arguments-lists-equal-p (list-a list-b) (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. @@ -418,31 +486,38 @@ (defun arguments-lists-equal-p (list-a list-b) (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)) - (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. @@ -479,12 +554,11 @@ (defmethod 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)))) -(export '(fun function func fn)) +(export '(fun function () func fn)) (define-c-type-syntax fun (ret &rest args) "Return the type of functions which returns RET and has arguments ARGS. @@ -530,8 +604,7 @@ (defun commentify-argument-names (arguments) 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))