(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
(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 "~:@<SPECS ~@_~:I~/sod:print-c-type/~
+ ~{ ~_~/sod:print-c-storage-specifier/~}~:>"
+ (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.
(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)
(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.
(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 (unsigned unsigned-int uint) "unsigned" :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 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)
`(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)))
(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)))
(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 "~:@<ATOMIC ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
+ (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.
(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.
(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.
(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)
(other-what (cdr other-item)))
(unless (c-type-equal-p type other-type)
(error "Type mismatch for keyword argument `~A': ~
- ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]."
+ ~A~@[ (~A)~] doesn't match ~A~@[ (~A)~]"
name
type what
other-type other-what))))))))