;;;--------------------------------------------------------------------------
;;; C types stuff.

(cl:defpackage #:c-types
  (:use #:common-lisp
	#+sbcl #:sb-mop
	#+(or cmu clisp) #:mop
	#+ecl #:clos)
  (:export #:c-type
	   #:c-declarator-priority #:maybe-parenthesize
	   #:pprint-c-type
	   #:c-type-subtype #:compount-type-declaration
	   #:qualifiable-c-type #:c-type-qualifiers #:format-qualifiers
	   #:simple-c-type #:c-type-name
	   #:c-pointer-type
	   #:tagged-c-type #:c-enum-type #:c-struct-type #:c-union-type
	   #:tagged-c-type-kind
	   #:c-array-type #:c-array-dimensions
	   #:make-argument #:argument-name #:argument-type
	   #:c-function-type #:c-function-arguments

	   #:define-c-type-syntax #:c-type-alias #:defctype
	   #:print-c-type
	   #:qualifier #:declare-qualifier
	   #:define-simple-c-type

	   #:const #:volatile #:static #:restrict
	   #: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
	   #:float #:double #:long-double
	   #:pointer #:ptr
	   #:[] #:vec
	   #:fun #:func #:fn))


;;;--------------------------------------------------------------------------
;;; Convenient syntax for C types.

;; Basic machinery.

;; Qualifiers.  They have hairy syntax and need to be implemented by hand.

;; Simple types.

;; Pointers.

;; Tagged types.

;; Arrays.

;; Functions.


(progn
  (defconstant q-byte (byte 3 0))
  (defconstant q-const 1)
  (defconstant q-volatile 2)
  (defconstant q-restrict 4)

  (defconstant z-byte (byte 3 3))
  (defconstant z-unspec 0)
  (defconstant z-short 1)
  (defconstant z-long 2)
  (defconstant z-long-long 3)
  (defconstant z-double 4)
  (defconstant z-long-double 5)

  (defconstant s-byte (byte 2 6))
  (defconstant s-unspec 0)
  (defconstant s-signed 1)
  (defconstant s-unsigned 2)

  (defconstant t-byte (byte 3 8))
  (defconstant t-unspec 0)
  (defconstant t-int 1)
  (defconstant t-char 2)
  (defconstant t-float 3)
  (defconstant t-user 4))

(defun make-type-flags (size sign type &rest quals)
  (let ((flags 0))
    (dolist (qual quals)
      (setf flags (logior flags qual)))
    (setf (ldb z-byte flags) size
	  (ldb s-byte flags) sign
	  (ldb t-byte flags) type)
    flags))


(defun expand-c-type (spec)
  "Parse SPEC as a C type and return the result.

   The SPEC can be one of the following.

     * A C-TYPE object, which is returned immediately.

     * A list, (OPERATOR . ARGUMENTS), where OPERATOR is a symbol: a parser
       function associated with the OPERATOR symbol by DEFINE-C-TYPE-SYNTAX
       or some other means is invoked on the ARGUMENTS, and the result is
       returned.

     * A symbol, which is treated the same way as a singleton list would be."

  (flet ((interp (sym)
	   (or (get sym 'c-type)
	       (error "Unknown C type operator ~S." sym))))
    (etypecase spec
      (c-type spec)
      (symbol (funcall (interp spec)))
      (list (apply (interp (car spec)) (cdr spec))))))

(defmacro c-type (spec)
  "Evaluates to the type that EXPAND-C-TYPE would return.

   Currently this just quotes SPEC and calls EXPAND-C-TYPE at runtime.  Maybe
   later it will do something more clever."
  `(expand-c-type ',spec))

;; S-expression machinery.  Qualifiers have hairy syntax and need to be
;; implemented by hand.

(defun qualifier (qual &rest args)
  "Parse a qualified C type.

   The ARGS consist of a number of qualifiers and exactly one C-type
   S-expression.  The result is a qualified version of this type, with the
   given qualifiers attached."
  (if (null args)
      qual
      (let* ((things (mapcar #'expand-c-type args))
	     (quals (delete-duplicates
		     (sort (cons qual (remove-if-not #'keywordp things))
			   #'string<)))
	     (types (remove-if-not (lambda (thing) (typep thing 'c-type))
				   things)))
	(when (or (null types)
		  (not (null (cdr types))))
	  (error "Only one proper type expected in ~S." args))
	(qualify-type (car types) quals))))
(setf (get 'qualifier 'c-type) #'qualifier)

(defun declare-qualifier (qual)
  "Defines QUAL as being a type qualifier.

   When used as a C-type operator, it applies that qualifier to the type that
   is its argument."
  (let ((kw (intern (string qual) :keyword)))
    (setf (get qual 'c-type)
	  (lambda (&rest args)
	    (apply #'qualifier kw args)))))

;; Define some initial qualifiers.
(dolist (qual '(const volatile restrict))
  (declare-qualifier qual))


(define-c-type-syntax simple-c-type (name)
  "Constructs a simple C type called NAME (a string or symbol)."
  (make-simple-type (c-name-case name)))

(defmethod print-c-type :around
    (stream (type qualifiable-c-type) &optional colon atsign)
  (if (c-type-qualifiers type)
      (pprint-logical-block (stream nil :prefix "(" :suffix ")")
	(format stream "QUALIFIER~{ ~:_~:I~A~} ~:_"
		(c-type-qualifiers type))
	(call-next-method stream type colon atsign))
      (call-next-method)))
;; S-expression syntax.


(define-c-type-syntax enum (tag)
  "Construct an enumeration type named TAG."
  (make-instance 'c-enum-type :tag (c-name-case tag)))
(define-c-type-syntax struct (tag)
  "Construct a structure type named TAG."
  (make-instance 'c-struct-type :tag (c-name-case tag)))
(define-c-type-syntax union (tag)
  "Construct a union type named TAG."
  (make-instance 'c-union-type :tag (c-name-case tag)))

(defgeneric make-me-argument (message class)
  (:documentation
   "Return an ARGUMENT object for the `me' argument to MESSAGE, as
   specialized to CLASS."))

(defmethod make-me-argument
    ((message basic-message) (class sod-class))
  (make-argument "me" (make-instance 'c-pointer-type
				     :subtype (sod-class-type class))))