;;; AH2CL (Another Header to Common Lisp converter)
;;;
;;; Copyright (C) 2004 Philippe Brochard (hocwp@free.fr)
;;;
;;; #date#: Fri Apr 29 22:20:34 2005
;;;
;;; The authors grant you the rights to distribute
;;; and use this software as governed by the terms
;;; of the Lisp Lesser GNU Public License
;;; (http://opensource.franz.com/preamble.html),
;;; known as the LLGPL.
;;;
;;; AH2Cl is a (very (very)) simple C header parser.
;;; It produce (at the moment) ffi (foreign function interface) for clisp and for uffi
;;; (but callbacks works only with clisp and cmucl).
;;; 
;;; Usage: (parse-file "file.h") or (parse-stream header-stream)
;;;
;;;   parse-stream and parse-file accept the following keywords:
;;;
;;;   in (needed by parse-stream): the stream to parse.
;;;   file-in (needed by parse-file): the .h file to parse.
;;;   out (parse-stream): the stream where to produce results.
;;;   file-out (parse-file): the file where to produce results.
;;;   ignored-keyword: a list of atoms or lists. Ignore all atoms
;;;            or replace all (first lists) with (second lists).
;;;   ignore-lines: a list of atoms. Ignore all lines with atoms.
;;;   library: the library where is the C code.
;;;   language: the language to use (nil, :c or :stdc...).
;;;   write-comment: write comment in the result stream.
;;;   write-ignored: write ignored lines in the result stream.
;;;   write-original: write the original lines from parser.
;;;   package-name: the package name to use.
;;;   package-definition-type: :new : create a new package
;;;                            :append : extend an existing package
;;;                            nil : produce no package.
;;;   backend: write specific ffi: :clisp, :uffi or :both
;;;
;;; Example:
;;;
;;; (ah2cl:parse-file "test.h" :library "test.so" :language :stdc :ignored-keyword '("extern"))
;;;
;;;
;;;
;;; Thanks to:
;;;   Dave Watson for the multiple functions per type declaration patch
;;;   Aneil Mallavarapu for its struct bug fix.



(in-package :common-lisp-user)

(defpackage :ah2cl
  (:use :common-lisp)
  (:export :parse-stream
	   :parse-file
	   :write-package-definition))

(in-package :ah2cl)


;;; Global local variables.
(defparameter *ignored-keyword* ())
(defparameter *ignore-lines* ())
(defparameter *library* ())
(defparameter *language* ())
(defparameter *write-comment* t)
(defparameter *write-ignored* t)
(defparameter *write-original* ())

(defparameter *exported-symbol* ())

(defparameter *backend* :clisp)
(defparameter *clisp-delimiter* "")
(defparameter *uffi-delimiter* "")


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                           ;;;
;;;  Implementation specific stuff                            ;;;
;;;                                                           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun write-clisp-delimiter (out)
  (format out "~A~%" *clisp-delimiter*))

(defun write-uffi-delimiter (out)
  (format out "~A~%" *uffi-delimiter*))

(defun implementation-write-original (out type original)
  (when *write-original*
    (format out ";;; ~A: ~A~%" type original)))


(defun implementation-write-define (out name value)
  (push name *exported-symbol*)
  (format out "(defconstant ~A ~A)~%" name value))



(defun implementation-write-comment (out comment)
  (format out ";; ~A~%" comment))

(defun implementation-write-ignored (out ignored)
  (when *write-ignored*
    (format out ";; **IGNORED**: ~A~%" ignored)))



(defun implementation-write-enum (out name elements)
  (let ((name (if name name (format nil "enum_~A_t" (gensym)))))
    (push name *exported-symbol*)
    (labels ((clisp-enum ()
			 (format out "(ffi:def-c-enum ~A" name)
			 (dolist (el elements)
			   (push (first el) *exported-symbol*)
			   (if (second el)
			       (format out "~%                (~A ~A)"
				       (first el) (second el))
			     (format out "~%                ~A" (first el))))
			 (format out ")~%~%"))
	     (uffi-enum ()
			(format out "(progn
  (uffi:def-enum ~A~%                 (" name)
			(dolist (el elements)
			  (push (first el) *exported-symbol*)
			  (if (second el)
			      (format out "(:~A ~A) "
				      (first el) (second el))
			    (format out ":~A " (first el))))
			(format out "))~%")
			(dolist (el elements)
			  (format out "  (defconstant ~A ~A#~A)"
				  (first el) name (first el))
			  (if (eql el (car (last elements)))
			      (format out ")~%~%")
			    (format out "~%")))))
      (case *backend*
	(:clisp (clisp-enum))
	(:uffi (uffi-enum))
	(:both (write-clisp-delimiter out) (clisp-enum)
	       (write-uffi-delimiter out) (uffi-enum))))))




(defun implementation-write-union (out name elements)
  (push name *exported-symbol*)
  (labels ((clisp-union ()
			(format out "(ffi:def-c-type ~A (ffi:c-union" name)
			(dolist (x elements)
			  (format out " (~A ~A)" (first x) (type->clisp (second x))))
			(format out "))~%~%"))
	   (uffi-union ()
		       (format out "(uffi:def-union ~A" name)
		       (dolist (x elements)
			 (format out " (~A ~A)" (first x) (type->uffi (second x))))
		       (format out ")~%~%")))
    (case *backend*
      (:clisp (clisp-union))
      (:uffi (uffi-union))
      (:both (write-clisp-delimiter out) (clisp-union)
	     (write-uffi-delimiter out) (uffi-union)))))



(defun implementation-write-typedef (out name type)
  (push name *exported-symbol*)
  (labels ((clisp-typedef ()
			  (format out "(ffi:def-c-type ~A ~A)~%~%"
				  name (type->clisp type)))
	   (uffi-typedef ()
			 (format out "(uffi:def-foreign-type ~A ~A)~%~%"
				 name
				 (if (string= (type->uffi type) ":void")
				     ":char"
				   (type->uffi type)))))
    (case *backend*
      (:clisp (clisp-typedef))
      (:uffi (uffi-typedef))
      (:both (write-clisp-delimiter out) (clisp-typedef)
	     (write-uffi-delimiter out) (uffi-typedef)))))


(defun implementation-write-struct (out name elements)
  (push name *exported-symbol*)
  (push (format nil "make-~A" name) *exported-symbol*)
  (labels ((clisp-struct ()
			 (format out "(ffi:def-c-struct (~A :typedef)" name)
			 (dolist (el elements)
			   (push (format nil "~A-~A" name (first el)) *exported-symbol*)
			   (format out "~%                  (~A ~A)"
				   (first el) (type->clisp (second el))))
			 (format out ")~%~%"))
	   (uffi-struct ()
			(format out "(progn
 (uffi:def-struct ~A" name)
			(dolist (el elements)
			  (push (format nil "~A-~A" name (first el)) *exported-symbol*)
			  (format out "~%                  (~A ~A)"
				  (first el) (type->uffi (second el))))
			(format out ")~%")
			(dolist (el elements)
			  (format out " (defmacro ~A-~A (s)
   `(uffi:get-slot-value ,s '~A '~A))~%" name (first el) name (first el)))
			(format out " (defun make-~A (&key" name)
			(dolist (el elements)
			  (format out " ~A" (first el)))
			(format out ")
   (let ((s (uffi:allocate-foreign-object '~A)))~%" name)
			(dolist (el elements)
			  (format out "     (setf (~A-~A s) ~A)~%" name (first el) (first el)))
			(format out "     s)))~%~%")))
    (case *backend*
      (:clisp (clisp-struct))
      (:uffi (uffi-struct))
      (:both (write-clisp-delimiter out) (clisp-struct)
	     (write-uffi-delimiter out) (uffi-struct)))))



(defun implementation-write-function (out name return-type arguments)
  (push name *exported-symbol*)
  (labels ((clisp-function ()
			   (format out "(ffi:def-call-out ~A
                  (:name ~S)
                  (:return-type ~A)~%" name name (type->clisp return-type))
			   (format out "                  (:arguments")
			   (dolist (el arguments)
			     (format out " (~A ~A)"
				     (first el) (type->clisp (second el))))
			   (format out ")")
			   (when *language*
			     (format out "~%                  (:language ~S)" *language*))
			   (when *library*
			     (format out "~%                  (:library ~S)" *library*))
			   (format out ")~%~%"))
	   (uffi-function ()
			  (format out "(uffi:def-function (~S ~A)~%" name name)
			  (format out "                   (")
			  (dolist (el arguments)
			    (format out " (~A ~A)"
				    (if (string-equal (first el) "t") "tp" (first el))
				    (type->uffi (second el))))
			  (format out ")~%")
			  (format out "                   :returning ~A" (type->uffi return-type))
			  (when *library*
			    (format out "~%                   :module ~S" *library*))
			  (format out ")~%~%")))
    (case *backend*
      (:clisp (clisp-function))
      (:uffi (uffi-function))
      (:both (write-clisp-delimiter out) (clisp-function)
	     (write-uffi-delimiter out) (uffi-function)))))




(defun implementation-write-var (out name type)
  (push name *exported-symbol*)
  (labels ((clisp-var ()
		      (format out "(ffi:def-c-var ~A
               (:name ~S)
               (:type ~A)"
			      name name (type->clisp type))
		      (when *library*
			(format out "~%               (:library ~S)" *library*))
		      (format out ")~%~%"))
	   (uffi-var ()
		     (format out "(uffi:def-foreign-var (~S ~A) ~A" name name (type->uffi type))
		     (when *library*
		       (format out " ~S" *library*))
		     (format out ")~%~%")))
    (case *backend*
      (:clisp (clisp-var))
      (:uffi (uffi-var))
      (:both (write-clisp-delimiter out) (clisp-var)
	     (write-uffi-delimiter out) (uffi-var)))))



(defun write-package-definition (out package-name package-type)
  (setq *exported-symbol* (nreverse *exported-symbol*))
  (labels ((write-load-library ()
             (case *backend*
	       (:uffi (format out "(uffi:load-foreign-library ~S :module ~S :supporting-libraries '(\"c\"))~%~%"
			      *library* *library*))
	       (:both (write-uffi-delimiter out)
		      (format out "(uffi:load-foreign-library ~S :module ~S :supporting-libraries '(\"c\"))~%~%"
			      *library* *library*)))))
    (case package-type
      (:new
       (format out "(in-package :common-lisp-user)~%~%")
       (format out "(defpackage ~S~%  (:use :common-lisp)~%" package-name)
       (format out "  (:export ")
       (dolist (s *exported-symbol*)
	 (unless (eql s (first *exported-symbol*))
	   (format out "~%	   "))
	 (format out ":~A" s))
       (format out "))~%~%")
       (format out "(in-package ~S)~%~%" package-name)
       (write-load-library))
      (:append
       (format out "(in-package ~S)~%~%" package-name)
       (format out "(export '(")
       (dolist (s *exported-symbol*)
	 (unless (eql s (first *exported-symbol*))
	   (format out "~%          "))
	 (format out "~A" s))
       (format out "))~%~%")
       (write-load-library)))))


    







(defun type->clisp (type)
  (labels ((c-function (type args)
		       (with-output-to-string
			 (str)
			 (format str "(ffi:c-function (:return-type ~A) (:arguments" (type->clisp type))
			 (dolist (a args)
			   (format str " (~A ~A)" (first a) (type->clisp (second a))))
			 (format str ")")
			 (when *language*
			   (format str " (:language ~S)" *language*))
			 (format str ")")
			 str)))
    (cond ((consp type) (c-function (first type) (second type)))
	  ((eql #\* (aref type (1- (length type))))
	   (let ((base-type (string-right-trim "* " type)))
	     (cond ((string= "void" base-type) "ffi:c-pointer")
		   ((string= "char" base-type) "ffi:c-string")
		   (t (format nil "(ffi:c-ptr ~A)"
			      (type->clisp base-type))))))
	  ((string= "void" type) nil)
	  ((string= "int" type) "ffi:int")
	  ((string= "char" type) "ffi:character")
	  ((string= "signed char" type) "ffi:char")
	  ((string= "unsigned char" type) "ffi:uchar")
	  ((string= "short" type) "ffi:short")
	  ((string= "unsigned short" type) "ffi:ushort")
	  ((string= "unsigned int" type) "ffi:uint")
	  ((string= "signed short" type) "ffi:short")
	  ((string= "signed int" type) "ffi:int")
	  ((string= "long" type) "ffi:long")
	  ((string= "unsigned long" type) "ffi:ulong")
	  ((string= "signed long" type) "ffi:long")
	  ((string= "uint8" type) "ffi:uint8")
	  ((string= "sint8" type) "ffi:sint8")
	  ((string= "uint16" type) "ffi:uint16")
	  ((string= "sint16" type) "ffi:sint16")
	  ((string= "uint32" type) "ffi:uint32")
	  ((string= "sint32" type) "ffi:sint32")
	  ((string= "uint64" type) "ffi:uint64")
	  ((string= "sint64" type) "ffi:sint64")
	  ((string= "float" type) "ffi:single-float")
	  ((string= "double" type) "ffi:double-float")
	  ((string= "unsigned" type) "ffi:uint")
	  ((string= "signed" type) "ffi:int")
	  (t type))))


(defun type->uffi (type)
  (labels ((c-function (type args)
		       (with-output-to-string
			 (str)
			 (format str "(* (function ~A" (type->uffi type))
			 (dolist (a args)
			   (format str " ~A" (type->uffi (second a))))
			 (format str "))")
			 str)))
    (cond ((consp type) (c-function (first type) (second type)))
	  ((eql #\* (aref type (1- (length type))))
	   (let ((base-type (string-right-trim "* " type)))
	     (cond ((string= "void" base-type) ":pointer-void")
		   ((string= "char" base-type) ":cstring")
		   (t (format nil "(* ~A)"
			      (type->uffi base-type))))))
	  ((string= "void" type) ":void")
	  ((string= "int" type) ":int")
	  ((string= "char" type) ":char")
	  ((string= "signed char" type) ":char")
	  ((string= "unsigned char" type) ":unsigned-char")
	  ((string= "short" type) ":short")
	  ((string= "unsigned short" type) ":unsigned-short")
	  ((string= "unsigned int" type) ":unsigned-int")
	  ((string= "signed short" type) ":short")
	  ((string= "signed int" type) ":int")
	  ((string= "long" type) ":long")
	  ((string= "unsigned long" type) ":unsigned-long")
	  ((string= "signed long" type) ":long")
	  ((string= "uint8" type) ":unsigned-byte")
	  ((string= "sint8" type) ":byte")
	  ((string= "uint16" type) ":unsigned-short")
	  ((string= "sint16" type) ":short")
	  ((string= "uint32" type) ":unsigned-int")
	  ((string= "sint32" type) ":int")
	  ((string= "uint64" type) ":unsigned-long")
	  ((string= "sint64" type) ":long")
	  ((string= "float" type) ":float")
	  ((string= "double" type) ":double")
	  ((string= "unsigned" type) ":unsigned-int")
	  ((string= "signed" type) ":int")
	  (t type))))






;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                           ;;;
;;;  String facilities                                        ;;;
;;;                                                           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun position-ignorable (char string &key (start 0)
				(ignore-enter-char nil) (ignore-leave-char nil))
  (if ignore-enter-char
      (let ((p (position char string :start start))
	    (p-enter (position ignore-enter-char string :start start))
	    (p-leave (position ignore-leave-char string :start start)))
	(cond ((null p) nil)
	      ((null p-enter) p)
	      ((null p-leave) nil)
	      ((< p-enter p)
	       (position-ignorable char string :start (1+ p-leave)
				   :ignore-enter-char ignore-enter-char
				   :ignore-leave-char ignore-leave-char))
	      (t p)))
    (position char string :start start)))


(defun string-to-list (str &key (split-char #\space) (initial-trim nil)
			   (trim nil) (ignore-enter-char nil)
			   (ignore-leave-char nil))
  (let ((str (string-trim initial-trim str)))
    (do* ((start 0 (1+ index))
	  (index (position-ignorable split-char str :start start
				     :ignore-enter-char ignore-enter-char
				     :ignore-leave-char ignore-leave-char)
		 (position-ignorable split-char str :start start
				     :ignore-enter-char ignore-enter-char
				     :ignore-leave-char ignore-leave-char))
	  (accum nil))
	((null index)
	 (unless (string= (subseq str start) "")
	   (push (string-trim trim (subseq str start)) accum))
	 (nreverse accum))
      (when (/= start index)
	(push (string-trim trim (subseq str start index)) accum)))))




(defun list-to-string (list)
  (string-trim " ()" (format nil "~A" list)))

(defun cut-string (str &key (cut-char #\Space) (from-end nil)
		       (preserve nil) (initial-trim nil)
		       (begin-trim nil) (end-trim nil))
  "Cut a string in two string according to cut-char.
from-end: cut string from first cut-char begining from end (t)
          or not (nil).
preserve: :begin cut-char is preserved in first string,
          :end in second string.
initial-trim: remove all initial-trim char from str.
begin-trim: remove all begin-trim char in first return string.
end-trim: remove all trim-trim char in second return string."
  (let* ((str (string-trim initial-trim str))
	 (pos (position cut-char str :from-end from-end)))
    (if pos
	(let ((begin (string-trim begin-trim (subseq str 0 pos)))
	      (end (string-trim end-trim (subseq str (1+ pos)))))
	  (case preserve
	    (:begin (setq begin (concatenate 'string begin (list cut-char))))
	    (:end (setq end (concatenate 'string (list cut-char) end))))
	  (values begin end))
      str)))
  
(defun remove-string (substr str &key (replace-with ()) (start 0))
  "Remove substr from str. Replace substr with Replace-with"
  (let ((pos (search substr str :start2 start)))
    (if pos
	(remove-string substr
		       (concatenate 'string (subseq str 0 pos)
				    replace-with
				    (subseq str (+ pos (length substr))))
		       :replace-with replace-with
		       :start (+ pos (length replace-with)))
      str)))



(defun my-search (substr str)
  "Search substr in str.
   return T only if substr is followed by #\Space or #\{"
  (let ((pos (search substr str))
	(lsubstr (length substr))
	(lstr (length str)))
    (when (numberp pos)
      (when (>= pos (- lstr lsubstr))
	(return-from my-search t))
      (let ((n (aref str (+ pos (length substr)))))
	(when (or (eql n #\Space) (eql n #\{))
	  (when (= pos 0)
	    (return-from my-search t))
	  (when (eql (aref str (- pos 1)) #\Space)
	    t))))))
	

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                                                           ;;;
;;;  Various parser                                           ;;;
;;;                                                           ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun ignorable-line (line)
  (dolist (elm *ignore-lines*)
    (when (search elm line)
      (return-from ignorable-line t))))




(defun parse-value (value)
  (cond ((eql (search "0x" value) 0)
	 (remove-string "0x" value :replace-with "#x"))
	((eql (search "0X" value) 0)
	 (remove-string "0X" value :replace-with "#x"))
	(t value)))


(defun write-define (out accum)
  (when accum
    (implementation-write-original out 'define accum)
    (when (ignorable-line accum)
      (implementation-write-ignored out accum)
      (return-from write-define))
    (if (position #\( accum)
	(implementation-write-ignored out accum)
      (multiple-value-bind (base define)
	  (cut-string accum :initial-trim " " :begin-trim " " :end-trim " ")
	(cond ((string= "#define" base)
	       (multiple-value-bind (name value)
		   (cut-string define :begin-trim " " :end-trim " ")
		 (implementation-write-define out name (parse-value value))))
	      (t (implementation-write-ignored out accum)))))))


(defun write-comment (out accum)
  (when accum
    (implementation-write-original out 'comment accum)
    (when *write-comment*
      (implementation-write-comment out accum))))



;;; Code walker
(defun parse-var (var)
  (if (and (search "(" var)
	   (search "*" var))
      (multiple-value-bind (base arguments)
	  (cut-string var :cut-char #\( :from-end t :initial-trim " ;"
		      :begin-trim " (" :end-trim " )")
	(if (string= "void" arguments)
	    (setq arguments nil)
	  (setq arguments (mapcar #'(lambda (x)
				      (multiple-value-bind (type name)
					  (parse-var x)
					(list (if name
						  name
						(format nil "p~A" (gensym)))
					      type)))
				  (string-to-list arguments :split-char #\,
						  :initial-trim " "))))
	(multiple-value-bind (type name)
	    (cut-string base :cut-char #\( :from-end t
			:begin-trim " (" :end-trim " *)")
	  (values (list type arguments) name)))
    (multiple-value-bind (type name)
	(cut-string var :from-end t :initial-trim " ;"
		    :begin-trim " " :end-trim " ")
      (values type name))))



(defun analyze-enum (out accum)
  (when accum
    (multiple-value-bind (ignore base)
	(cut-string accum :cut-char #\{ :begin-trim " " :end-trim "; ")
      (declare (ignore ignore))
      (multiple-value-bind (elements name)
	  (cut-string base :cut-char #\} :begin-trim " " :end-trim " ")
	(setq elements (mapcar #'(lambda (x)
				   (let ((elm (string-to-list x :split-char #\= :trim " ")))
				     (when (second elm)
				       (setf (second elm) (parse-value (second elm))))
				     elm))
			       (string-to-list elements :split-char #\,
					       :initial-trim " ")))
	(implementation-write-enum out
				   (if (string= "" name) nil name)
				   elements)))))


(defun analyze-union (out accum)
  (when accum
    (multiple-value-bind (ignore base)
	(cut-string accum :cut-char #\{ :begin-trim " " :end-trim "; ")
      (declare (ignore ignore))
      (multiple-value-bind (elements name)
	  (cut-string base :cut-char #\} :begin-trim " " :end-trim " ")
	(setq elements (mapcar #'(lambda (x)
				   (multiple-value-bind (type name)
				       (cut-string x :from-end t :initial-trim " ;"
						   :begin-trim " " :end-trim " ")
				     (list name type)))
			       (string-to-list elements :split-char #\;
					       :initial-trim " ")))
	(implementation-write-union out name elements)))))



(defun analyze-typedef (out accum)
  (when accum
    (multiple-value-bind (type name)
	(parse-var (subseq accum 8))
      (if name
	  (implementation-write-typedef out name type)
	(implementation-write-typedef out type nil)))))





(defun analyze-struct (out accum)
  (when accum
    (if (position #\{ accum)
	(multiple-value-bind (struct-identifier base)
	    (cut-string accum :cut-char #\{ :begin-trim " " :end-trim "; ")
          (let ((id-name (string-trim
                          " "
                          (remove-string 
                           "typedef" 
                           (remove-string "struct" struct-identifier)))))
            (multiple-value-bind (elements name)
                (cut-string base :cut-char #\} :begin-trim " " :end-trim " ")	   
              (setq elements (mapcar #'(lambda (x)
                                         (multiple-value-bind (type name)
                                             (parse-var x)
                                           (list name type)))
                                     (string-to-list elements :split-char #\;
                                                     :initial-trim " ")))
              (implementation-write-struct out (if (zerop (length name)) id-name name)
                                           elements))))
          (multiple-value-bind (base name)
              (cut-string accum :from-end t :initial-trim "; " :end-trim " ")
            (let ((type (string-trim " "
                                     (remove-string "typedef"
                                                    (remove-string "struct" base)))))
              (if (or (string= type "") (string= name type))
                  (implementation-write-struct out name nil)
                (implementation-write-typedef out name type)))))))
	


 (defun analyze-function (out accum)
   (when accum
     (if (and (position #\, accum) (> (position #\; accum) (position #\, accum)))
	 (let ((prototypes (string-to-list accum 
					   :split-char #\,
					   :ignore-enter-char #\(
					   :ignore-leave-char #\))))
	   (analyze-function-single out (first prototypes))
	   (let ((type (cut-string (cut-string accum :cut-char #\( :begin-trim " "
					       :end-trim " ")
				   :cut-char #\space :begin-trim " " 
				   :end-trim " " :from-end t)))
	     (dolist (prototype (rest prototypes))
	       (analyze-function-single out (concatenate 'string type prototype)))))
	 (analyze-function-single out (string-trim ";" accum)))))


(defun analyze-function-single (out accum)
  (when accum
    (multiple-value-bind (base arguments)
	(cut-string accum :cut-char #\( :initial-trim " )"
		    :begin-trim " " :end-trim " ")
      (multiple-value-bind (type name)
	  (parse-var base)
	(setq arguments (string-to-list arguments :split-char #\,
					:initial-trim " ();"
					:ignore-enter-char #\(
					:ignore-leave-char #\)))
	(if (string= "void" (first arguments))
	    (setq arguments nil)
	  (setq arguments (mapcar #'(lambda (x)
				      (multiple-value-bind (type name)
					  (parse-var x)
					(list name type)))
				  arguments)))
	(if name
	    (implementation-write-function out name type arguments)
	  (implementation-write-ignored out accum))))))




(defun analyze-var (out accum)
  (when accum
    (multiple-value-bind (type name)
	(parse-var accum)
      (if name
	  (implementation-write-var out name type)
	(implementation-write-ignored out accum)))))




(defun write-code (out accum)
  (when accum
    (implementation-write-original out 'code accum)
    (when (ignorable-line accum)
      (implementation-write-ignored out accum)
      (return-from write-code))
    (setq accum (remove-string "*" accum :replace-with " * "))
    (cond ((my-search "enum" accum)
	   (analyze-enum out accum))
	  ((my-search "union" accum)
	   (analyze-union out accum))
	  ((my-search "struct" accum)
	   (analyze-struct out accum))
	  ((my-search "typedef" accum)
	   (analyze-typedef out accum))
	  ((position #\( accum)
	   (analyze-function out accum))
	  ((or (position #\{ accum)
	       (position #\( accum))
	   (implementation-write-ignored out accum))
	  (t (analyze-var out accum)))))



(defun clean-accum (accum)
  (let ((ret (string-trim " " (coerce (nreverse accum) 'string))))
    (dolist (key *ignored-keyword*)
      (if (atom key)
	  (setq ret (remove-string key ret))
	(setq ret (remove-string (first key) ret :replace-with (second key)))))
    (unless (string= ret "")
      ret)))




(defun do-parse (in out)
  (let ((last ())
	(accum ())
	(accum-comment ())
	(accum-define ())
	(comment nil)
	(group nil)
	(define nil))
    (do ((c (read-char in nil :eof) (read-char in nil :eof)))
	((eql c :eof) 'end)

      (case c
	(#\Newline
	 (cond (comment (push #\Space accum-comment))
	       (define (push #\Space accum-define))
	       (group (push #\Space accum))
	       (t (push #\Space accum)))
	 (unless comment
	   (when (and define (not (eql last #\\)))
	     (write-code out (clean-accum accum))
	     (setf accum nil)
	     (write-define out (clean-accum accum-define))
	     (setf accum-define nil)
	     (setf define nil)
	     (setf group nil))))
	
	(#\# (unless comment
	       (push c accum-define)
	       (setf define t)))
	
	(#\; (cond (comment (push c accum-comment))
		   (define (push c accum-define))
		   (group (push c accum))
		   (t (push c accum)))
	 (unless (or comment group)
	   (write-code out (clean-accum accum))
	   (setf accum nil)))
	
	(#\/ (push c accum-comment)
	 (when (eql last #\*)
	   (setf comment nil)
	   (write-comment out (clean-accum accum-comment))
	   (setf accum-comment nil)))
	
	(#\* (when (eql last #\/)
	       (setf comment t))
	 (cond (comment (push c accum-comment))
	       (define (push c accum-define))
	       (group (push c accum))
	       (t (push c accum))))

	(#\{ (cond (comment (push c accum-comment))
		   (t (push c accum)
		      (setf group t))))

	(#\} (cond (comment (push c accum-comment))
		   (t (push c accum)
		      (setf group nil))))

	((#\\ #\Tab) (cond (comment (push #\Space accum-comment))
			   (define (push #\Space accum-define))
			   (group (push #\Space accum))
			   (t (push #\Space accum))))

	(t (cond (comment (push c accum-comment))
		 (define (push c accum-define))
		 (group (push c accum))
		 (t (push c accum)))))

      (setf last c)))
  *exported-symbol*)



(defun parse-stream (in &key (out *standard-output*) (ignored-keyword ())
			(ignore-lines ())
			(library nil) (language nil)
			(write-comment t) (write-ignored t) (write-original nil)
			(package-name :test) (package-definition-type :new)
			(backend :clisp)
			(clisp-delimiter "#+CLISP") (uffi-delimiter "#-CLISP"))
  (setq *ignored-keyword* ignored-keyword
	*ignore-lines* ignore-lines
	*library* library
	*language* language
	*write-comment* write-comment
	*write-ignored* write-ignored
	*write-original* write-original
	*exported-symbol* nil
	*backend* backend
	*clisp-delimiter* clisp-delimiter
	*uffi-delimiter* uffi-delimiter)
  (when package-definition-type
    (do-parse in nil)
    (write-package-definition out package-name package-definition-type))
  (file-position in 0)
  (setq *exported-symbol* nil)
  (do-parse in out))




(defun parse-file (file-in &key (file-out *standard-output*) (ignored-keyword ())
			   (ignore-lines ())
			   (library nil) (language nil)
			   (write-comment t) (write-ignored t) (write-original nil)
			   (package-name :test) (package-definition-type :new)
			   (backend :clisp)
			   (clisp-delimiter "#+CLISP") (uffi-delimiter "#-CLISP"))
  (with-open-file
   (in file-in :direction :input)
   (if (eql file-out *standard-output*)
       (parse-stream in :ignored-keyword ignored-keyword
		     :ignore-lines ignore-lines
		     :library library :language language
		     :write-comment write-comment
		     :write-ignored write-ignored
		     :write-original write-original
		     :package-name package-name
		     :package-definition-type package-definition-type
		     :backend backend
		     :clisp-delimiter clisp-delimiter
		     :uffi-delimiter uffi-delimiter)
     (with-open-file
      (out file-out :direction :output :if-exists :supersede)
      (parse-stream in :out out :ignored-keyword ignored-keyword
		    :ignore-lines ignore-lines
		    :library library :language language
		    :write-comment write-comment
		    :write-ignored write-ignored
		    :write-original write-original
		    :package-name package-name
		    :package-definition-type package-definition-type
		    :backend backend
		    :clisp-delimiter clisp-delimiter
		    :uffi-delimiter uffi-delimiter)))))