;;; -*-lisp-*-
;;;
;;; Protocol for C type representation
;;;
;;; (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)

;;;--------------------------------------------------------------------------
;;; Root classes and common access protocol.

;; It seems more useful to put the root class here, so that we can provide
;; methods specialized on it, e.g., PRINT-OBJECT.

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

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

(export 'canonify-qualifiers)
(defun canonify-qualifiers (qualifiers)
  "Return a canonical list of qualifiers."
  (delete-duplicates (sort (copy-list qualifiers) #'string<)))

(export 'qualify-c-type)
(defgeneric qualify-c-type (type qualifiers)
  (:documentation
   "Return a type like TYPE but with the specified QUALIFIERS.

   The qualifiers of the returned type are the union of the requested
   QUALIFIERS and the qualifiers already applied to TYPE."))

(export 'c-qualifier-keyword)
(defgeneric c-qualifier-keyword (qualifier)
  (:documentation "Return the C keyword for the QUALIFIER (a Lisp keyword).")
  (:method ((qualifier symbol)) (string-downcase qualifier)))

(export 'c-type-qualifier-keywords)
(defun c-type-qualifier-keywords (c-type)
  "Return the type's qualifiers, as a list of C keyword names."
  (mapcar #'c-qualifier-keyword (c-type-qualifiers c-type)))

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

;;;--------------------------------------------------------------------------
;;; Comparison protocol.

(export 'c-type-equal-p)
(defgeneric c-type-equal-p (type-a type-b)
  (:method-combination and)
  (:documentation
   "Answers whether two types TYPE-A and TYPE-B are structurally equal.

   Here, `structurally equal' means that they have the same qualifiers,
   similarly spelt names, and structurally equal components.")
  (:method and (type-a type-b)
    (eql (class-of type-a) (class-of type-b))))

(defmethod c-type-equal-p and ((type-a qualifiable-c-type)
			       (type-b qualifiable-c-type))
  (equal (canonify-qualifiers (c-type-qualifiers type-a))
	 (canonify-qualifiers (c-type-qualifiers type-b))))

;;;--------------------------------------------------------------------------
;;; C syntax output protocol.

(export 'pprint-c-type)
(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
      (null (pprint-c-type type stream
			   (lambda (stream prio spacep)
			     (declare (ignore stream prio spacep))
			     nil)))
      ((or function symbol) (call-next-method))
      (t (pprint-c-type type stream
			(lambda (stream prio spacep)
			  (declare (ignore prio))
			  (when spacep
			    (c-type-space stream))
			  (princ kernel stream)))))))

(export 'c-type-space)
(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."
  (multiple-value-bind (prefix suffix)
      (if condition (values "(" ")") (values "" ""))
    (pprint-logical-block (stream nil :prefix prefix :suffix suffix)
      (funcall thunk stream))))

(export 'maybe-in-parens)
(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)))

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

;;;--------------------------------------------------------------------------
;;; S-expression notation protocol.

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

   This function is suitable for use in `format's ~/.../ command."))

(export '(expand-c-type-spec expand-c-type-form))
(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))))

(export 'c-type)
(defmacro c-type (spec)
  "Expands to code to construct a C type, using `expand-c-type-spec'."
  (expand-c-type-spec spec))

(export 'define-c-type-syntax)
(defmacro define-c-type-syntax (name bvl &body 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-spec' sees a list (NAME . STUFF), it will call
   this function with the argument list STUFF."
  (with-gensyms (head tail)
    (multiple-value-bind (doc decls body) (parse-body body)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (defmethod expand-c-type-form ((,head (eql ',name)) ,tail)
	   ,@doc
	   (destructuring-bind ,bvl ,tail
	     ,@decls
	     (block ,name ,@body)))
	 ',name))))

(export 'c-type-alias)
(defmacro c-type-alias (original &rest aliases)
  "Make ALIASES behave the same way as the ORIGINAL type."
  (with-gensyms (head tail)
    `(eval-when (:compile-toplevel :load-toplevel :execute)
       ,@(mapcar (lambda (alias)
		   `(defmethod expand-c-type-form
			((,head (eql ',alias)) ,tail)
		      (expand-c-type-form ',original ,tail)))
		 aliases)
       ',aliases)))

(export 'defctype)
(defmacro defctype (names value &key export)
  "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-spec'.
   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
       ,@(and export
	      `((export '(,typevar ,@names))))
       (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))
       'names)))

(export 'c-name-case)
(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)))

;;;--------------------------------------------------------------------------
;;; Storage specifier protocol.

(export 'pprint-c-storage-specifier)
(defgeneric pprint-c-storage-specifier (spec stream)
  (:documentation "Print the storage specifier SPEC to STREAM, as C syntax.")
  (:method ((spec symbol) stream) (princ (string-downcase spec) stream)))

(export 'print-c-storage-specifier)
(defgeneric print-c-storage-specifier (stream spec &optional colon atsign)
  (:documentation
   "Print the storage specifier SPEC to STREAM, as an S-expression.

   This function is suitable for use in `format's ~/.../ command.")
  (:method (stream (spec t) &optional colon atsign)
    (declare (ignore colon atsign))
    (prin1 spec stream))
  (:method (stream (spec symbol) &optional colon atsign)
    (declare (ignore colon atsign))
    (princ (string-downcase spec) stream)))

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

(export 'define-c-storage-specifier-syntax)
(defmacro define-c-storage-specifier-syntax (name bvl &body body)
  "Define a C storage-specifier syntax function.

   A function defined by BODY and with lambda-list BVL is associated wth the
   NAME.  When `expand-c-storage-specifier' sees a list (NAME . STUFF), it
   will call this function with the argument list STUFF."
  (with-gensyms (head tail)
    (multiple-value-bind (doc decls body) (parse-body body)
      `(eval-when (:compile-toplevel :load-toplevel :execute)
	 (defmethod expand-c-storage-specifier-form
	     ((,head (eql ',name)) ,tail)
	   ,@doc
	   (destructuring-bind ,bvl ,tail
	     ,@decls
	     (block ,name ,@body)))
	 ',name))))

;;;--------------------------------------------------------------------------
;;; A type for carrying storage specifiers.

(export '(c-storage-specifiers-type c-type-specifiers))
(defclass c-storage-specifiers-type (c-type)
  ((specifiers :initarg :specifiers :type list :reader c-type-specifiers)
   (subtype :initarg :subtype :type c-type :reader c-type-subtype))
  (:documentation
   "A type for carrying storage specifiers.

   Properly, storage specifiers should only appear on an outermost type.
   This fake C type is a handy marker for the presence of storage specifiers,
   so that they can be hoisted properly when constructing derived types."))

(export 'wrap-c-type)
(defun wrap-c-type (wrapper-func base-type)
  "Handle storage specifiers correctly when making a derived type.

   WRAPPER-FUNC should be a function which will return some derived type of
   BASE-TYPE.  This function differs from `funcall' only when BASE-TYPE is
   actually a `c-storage-specifiers-type', in which case it invokes
   WRAPPER-FUNC on the underlying type, and re-attaches the storage
   specifiers to the derived type."
  (if (typep base-type 'c-storage-specifiers-type)
      (let* ((unwrapped-type (c-type-subtype base-type))
	     (wrapped-type (funcall wrapper-func unwrapped-type))
	     (specifiers (c-type-specifiers base-type)))
	(make-or-intern-c-type 'c-storage-specifiers-type unwrapped-type
			       :specifiers specifiers
			       :subtype wrapped-type))
      (funcall wrapper-func base-type)))

;;;--------------------------------------------------------------------------
;;; Function arguments.

(export '(argument argumentp make-argument
	  argument-name argument-type argument-default))
(defstruct (argument (:constructor make-argument (name type &optional default
						  &aux (%type type)))
		     (:predicate argumentp))
  "Simple structure representing a function argument."
  (name nil :type t :read-only t)
  (%type nil :type c-type :read-only t)
  (default nil :type t :read-only t))
(define-access-wrapper argument-type argument-%type :read-only t)

(export 'commentify-argument-name)
(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)))

;;;--------------------------------------------------------------------------
;;; Printing objects.

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

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