(defpackage #:cffi-grovel
  (:use #:cl)
  (:export #:process-grovel-file #:define-pseudo-cvar #:symbolicate
	   #:make-from-pointer-function-name))
(in-package #:cffi-grovel)

(defparameter +cc+ "gcc")

(defparameter +input-suffix+ ".lisp")
(defparameter +c-output-suffix+ ".c")
(defparameter +intermediate-output-suffix+ ".cffi.lisp")

;; FIXME
;; As best I can tell clisp's ext:run-program can either create new
;; streams OR return the exit code, but not both.  Using existing
;; streams don't seem to be an option either.  For now we dump the
;; errors to the normal terminal-io, in hopes that someone can see
;; them...
#+clisp
(defun invoke (command &rest args)
  (let ((exit-code (ext:run-program command
                                    :arguments args)))
    (unless (zerop exit-code)
      (error "External process exited with code ~S.~@
                   Command was: ~S~{ ~S~}~@"
	     exit-code
	     command
	     args))))

#+ecl
(defun invoke (command &rest args)
  (let ((return-value nil))
    (unwind-protect
	 (progn
	   (setq return-value (si:run-program command args))
	   (loop while (read-char return-value nil nil)))
      (close return-value))
    t))

#+(or cmu openmcl sbcl)
(defun invoke (command &rest args)
  (let* (process
	 exit-code
	 (message (with-output-to-string (message)
		    (setq process (#+openmcl ccl:run-program
				   #+cmu extensions:run-program
				   #+sbcl sb-ext:run-program
				          command args
					  :output message
					  :error :output
					  #+sbcl :search #+sbcl t))
		    (loop for status = (multiple-value-list
					(#+openmcl ccl:external-process-status
					 #+cmu extensions:process-status 
					 #+sbcl sb-ext:process-status 
					 process))
		       until (eq :exited (car status))
		       finally (setq exit-code
				     #+openmcl (cadr status)
				     #+sbcl (sb-ext:process-exit-code process)
				     #+cmu (extensions:process-exit-code process)
				     )))))
    (unless (= exit-code 0)
      (error "External process exited with code ~S.~@
                   Command was: ~S~{ ~S~}~@
                   Output was:~%~A"

	     exit-code
	     command
	     args
	     message))))

#+allegro
(defun invoke (command &rest args)
  (let ((command-string (format nil "~A ~{~A ~}" command args)))
    (multiple-value-bind (stdout-lines stderr-lines exit-code)
        (excl.osi:command-output command-string)
      (unless (= exit-code 0)
        (error "External process exited with code ~S.~%
                     Command was: ~A~%
                     Output was:~%~{~T~A~%}
                     Error Output was:~%~{~T~A~%~}"
               exit-code
               command-string
               stdout-lines
               stderr-lines)))))

(defun name-designator-c (designator)
  (etypecase designator
    (list (nth 0 designator))
    (string designator)
    (symbol (string-downcase (symbol-name designator)))))

(defun name-designator-lisp (designator)
  (etypecase designator
    (list (nth 1 designator))
    (string (intern (string-upcase designator)))
    (symbol designator)))


(defparameter +header+"/*
 * This file has been automatically generated by cffi-grovel.
 * Do not edit it by hand.
 */
")

(defparameter +main-1+ "

#ifndef offsetof
#define offsetof(type, slot) ((int) ((char *) &(((type *) 0)->slot)))
#endif
#define sizeofslot(type, slot) (sizeof(((type *) 0)->slot))
#define stringify(x) #x
#define indirect_stringify(x) stringify(x)

void type_name(FILE *output, int base_p, int signed_p, int size);

int main(int argc, char**argv) {
  FILE *output = argc > 1 ? fopen(argv[1], \"w\") : stdout;

")

(defparameter +main-2+ "
  if(output != stdout)
    fclose(output);
  return 0;
}

void type_name(FILE *output, int base_p, int signed_p, int size) {
  if(!base_p) {
    if(signed_p) {
      switch(size) {
        case 1: fprintf(output, \":int8\"); break;
        case 2: fprintf(output, \":int16\"); break;
        case 4: fprintf(output, \":int32\"); break;
        case 8: fprintf(output, \"#-cffi-features:no-long-long :int64 #+cffi-features:no-long-long #.(progn (cerror \\\"Use :int32 instead.\\\"  \\\"This platform does not support long long types.\\\") :int32)\"); break;
        default: goto error;
      }
    } else {
      switch(size) {
        case 1: fprintf(output, \":uint8\"); break;
        case 2: fprintf(output, \":uint16\"); break;
        case 4: fprintf(output, \":uint32\"); break;
        case 8: fprintf(output, \"#-cffi-features:no-long-long :uint64 #+cffi-features:no-long-long #.(progn (cerror \\\"Use :uint32 instead.\\\" \\\"This platform does not support long long types.\\\") :uint32)\"); break;
        default: goto error;
      }
    }
  } else {
    fprintf(output, \":\");
    if(!signed_p)
      fprintf(output, \"unsigned-\");

    if(sizeof(char) == size) fprintf(output, \"char\");
    else if(sizeof(short) == size) fprintf(output, \"short\");
    else if(sizeof(long) == size) fprintf(output, \"long\");
    else if(sizeof(long long) == size) fprintf(output, \"long-long\");
    else if(sizeof(int) == size) fprintf(output, \"int\");
  }

  return;
error:
  fprintf(output, \"(cl:error \\\"No type of size ~D.\\\" %i)\\n\", size);
}
")

(defun unescape-for-c (text)
  (with-output-to-string (result)
    (loop for i below (length text)
	 for char = (char text i)
	 do
	 (cond ((eql char #\")
		(princ "\\\"" result))
	       ((eql char #\newline)
		(princ "\\n" result))
	       (t
		(princ char result))))))

(defun c-format (out fmt &rest args)
  (let ((text (unescape-for-c
	       (apply #'format nil fmt args))))
    (format out "~&  fprintf(output, \"~A\");~%" text)))

(defun c-printf (out fmt &rest args)
  (flet ((item (item)
	   (format out "~A" (unescape-for-c (format nil item)))))
    (format out "~&  fprintf(output, \"")
    (item fmt)
    (format out "\"")
    (loop for arg in args do
	 (format out ", ")
	 (item arg))
    (format out ");~%")))

(defun c-write (out form &key recursive)
  (cond
    ((and (listp form)
	  (eq 'quote (car form)))
     (c-format out "'")
     (c-write out (cadr form)
	      :recursive t))
    ((listp form)
     (c-format out "(")
     (loop
	for subform in form
	for first-p = t then nil
	unless first-p do (c-format out " ")
	do (c-write out subform
		    :recursive t))
     (c-format out ")"))
    ((symbolp form)
     (c-print-symbol out form)))
  (unless recursive
    (c-format out "~%")))


(defun c-print-symbol (out symbol &optional no-package)
  (let* ((package-name (package-name (symbol-package symbol)))
	 (format-control (cond ((string= "KEYWORD" package-name)
				":~(~A~)")
			       (no-package
				"~(~A~)")
			       ((string= "COMMON-LISP" package-name)
				"cl:~(~A~)")
			       ((string= "CFFI" package-name)
				"cffi:~(~A~)")
			       (t
				"~(~A~)"))))
    (c-format out format-control symbol)))

(defun c-export (out symbol)
  (unless (string= "KEYWORD" (package-name (symbol-package symbol)))
    (c-format out "(cl:export '")
    (c-print-symbol out symbol t)
    (c-format out ")~%")))

(defun c-section-header (out section-type section-symbol)
  (format out "~%/***** ~A section for ~S *****/~%"
	  section-type
	  section-symbol))

(defvar +standard-items+
    '((include "stdio.h" "stdlib.h")
      (base-type :uint8 :unsigned 1)
      (base-type :uint16 :unsigned 2)
      (base-type :uint32 :unsigned 4)
      #-cffi-features:no-long-long
      (base-type :uint64 :unsigned 8)
      (base-type :int8 :signed 1)
      (base-type :int16 :signed 2)
      (base-type :int32 :signed 4)
      #-cffi-features:no-long-long
      (base-type :int64 :signed 8)))

(defun remove-suffix (string suffix)
  (let ((suffix-start (- (length string)
			 (length suffix))))
    (if (and (> suffix-start 0)
	     (string= string suffix
		      :start1 suffix-start))
	(subseq string 0 suffix-start)
	string)))

(defun add-suffix (string suffix)
  (concatenate 'string string suffix))

(defun make-executable-path (path)
  (cond ((eql #\/ (char path 0))
	 path)
	(t
	 (concatenate 'string "./" path))))

(defun process-grovel-file (base-name)
  (setq base-name (remove-suffix base-name +input-suffix+))
  (let ((input-name (add-suffix base-name +input-suffix+))
	(c-output-name (add-suffix base-name +c-output-suffix+))
	(executable-name (make-executable-path base-name))
	(intermediate-output-name (add-suffix base-name
					      +intermediate-output-suffix+))
	(*cc-flags* nil))
    (declare (special *cc-flags*))
    (with-open-file (in input-name :direction :input)
      (with-open-file (out c-output-name :direction :output
			   :if-exists :supersede)
	(let* ((items (loop for item = (read in nil nil)
			 while item collect item))
	       (header-items (remove-if-not #'header-item-p items))
	       (body-items (remove-if #'header-item-p items))
	       (standard-header-items (remove-if-not #'header-item-p
						     +standard-items+))
	       (standard-body-items (remove-if #'header-item-p
					       +standard-items+)))
	  (princ +header+ out)
	  (loop for item in header-items do (process-item out item))
	  (loop for item in standard-header-items do (process-item out item))
	  (princ +main-1+ out)
	  (loop for item in standard-body-items do (process-item out item))
	  (loop for item in body-items do (process-item out item))
	  (princ +main-2+ out)))
      (apply #'invoke +cc+ "-o" executable-name c-output-name *cc-flags*)
      (invoke executable-name intermediate-output-name))))

(defun item-kind (item)
  (intern (symbol-name (car item))
	  (find-package #.(package-name *package*))))

(defun header-item-p (item)
  (member (item-kind item)
	  '(include define flag)))

(defun process-item (out item)
  (let ((item-kind (item-kind item))
	(item-parameters (cdr item)))
    (funcall (ecase item-kind
	       (include #'process-include-item)
	       (define #'process-define-item)
	       (flag #'process-flag-item)
	       (in-package #'process-in-package-item)
	       (ctype #'process-ctype-item)
	       (base-type #'process-base-type-item)
	       (constant #'process-constant-item)
	       (cunion #'process-cunion-item)
	       (cstruct #'process-cstruct-item)
	       (cstruct-and-class #'process-cstruct-and-class-item)
               (cvar #'process-cvar-item)
               (cenum #'process-cenum-item)
	       (constantenum #'process-constantenum-item))
	     out
	     item-parameters)))

(defun process-include-item (out item)
  (destructuring-bind (&rest inclusions) item
      (dolist (inclusion inclusions)
	(format out "#include <~A>~%" inclusion))))

(defun process-define-item (out item)
  (destructuring-bind (name &optional value) item
    (format out "#define ~A" name)
    (when value
      (format out " ~A~%" value))
    (terpri out)))

(defun process-flag-item (out item)
  (declare (special *cc-flags*))
  (declare (ignore out))
  (destructuring-bind (flag-string)
      item
    (setq *cc-flags*
	  (nconc *cc-flags* (list flag-string)))))

(defun process-in-package-item (out item)
  (destructuring-bind (name)
      item
    (c-format out "(cl:in-package ~S)~%" name)))

(defun process-ctype-item (out item)
  (process-type-item out item nil))

(defun process-base-type-item (out item)
  (process-type-item out item t))

(defun process-type-item (out item base-p)
  (destructuring-bind (lisp-name signedness size-designator)
      item
    (let ((signed-p (ecase signedness
		      (:unsigned nil)
		      (:signed t))))
      (c-section-header out "ctype" lisp-name)
      (c-export out lisp-name)
      (c-format out "(cffi:defctype ")
      (c-print-symbol out lisp-name t)
      (c-format out " ")
      (format out "~&  type_name(output, ~:[0~;1~], ~:[0~;1~], ~
                                 ~:[sizeof(~A)~;~D~]);~%"
	      base-p
	      signed-p
	      (etypecase size-designator
		(string nil)
		(integer t))
	      size-designator)
      (c-format out ")~%"))))

;; FIXME syntax differs from anything in cffi
(defun process-constant-item (out item)
  (destructuring-bind ((lisp-name &rest c-names) &key documentation optional)
      item
    (c-section-header out "constant" lisp-name)
    (loop for c-name in c-names do
	 (format out "~&#ifdef ~A~%" c-name)
	 (c-export out lisp-name)
	 (c-format out "(cl:defconstant ")
	 (c-print-symbol out lisp-name t)
	 (c-format out " ")
	 (c-printf out "%i" c-name)
	 (when documentation
	   (c-format out " ~S" documentation))
	 (c-format out ")~%")
	 (format out "~&#else~%"))
    (unless optional
      (c-format out "(cl:warn \"No definition for ~A.\")~%" lisp-name))
    (dotimes (i (length c-names))
      (format out "~&#endif~%"))))

(defun process-cunion-item (out item)
  (destructuring-bind (union-lisp-name union-c-name &rest slots)
      item
    (let ((documentation (when (stringp (car slots))
			   (pop slots))))
      (setq union-c-name (concatenate 'string "union " union-c-name))
      (c-section-header out "cunion" union-lisp-name)
      (c-export out union-lisp-name)
      (dolist (slot slots)
	(let ((slot-lisp-name (car slot)))
	  (c-export out slot-lisp-name)))
      (c-format out "(cffi:defcunion (")
      (c-print-symbol out union-lisp-name t)
      (c-printf out " :size %i)"
                (format nil "sizeof(~A)" union-c-name))
      (when documentation
	(c-format out "~%  ~S" documentation))
      (dolist (slot slots)
	(destructuring-bind (slot-lisp-name slot-c-name
					    &key
					    type
					    (signed t)
					    count)
	    slot
	  (c-format out "~%  (")
	  (c-print-symbol out slot-lisp-name t)
	  (c-format out " ")
	  (if type
	      (c-print-symbol out type)
	      (format out "  type_name(output, 0, ~:[0~;1~], ~
                                sizeofslot(~A, ~A));~%"
		      signed
		      union-c-name
		      slot-c-name))
	  (when count
	    (cond ((integerp count)
		   (c-format out " :count ~D" count))
		  ((eq count :auto)
                   ;; nb, works like :count :auto does in cstruct below
		   (c-printf out " :count %i"
			     (format nil "sizeof(~A)"
				     union-c-name)))))
          (c-format out ")")))
      (c-format out ")~%"))))

(defun process-cstruct-and-class-item (out item)
  (process-cstruct-item out item)
  (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
      item
    (declare (ignore struct-c-name))
    (let* ((slot-names (mapcar #'car slots))
	   (reader-names (mapcar
			  (lambda (slot-name)
			    (intern
			     (concatenate 'string
					  (symbol-name struct-lisp-name)
					  "-"
					  (symbol-name slot-name))))
			  slot-names))
	   (initarg-names (mapcar
			   (lambda (slot-name)
			     (intern (symbol-name slot-name)
				     "KEYWORD"))
			   slot-names))
	   (slot-decoders (mapcar (lambda (slot)
				    (destructuring-bind
					  (lisp-name c-name
						     &key type count
						     &allow-other-keys)
					slot
				      (declare (ignore lisp-name c-name))
				      (cond ((and (eq type :char)
						  count)
					     'cffi:foreign-string-to-lisp)
					    (t
					     nil))))
				  slots))
	   (defclass-form
	    `(defclass ,struct-lisp-name ()
	       ,(mapcar (lambda (slot-name initarg-name reader-name)
			  `(,slot-name :initarg ,initarg-name
				       :reader ,reader-name))
			slot-names
			initarg-names
			reader-names)))
	   (make-function-name
	    (make-from-pointer-function-name struct-lisp-name))
	   (make-defun-form
	    `(defun ,make-function-name (pointer)
	       (cffi:with-foreign-slots
		   (,slot-names pointer ,struct-lisp-name)
		 (make-instance ',struct-lisp-name
				,@(loop
				     for slot-name in slot-names
				     for initarg-name in initarg-names
				     for slot-decoder in slot-decoders
				     collect initarg-name
				     if slot-decoder
				     collect `(,slot-decoder ,slot-name)
				     else
				     collect slot-name))))))
      (c-export out make-function-name)
      (dolist (reader-name reader-names)
	(c-export out reader-name))
      (c-write out defclass-form)
      (c-write out make-defun-form))))

(defun make-from-pointer-function-name (type-name)
  (intern
   (concatenate 'string
		"MAKE-"
		(symbol-name type-name)
		"-FROM-POINTER")))

(defun process-cstruct-item (out item)
  (destructuring-bind (struct-lisp-name struct-c-name &rest slots)
      item
    (let ((documentation (when (stringp (car slots))
			   (pop slots))))
      (c-section-header out "cstruct" struct-lisp-name)
      (c-export out struct-lisp-name)
      (dolist (slot slots)
	(let ((slot-lisp-name (car slot)))
	  (c-export out slot-lisp-name)))
      (c-format out "(cffi:defcstruct (")
      (c-print-symbol out struct-lisp-name t)
      (c-printf out " :size %i)"
		(format nil "sizeof(~A)" struct-c-name))
      (when documentation
	(c-format out "~%  ~S" documentation))
      (dolist (slot slots)
	(destructuring-bind (slot-lisp-name slot-c-name
					    &key
					    type
					    (signed t)
					    count)
	    slot
	  (c-format out "~%  (")
	  (c-print-symbol out slot-lisp-name t)
	  (c-format out " ")
	  (if type
	      (c-print-symbol out type)
	      (format out "  type_name(output, 0, ~:[0~;1~], ~
                                sizeofslot(~A, ~A));~%"
		      signed
		      struct-c-name
		      slot-c-name))
	  (when count
	    (cond ((integerp count)
		   (c-format out " :count ~D" count))
		  ((eq count :auto)
		   (c-printf out " :count %i"
			     (format nil "sizeof(~A) - offsetof(~A, ~A)"
				     struct-c-name
				     struct-c-name
				     slot-c-name)))))
	  (c-printf out " :offset %i)"
		    (format nil "offsetof(~A, ~A)"
			    struct-c-name
			    slot-c-name))))
      (c-format out ")~%"))))

;;; FIXME cffi-utils has this same function, defined differently
(defun symbolicate (&rest pieces)
  (intern
   (apply #'concatenate 'string 
            (loop for thing in pieces
               collect (if (symbolp thing)
                           (symbol-name thing)
                           thing)))
   *package*))

(defmacro define-pseudo-cvar (str name type &key read-only)
  (let ((c-parse (let ((*read-eval* nil)
                       (*readtable* (copy-readtable nil)))
                   (setf (readtable-case *readtable*) :preserve)
                   (read-from-string str))))
    (typecase c-parse
      (symbol `(cffi:defcvar (,(symbol-name c-parse) ,name) ,type
                 :read-only ,read-only))
      (list (unless (and (= (length c-parse) 2)
                         (null (second c-parse))
                         (symbolp (first c-parse))
                         (eql #\* (char (symbol-name (first c-parse)) 0)))
              (error "Unable to parse c-string ~s." str))
            (let ((func-name (symbolicate "%" name '#:-accessor)))
              `(progn
                 (declaim (inline ,func-name))
                 (cffi:defcfun (,(string-trim "*"
                                              (symbol-name (first c-parse)))
                                 ,func-name) :pointer)
                 (define-symbol-macro ,name
		     (cffi:mem-ref (,func-name) ',type)))))
      (t (error "Unable to parse c-string ~s." str)))))

;; FIXME using unexported cffi funcs
(defun process-cvar-item (out item)
  (destructuring-bind (name type &key read-only) item
    (let ((lisp-name (cffi::lisp-var-name name))
          (c-name (cffi::foreign-var-name name)))
      (c-section-header out "cvar" lisp-name)
      (c-export out lisp-name)
      (c-printf out "(cffi-grovel:define-pseudo-cvar \"%s\" "
                (format nil "indirect_stringify(~a)" c-name))
      (c-print-symbol out lisp-name t)
      (c-format out " ")
      (c-print-symbol out type)
      (when read-only 
        (c-format out " :read-only t"))
      (c-format out ")~%"))))

;; FIXME where would docs on enum elements go?
(defun process-cenum-item (out item)
  (destructuring-bind (name &body enum-list) item
    (c-section-header out "cenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum~%")
    (c-print-symbol out name t)
    (loop for enum in enum-list do
         (destructuring-bind ((lisp-name &rest c-names) &key documentation) enum
           (declare (ignore documentation))
           (check-type lisp-name keyword)
           (loop for c-name in c-names do
                (check-type c-name string)
                (c-format out "  (")
                (c-print-symbol out lisp-name)
                (c-format out " ")
                (c-printf out "%i" c-name)
                (c-format out ")~%"))))
    (c-format out ")~%")))

(defun process-constantenum-item (out item)
  (destructuring-bind (name &body enum-list) item
    (c-section-header out "cenum" name)
    (c-export out name)
    (c-format out "(cffi:defcenum~%")
    (c-print-symbol out name t)
    (loop for enum in enum-list do
         (destructuring-bind ((lisp-name &rest c-names)
                              &key optional documentation) enum
           (declare (ignore documentation))
           (check-type lisp-name keyword)
           (loop for c-name in c-names do
                (check-type c-name string)
                (format out "~&#ifdef ~A~%" c-name)
                (c-format out "  (")
                (c-print-symbol out lisp-name)
                (c-format out " ")
                (c-printf out "%i" c-name)
                (c-format out ")~%")
                (format out "~&#else~%"))
           (unless optional
             (c-format out "(cl:warn \"No definition for ~A.\")~%" lisp-name))
           (dotimes (i (length c-names))
             (format out "~&#endif~%"))))
    (c-format out ")~%")))

#+asdf
(progn
  (import 'cffi-grovel-file "ASDF")
  (export 'cffi-grovel-file "ASDF")

  (defclass cffi-grovel-file (asdf:cl-source-file)
    ())

  (defmethod asdf:perform ((op asdf:compile-op)
			   (component cffi-grovel-file))
    (let* ((input-name (namestring
			(asdf:component-pathname component)))
	   (base-name (remove-suffix input-name +input-suffix+))
	   (intermediate-output-name (concatenate 'string
						  base-name
						  ".cffi.lisp"))
	   (final-output-name (namestring
			       (car (asdf:output-files op component)))))
      (process-grovel-file base-name)
      (compile-file intermediate-output-name :output-file final-output-name)))

  (defmethod asdf:perform ((op asdf:load-source-op)
                           (component cffi-grovel-file))
    (let* ((input-name (namestring
                        (asdf:component-pathname component)))
           (base-name (remove-suffix input-name +input-suffix+))
           (intermediate-output-name
	    (concatenate 'string
			 base-name
			 +intermediate-output-suffix+)))
      (process-grovel-file base-name)
      (load intermediate-output-name))))