[sod] / src / c-types-impl.lisp

;;; -*-lisp-*-
;;;
;;; C type representation implementation
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; 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
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Interning types.

(defparameter *c-type-intern-map* (make-hash-table :test #'equal)
  "Hash table mapping lists describing types to their distinguished
   representations.")

(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)))
    (or (gethash list *c-type-intern-map*)
	(let ((new (apply #'make-instance class initargs)))
	  (setf (gethash new *c-type-intern-map*) t
		(gethash list *c-type-intern-map*) new)))))

#+test
(defun check-type-intern-map ()
  "Sanity check for the type-intern map."
  (let ((map (make-hash-table)))

    ;; Pass 1: check that interned types are consistent with their keys.
    ;; Remember interned types.
    (maphash (lambda (k v)
	       (when (listp k)
		 (let ((ty (apply #'make-instance k)))
		   (assert (c-type-equal-p ty v)))
		 (setf (gethash v map) t)))
	     *c-type-intern-map*)

    ;; Pass 2: check that the interned type indicators are correct.
    (maphash (lambda (k v)
	       (declare (ignore v))
	       (assert (gethash k *c-type-intern-map*)))
	     map)
    (maphash (lambda (k v)
	       (declare (ignore v))
	       (when (typep k 'c-type)
		 (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 #'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))))

;;;--------------------------------------------------------------------------
;;; Simple C types.

;; Class definition.

(export '(simple-c-type c-type-name))
(defclass simple-c-type (qualifiable-c-type)
  ((name :initarg :name :type string :reader c-type-name))
  (:documentation
   "C types with simple forms."))

;; Constructor function and interning.

(export 'make-simple-type)
(defun make-simple-type (name &optional qualifiers)
  "Make a distinguished object for the simple type called NAME."
  (intern-c-type 'simple-c-type
		 :name name
		 :qualifiers (canonify-qualifiers qualifiers)))

;; Comparison protocol.

(defmethod c-type-equal-p and
    ((type-a simple-c-type) (type-b simple-c-type))
  (string= (c-type-name type-a) (c-type-name type-b)))

;; C syntax output protocol.

(defmethod pprint-c-type ((type simple-c-type) stream kernel)
  (pprint-logical-block (stream nil)
    (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)
  "Hash table mapping strings of C syntax to symbolic names.")

(defmethod print-c-type (stream (type simple-c-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (let* ((name (c-type-name type))
	 (symbol (gethash name *simple-type-map*)))
    (format stream "~:[~S~;~:@<~S~0@*~{ ~_~S~}~:>~]"
	    (c-type-qualifiers type) (or symbol name))))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defmethod expand-c-type-spec ((spec string))
    `(make-simple-type ,spec))
  (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 &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))))))

;; Built-in C types.

(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" :export t)
(define-simple-c-type (unsigned-short unsigned-short-int ushort)
  "unsigned short" :export t)

(define-simple-c-type (long signed-long long-int signed-long-int slong)
  "long" :export t)
(define-simple-c-type (unsigned-long unsigned-long-int ulong)
  "unsigned long" :export t)

(define-simple-c-type (long-long signed-long-long long-long-int
		       signed-long-long-int llong sllong)
  "long long" :export t)
(define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
  "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-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).

;; Class definition.

(export '(tagged-c-type c-type-tag))
(defclass tagged-c-type (qualifiable-c-type)
  ((tag :initarg :tag :type string :reader c-type-tag))
  (:documentation
   "C types with tags."))

;; Subclass definitions.

(export 'c-tagged-type-kind)
(defgeneric c-tagged-type-kind (type)
  (:documentation
   "Return the kind of tagged type that TYPE is, as a keyword."))

(export 'kind-c-tagged-type)
(defgeneric kind-c-tagged-type (kind)
  (:documentation
   "Given a keyword KIND, return the appropriate class name."))

(export 'make-c-tagged-type)
(defun make-c-tagged-type (kind tag &optional qualifiers)
  "Return a tagged type with the given KIND (keyword) and TAG (string)."
  (intern-c-type (kind-c-tagged-type kind)
		 :tag tag
		 :qualifiers (canonify-qualifiers qualifiers)))

(macrolet ((define-tagged-type (kind what)
	     (let* ((type (symbolicate 'c- kind '-type))
		    (keyword (intern (symbol-name kind) :keyword))
		    (constructor (symbolicate 'make- kind '-type)))
	       `(progn
		  (export '(,type ,kind ,constructor))
		  (defclass ,type (tagged-c-type) ()
		    (:documentation ,(format nil "C ~a types." what)))
		  (defmethod c-tagged-type-kind ((type ,type))
		    ',keyword)
		  (defmethod kind-c-tagged-type ((kind (eql ',keyword)))
		    ',type)
		  (defun ,constructor (tag &optional qualifiers)
		    (intern-c-type ',type :tag tag
				   :qualifiers (canonify-qualifiers
						qualifiers)))
		  (define-c-type-syntax ,kind (tag &rest quals)
		    ,(format nil "Construct ~A type named TAG" what)
		    `(,',constructor ,tag (list ,@quals)))))))
  (define-tagged-type enum "enumerated")
  (define-tagged-type struct "structure")
  (define-tagged-type union "union"))

;; Comparison protocol.

(defmethod c-type-equal-p and ((type-a tagged-c-type) (type-b tagged-c-type))
  (string= (c-type-tag type-a) (c-type-tag type-b)))

;; C syntax output protocol.

(defmethod pprint-c-type ((type tagged-c-type) stream kernel)
  (pprint-logical-block (stream nil)
    (format stream "~{~A ~@_~}~(~A~) ~A"
	    (c-type-qualifier-keywords type)
	    (c-tagged-type-kind type)
	    (c-type-tag type))
    (funcall kernel stream 0 t)))

;; S-expression notation protocol.

(defmethod print-c-type (stream (type tagged-c-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (format stream "~:@<~S ~@_~S~{ ~_~S~}~:>"
	  (c-tagged-type-kind type)
	  (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.

;; Class definition.

(export 'c-pointer-type)
(defclass c-pointer-type (qualifiable-c-type)
  ((subtype :initarg :subtype :type c-type :reader c-type-subtype))
  (:documentation "C pointer types."))

;; Constructor function.

(export 'make-pointer-type)
(defun make-pointer-type (subtype &optional qualifiers)
  "Return a (maybe distinguished) pointer type."
  (make-or-intern-c-type 'c-pointer-type subtype
			 :subtype subtype
			 :qualifiers (canonify-qualifiers qualifiers)))

;; Comparison protocol.

(defmethod c-type-equal-p and ((type-a c-pointer-type)
			       (type-b c-pointer-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-pointer-type) stream kernel)
  (pprint-c-type (c-type-subtype type) stream
		 (lambda (stream prio spacep)
		   (when spacep (c-type-space stream))
		   (maybe-in-parens (stream (> prio 1))
		     (format stream "*~{~A~^ ~@_~}"
			     (c-type-qualifier-keywords type))
		     (funcall kernel stream 1 (c-type-qualifiers type))))))

;; S-expression notation protocol.

(defmethod print-c-type (stream (type c-pointer-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (format stream "~:@<* ~@_~/sod:print-c-type/~{ ~_~S~}~:>"
	  (c-type-subtype type)
	  (c-type-qualifiers type)))

(export '(* pointer ptr))
(define-c-type-syntax * (sub &rest quals)
  "Return the type of pointer-to-SUB."
  `(make-pointer-type ,(expand-c-type-spec sub) (list ,@quals)))
(c-type-alias * pointer ptr)

;; Built-in C types.

(export '(string const-string))
(defctype string (* char))
(defctype const-string (* (char :const)))

;;;--------------------------------------------------------------------------
;;; Array types.

;; Class definition.

(export '(c-array-type c-array-dimensions))
(defclass c-array-type (c-type)
  ((subtype :initarg :subtype :type c-type :reader c-type-subtype)
   (dimensions :initarg :dimensions :type list :reader c-array-dimensions))
  (:documentation
   "C array types."))

;; Constructor function.

(export 'make-array-type)
(defun make-array-type (subtype dimensions)
  "Return a new array of SUBTYPE with given DIMENSIONS."
  (make-instance 'c-array-type :subtype subtype
		 :dimensions (or dimensions '(nil))))

;; Comparison protocol.

(defmethod c-type-equal-p and ((type-a c-array-type) (type-b c-array-type))

  ;; Messy.  C doesn't have multidimensional arrays, but we fake them for
  ;; convenience's sake.  But it means that we have to arrange for
  ;; multidimensional arrays to equal vectors of vectors -- and in general
  ;; for multidimensional arrays of multidimensional arrays to match each
  ;; other properly, even when their dimensions don't align precisely.
  (labels ((check (sub-a dim-a sub-b dim-b)
	     (cond ((endp dim-a)
		    (cond ((endp dim-b)
			   (c-type-equal-p sub-a sub-b))
			  ((typep sub-a 'c-array-type)
			   (check (c-type-subtype sub-a)
				  (c-array-dimensions sub-a)
				  sub-b dim-b))
			  (t
			   nil)))
		   ((endp dim-b)
		    (check sub-b dim-b sub-a dim-a))
		   ((equal (car dim-a) (car dim-b))
		    (check sub-a (cdr dim-a) sub-b (cdr dim-b)))
		   (t
		    nil))))
    (check (c-type-subtype type-a) (c-array-dimensions type-a)
	   (c-type-subtype type-b) (c-array-dimensions type-b))))

;; C syntax output protocol.

(defmethod pprint-c-type ((type c-array-type) stream kernel)
  (pprint-c-type (c-type-subtype type) stream
		 (lambda (stream prio spacep)
		   (maybe-in-parens (stream (> prio 2))
		     (funcall kernel stream 2 spacep)
		     (format stream "~@<~{[~@[~A~]]~^~_~}~:>"
			     (c-array-dimensions type))))))

;; S-expression notation protocol.

(defmethod print-c-type (stream (type c-array-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (format stream "~:@<[] ~@_~:I~/sod:print-c-type/~{ ~_~S~}~:>"
	  (c-type-subtype type)
	  (c-array-dimensions type)))

(export '([] array vec))
(define-c-type-syntax [] (sub &rest dims)
  "Return the type of arrays of SUB with the dimensions DIMS.

   If the DIMS are omitted, a single unknown-length dimension is added."
  `(make-array-type ,(expand-c-type-spec sub)
		    (list ,@(or dims '(nil)))))
(c-type-alias [] array vec)

;;;--------------------------------------------------------------------------
;;; Function types.

;; Function arguments.

(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
   the same type, or be `:ellipsis'.  The argument names are not inspected."
  (and (= (length list-a) (length list-b))
       (every (lambda (arg-a arg-b)
		(if (eq arg-a :ellipsis)
		    (eq arg-b :ellipsis)
		    (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 :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 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))
       (argument-lists-equal-p (c-function-arguments type-a)
			       (c-function-arguments type-b))))

;; C syntax output protocol.

(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)))))))))))

;; S-expression notation protocol.

(defmethod print-c-type
    (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/~:>~}~
		  ~:>"
	  (c-type-subtype type)
	  (mapcar (lambda (arg)
		    (if (eq arg :ellipsis) arg
			(list (argument-name arg) (argument-type arg))))
		  (c-function-arguments type))))

(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.

   The ARGS are a list of arguments of the form (NAME TYPE).  The NAME can be
   NIL to indicate that no name was given.

   If an entry isn't a list, it's assumed to be the start of a Lisp
   expression to compute the tail of the list; similarly, if the list is
   improper, then it's considered to be a complete expression.  The upshot of
   this apparently bizarre rule is that you can say

     (c-type (fun int (\"foo\" int) . arg-tail))

   where ARG-TAIL is (almost) any old Lisp expression and have it tack the
   arguments onto the end.  Of course, there don't have to be any explicit
   arguments at all.  The only restriction is that the head of the Lisp form
   can't be a list -- so ((lambda (...) ...) ...) is out, but you probably
   wouldn't type that anyway."

  `(make-function-type ,(expand-c-type-spec ret)
		       ,(do ((args args (cdr args))
			     (list nil
				   (cons `(make-argument ,(caar args)
							 ,(expand-c-type-spec
							   (cadar args)))
					 list)))
			    ((or (atom args) (atom (car args)))
			     (cond ((and (null args) (null list)) `nil)
				   ((null args) `(list ,@(nreverse list)))
				   ((and (consp args)
					 (eq (car args) :ellipsis))
				    `(list ,@(nreverse list) :ellipsis))
				   ((null list) `,args)
				   (t `(list* ,@(nreverse list) ,args)))))))
(c-type-alias fun function () func fn)

;; Additional utilities for dealing with functions.

(export 'commentify-argument-names)
(defun commentify-argument-names (arguments)
  "Return an argument list with the arguments commentified.

   That is, with each argument name passed through
   `commentify-argument-name'."
  (mapcar (lambda (arg)
	    (if (eq arg :ellipsis) arg
		(make-argument (commentify-argument-name (argument-name arg))
			       (argument-type arg))))
	  arguments))

(export 'commentify-function-type)
(defun commentify-function-type (type)
  "Return a type like TYPE, but with arguments commentified.

   This doesn't recurse into the return type or argument types."
  (make-function-type (c-type-subtype type)
		      (commentify-argument-names
		       (c-function-arguments type))))

;;;----- That's all, folks --------------------------------------------------