;;; -*-lisp-*-
;;;
;;; Dealing with C types
;;;
;;; (c) 2008 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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)

;;;--------------------------------------------------------------------------
;;; Plain old C types.

;; Class definition.

(defclass c-type ()
  ()
  (:documentation
   "Base class for C type objects."))

;; Important protocol.

(defgeneric c-type-subtype (type)
  (:documentation
   "For compound types, return the base type."))

(defgeneric c-type-equal-p (type-a type-b)
  (:method-combination and)
  (:documentation
   "Answers whether two types TYPE-A and TYPE-B are, in fact, equal.")
  (:method and (type-a type-b)
    (eql (class-of type-a) (class-of type-b))))

(defgeneric pprint-c-type (type stream kernel)
  (:documentation
   "Pretty-printer for C types.

   Print TYPE to STREAM.  In the middle of the declarator, call the function
   KERNEL with one argument: whether it needs a leading space.")
  (:method :around (type stream kernel)
    (typecase kernel
      (function (call-next-method))
      (null (pprint-c-type type stream
			   (lambda (stream prio spacep)
			     (declare (ignore stream prio spacep))
			     nil)))
      (t (pprint-c-type type stream
			(lambda (stream prio spacep)
			  (declare (ignore prio))
			  (when spacep
			    (c-type-space stream))
			  (princ kernel stream)))))))

(defgeneric print-c-type (stream type &optional colon atsign)
  (:documentation
   "Print an abbreviated syntax for TYPE to the STREAM."))

(defmethod print-object ((object c-type) stream)
  (if *print-escape*
      (format stream "~:@<C-TYPE ~/sod::print-c-type/~:>" object)
      (pprint-c-type object stream nil)))

;; Utility functions and macros.

(defun c-type-space (stream)
  "Print a space and a miser-mode newline to STREAM.

   This is the right function to call in a PPRINT-C-TYPE kernel function when
   the SPACEP argument is true."
  (pprint-indent :block 2 stream)
  (write-char #\space stream)
  (pprint-newline :miser stream))

(defun maybe-in-parens* (stream condition thunk)
  "Helper function for the MAYBE-IN-PARENS macro."
  (pprint-logical-block
      (stream nil
	      :prefix (if condition "(" "")
	      :suffix (if condition ")" ""))
    (funcall thunk stream)))

(defmacro maybe-in-parens ((stream condition) &body body)
  "Evaluate BODY; if CONDITION, write parens to STREAM around it.

   This macro is useful for implementing the PPRINT-C-TYPE method on compound
   types.  The BODY is evaluated in the context of a logical block printing
   to STREAM.  If CONDITION is non-nil, then the block will have open/close
   parens as its prefix and suffix; otherwise they will be empty.

   The STREAM is passed to PPRINT-LOGICAL-BLOCK, so it must be a symbol."
  `(maybe-in-parens* ,stream ,condition (lambda (,stream) ,@body)))

;; S-expression syntax machinery.

(defun c-name-case (name)
  "Convert NAME to suitable case.

   Strings are returned as-is; symbols are squashed to lower-case and hyphens
   are replaced by underscores."
  (typecase name
    (symbol (with-output-to-string (out)
	      (loop for ch across (symbol-name name)
		    do (cond ((alpha-char-p ch)
			      (write-char (char-downcase ch) out))
			     ((or (digit-char-p ch)
				  (char= ch #\_))
			      (write-char ch out))
			     ((char= ch #\-)
			      (write-char #\_ out))
			     (t
			      (error "Bad character in C name ~S." name))))))
    (t name)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric expand-c-type-spec (spec)
    (:documentation
     "Expand SPEC into Lisp code to construct a C type.")
    (:method ((spec list))
      (expand-c-type-form (car spec) (cdr spec))))
  (defgeneric expand-c-type-form (head tail)
    (:documentation
     "Expand a C type list beginning with HEAD.")
    (:method ((name (eql 'lisp)) tail)
      `(progn ,@tail))))

(defmacro c-type (spec)
  "Expands to code to construct a C type, using EXPAND-C-TYPE-SPEC."
  (expand-c-type-spec spec))

(defmacro define-c-type-syntax (name bvl &rest body)
  "Define a C-type syntax function.

   A function defined by BODY and with lambda-list BVL is associated with the
   NAME.  When EXPAND-C-TYPE sees a list (NAME . STUFF), it will call this
   function with the argument list STUFF."
  (let ((headvar (gensym "HEAD"))
	(tailvar (gensym "TAIL")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       (defmethod expand-c-type-form ((,headvar (eql ',name)) ,tailvar)
	 (destructuring-bind ,bvl ,tailvar
	   ,@body)))))

(defmacro c-type-alias (original &rest aliases)
  "Make ALIASES behave the same way as the ORIGINAL type."
  (let ((headvar (gensym "HEAD"))
	(tailvar (gensym "TAIL")))
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       ,@(mapcar (lambda (alias)
		   `(defmethod expand-c-type-form
			((,headvar (eql ',alias)) ,tailvar)
		      (expand-c-type-form ',original ,tailvar)))
		 aliases))))

(defmacro defctype (names value)
  "Define NAMES all to describe the C-type VALUE.

   NAMES can be a symbol (treated as a singleton list), or a list of symbols.
   The VALUE is a C type S-expression, acceptable to EXPAND-C-TYPE.  It will
   be expanded once at run-time."
  (let* ((names (if (listp names) names (list names)))
	 (namevar (gensym "NAME"))
	 (typevar (symbolicate 'c-type- (car names))))
    `(progn
       (defparameter ,typevar ,(expand-c-type-spec value))
       (eval-when (:compile-toplevel :load-toplevel :execute)
	 ,@(mapcar (lambda (name)
		     `(defmethod expand-c-type-spec ((,namevar (eql ',name)))
			',typevar))
		   names)))))

;;;--------------------------------------------------------------------------
;;; Types which can accept qualifiers.

;; Basic definitions.

(defclass qualifiable-c-type (c-type)
  ((qualifiers :initarg :qualifiers :initform nil
	       :type list :accessor c-type-qualifiers))
  (:documentation
   "Base class for C types which can be qualified."))

(defun format-qualifiers (quals)
  "Return a string listing QUALS, with a space after each."
  (format nil "~{~(~A~) ~}" quals))

(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
			       (type-b qualifiable-c-type))
  (flet ((fix (type)
	   (sort (copy-list (c-type-qualifiers type)) #'string<)))
    (equal (fix type-a) (fix type-b))))

;; A handy utility.

(let ((cache (make-hash-table :test #'equal)))
  (defun qualify-type (c-type qualifiers)
    "Returns a qualified version of C-TYPE.

   Maintains a cache of qualified types so that we don't have to run out of
   memory.  This can also speed up type comparisons."
    (if (null qualifiers)
	c-type
	(let ((key (cons c-type qualifiers)))
	  (unless (typep c-type 'qualifiable-c-type)
	    (error "~A isn't qualifiable." (class-name (class-of c-type))))
	  (or (gethash key cache)
	      (setf (gethash key cache)
		    (copy-instance c-type :qualifiers qualifiers)))))))

;;;--------------------------------------------------------------------------
;;; Simple C types (e.g., built-in arithmetic types).

(defvar *simple-type-map* (make-hash-table :test #'equal)
  "A hash table mapping type strings to Lisp symbols naming them.")

;; Basic definitions.

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

(let ((cache (make-hash-table :test #'equal)))
  (defun make-simple-type (name &optional qualifiers)
    "Make a distinguished object for the simple type called NAME."
    (qualify-type (or (gethash name cache)
		      (setf (gethash name cache)
			    (make-instance 'simple-c-type :name name)))
		  qualifiers)))

(defmethod pprint-c-type ((type simple-c-type) stream kernel)
  (pprint-logical-block (stream nil)
    (format stream "~{~(~A~) ~@_~}~A"
	    (c-type-qualifiers type)
	    (c-type-name type))
    (funcall kernel stream 0 t)))

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

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

;; S-expression syntax.

(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 ,@tail)))

(defmacro define-simple-c-type (names type)
  "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)
       (define-c-type-syntax ,(car names) (&rest quals)
	 `(make-simple-type ,',type (list ,@quals))))))

(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 (int signed signed-int sint) "int")
(define-simple-c-type (unsigned unsigned-int uint) "unsigned")

(define-simple-c-type (short signed-short short-int signed-short-int sshort)
  "short")
(define-simple-c-type (unsigned-short unsigned-short-int ushort)
  "unsigned short")

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

(define-simple-c-type (long-long signed-long-long long-long-int
		       signed-long-long-int llong sllong)
  "long long")
(define-simple-c-type (unsigned-long-long unsigned-long-long-int ullong)
  "unsigned long long")

(define-simple-c-type float "float")
(define-simple-c-type double "double")
(define-simple-c-type long-double "long double")

(define-simple-c-type va-list "va_list")
(define-simple-c-type size-t "size_t")
(define-simple-c-type ptrdiff-t "ptrdiff_t")

;;;--------------------------------------------------------------------------
;;; Tag types (structs, unions and enums).

;; Definitions.

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

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

(macrolet ((define-tagged-type (kind what)
	     (let ((type (symbolicate 'c- kind '-type))
		   (constructor (symbolicate 'make- kind '-type)))
	       `(progn
		  (defclass ,type (tagged-c-type) ()
		    (:documentation ,(format nil "C ~a types." what)))
		  (defmethod c-tagged-type-kind ((type ,type))
		    ',kind)
		  (let ((cache (make-hash-table :test #'equal)))
		    (defun ,constructor (tag &optional qualifiers)
		      (qualify-type (or (gethash tag cache)
					(setf (gethash tag cache)
					      (make-instance ',type
							     :tag tag)))
				    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"))

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

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

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

;;;--------------------------------------------------------------------------
;;; Pointer types.

;; Definitions.

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

(let ((cache (make-hash-table :test #'eql)))
  (defun make-pointer-type (subtype &optional qualifiers)
    "Return a (maybe distinguished) pointer type."
    (qualify-type (or (gethash subtype cache)
		      (make-instance 'c-pointer-type :subtype subtype))
		  qualifiers)))

(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-qualifiers type))
		     (funcall kernel stream 1 (c-type-qualifiers type))))))

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

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

;; S-expression syntax.

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

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

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

;; Definitions.

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

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

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

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

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

;; S-expression syntax.

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

;; Arguments.

(defstruct (argument (:constructor make-argument (name type)) (:type list))
  "Simple list structure representing a function argument."
  name
  type)

(defun arguments-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)
		    (c-type-equal-p (argument-type arg-a)
				    (argument-type arg-b))))
	      list-a list-b)))

(defgeneric commentify-argument-name (name)
  (:documentation
   "Produce a `commentified' version of the argument.

   The default behaviour is that temporary argument names are simply omitted
   (NIL is returned); otherwise, `/*...*/' markers are wrapped around the
   printable representation of the argument.")
  (:method ((name null)) nil)
  (:method ((name t)) (format nil "/*~A*/" name)))

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

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

;; Definitions.

(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))
  (:documentation
   "C function types.  The subtype is the return type, as implied by the C
    syntax for function declarations."))

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

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

(defmethod print-c-type
    (stream (type c-function-type) &optional colon atsign)
  (declare (ignore colon atsign))
  (format stream
	  #.(concatenate 'string
			 "~:@<"
			 "FUN ~@_~:I~/sod::print-c-type/"
			 "~{ ~_~:<~S ~@_~/sod::print-c-type/~:>~}"
			 "~:>")
	  (c-type-subtype type)
	  (c-function-arguments type)))

(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-newline :miser stream)
		     (pprint-logical-block
			 (stream nil :prefix "(" :suffix ")")
		       (let ((firstp t))
			 (dolist (arg (c-function-arguments type))
			   (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 syntax.

(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)))
				   ((null list) `,args)
				   (t `(list* ,@(nreverse list) ,args)))))))
(c-type-alias fun function () func fn)

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