#!/usr/local/bin/klone

(defun main ()
  (setq files (getopts "cextractk [options] files...
extract doc from c sources of klone func. With no files, filter."
      ("-v" () verbose "Verbose operation")
      ("-V" () Verbose "More verbose operation")
      ("-o" "dir" dir "Write generated files into the directory")
      ("-k" () klone-fct "Extract only wrapped klone functions")
      ("-c" () c-fct "Extract only c functions")
      ("-s" () static-fct "Extract only static functions")
      ("-a" () all-fct "Extract all functions")
      ("-d" () autodoc-klone "Extract wrapped klone functions for klone autodoc")
      ("-p" () print-debug "Print results on screen too for debugging")
  ))

  ;; Look at parameters
  (if Verbose (setq verbose t))
  (if all-fct 
      (progn
        (setq klone-fct t)
        (setq c-fct t)
        (setq static-fct t))
    )
  (if (file-stats dir)
      (if (/= (file-type dir) 'directory)
          (progn
            (print-format "%0 exists and is not a directory!!\n" dir)
            (exit 1))
        )
    (progn
      (print-format "%0 directory doesn't exist! Create it!!\n" dir)
      (!! "mkdir" dir))
    )
  (if autodoc-klone
      (if (or all-fct static-fct c-fct)
          (progn
            (print "Warning: You can't use -c,-s,-a or -k with the -d option\n")
            (print "         Unset all the other flags....\n")
            (setq klone-fct '())
            (setq c-fct '())
            (setq static-fct '())
            )))

  ;; For each file... extract documentation.
  (if files
      (dolist (file files)
              (print-format "---- Extracting doc from file : %0\n"  file)
              (setq fd-in (open file))
              ;; Rename output file only for autodoc generation
              (if autodoc-klone
                  (setq file (+ (match "(.+)\.c" file 1) ".kl")))

              (setq fd-out (open (+ dir "/" file )
                                 :direction :output :if-exists :supersede)
                    )
              (finddoc fd-in fd-out)
              )
    (finddoc *standard-input* *standard-output*)
    )    
)

(defun get-sub-string (buffer start-point start-car end-car &aux indice parite)
  (setq indice start-point)
;  (print-format "Start-Car : %0, End-Car : %1\n" (get start-car 0) (get end-car 0))
  (while (/= (get buffer indice) (get start-car 0))
    (incf indice))
  ;; We find first car => parite = 1 and indice=indice+1
  (setq parite 1)
  (incf indice)
  (while (/= parite 0)
    (while (and (/= (get buffer indice) (get end-car 0)) (/= (get buffer indice) (get start-car 0)))
      (incf indice))
    (if (= (get buffer indice) (get start-car 0))
        (incf parite)
      (incf parite -1))
    (incf indice)
;    (print-format "Parite : %0\n" parite)
    )
  (subseq buffer start-point (incf indice))
)
 

(defun finddoc (in out &aux
                   (ch-comment "(/\\*[^*]*\\*(([^/*][^*]*)?\\*)*/)")
                   (re-comment (regcomp ch-comment))
                   (re-decl-subr (regcomp "KlDeclareSubr[ ]*\\([ ]*([^,]*),[ ]*\"([^\"]*)\",[ ]*([0-9]+|NARY)[ ]*\\)[ ]*;"))
                   (word "([a-zA-Z][a-zA-Z0-9_]*)")
                   (re-proto-C (regcomp (+ "\n(" word "[^\n;]*)[\t\n\ ]*\n" word "[\t\ ]*(\\({{[^/]|{/[^*]}}|[^\)]}*" ch-comment "?)*\\)[\t\n\ ]*")))
                   (re-include (regcomp "#include[^\n]*\n"))
                   (re-struct (regcomp "\n[\t\n\ ]*((typedef|struct)[^\{\};]*\{[^\}]*\}[^;]*;)"))
                   (re-ifndef (regcomp "#ifndef(.+)#endif"))
                   (buffer (String in))                ;gobble buffer
                   (offset 0)
                   (decls (list))
                   (comments (list))
                   (proto-Cs (list))
                   (dieses (list))
                   (big-list (list)) ;type, static, name, proto, comment, lisp-assoc, already used 
                   point-match match-commw re-decl matched the-proto 
                   lisp-after fct-kl fct-ckl type static lisp-assoc fct-proto
)
  
  (setq *standard-output* out)
  (if print-debug
      (progn
        (print-format "\n####################################\n")
        (print-format "Begenning of analysis...\n")
        (print-format "####################################\n")
        ))
  ;; find all subr declared 
  (if print-debug
      (print-format " - Find all subr declared\n"))
  (while (regexec re-decl-subr buffer offset)
    (setq point-match (getn (getn re-decl-subr 0) 0))
    (setq matched (regsub re-decl-subr 0))
    (setq offset (+ point-match (length matched)))
    (lappend decls (list (regsub re-decl-subr 1)(regsub re-decl-subr 2)(regsub re-decl-subr 3))))
  ;; find all comments
  (if print-debug
      (print-format " - Find all comments\n"))
  (setq offset 0)
  (while (regexec re-comment buffer offset)
    (setq point-match (getn (getn re-comment 0) 0))
    (setq matched (regsub re-comment 0))
    (setq offset (+ point-match (length matched)))
    (lappend comments (list point-match (+ matched "\n")))) ;;; @@@
  ;; find all proto C
  (if print-debug
      (print-format " - Find all proto C\n"))
  (setq offset 0)
  (while (regexec re-proto-C buffer offset)
    (setq point-match (getn (getn re-proto-C 0) 0))
    (if print-debug
        (progn
          (print-format "\n%0----\n" point-match)
          (print-format "%0\n" (get-sub-string buffer point-match "(" ")" ))))
    (setq fct-proto (get-sub-string buffer point-match "(" ")" ))
    (setq matched (regsub re-proto-C 0))
    (setq name (regsub re-proto-C 3))
    (setq offset (+ point-match (length matched)))
    (lappend proto-Cs (list name fct-proto)))
;;  (print-format "\n####################################\n")
;;   find all #include
  (if print-debug
      (print-format " - Find all #include\n"))
  (setq offset 0)
  (while (regexec re-include buffer offset)
    (setq point-match (getn (getn re-include 0) 0))
    (setq matched (regsub re-include 0))
    (setq offset (+ point-match (length matched)))
    (lappend dieses (list matched)))
  ;; find all #define
  (if print-debug
      (print-format " - Find all #define\n"))
  (while (regexec re-struct buffer offset)
    (setq point-match (getn (getn re-struct 0) 0))
    (setq matched (regsub re-struct 0))
    (setq offset (+ point-match (length matched)))
    (lappend dieses (list matched)))

  (if print-debug
      (progn
        (print-format "Content of analysed file\n")
        (print-format "======== Decls =====\n")
        (print-format "%0\n" decls)
        (print-format "======== Comments =====\n")
        (print-format "%0\n" comments)  
        (print-format "======== Proto-C =====\n")
        (print-format "%0\n" proto-Cs)
        (print-format "\n####################################\n")
        (print-format ".......... End of analysis\n")
        (print-format "####################################\n")
        ))
  
;; type 1: Kl, 2: C-Kl, 3: C,
  (dolist (proto proto-Cs)
          (setq lisp-assoc ())
          ;; Define type of function : Kl, C-Kl, C
          (if (=  (match "(.+)Kl" (get proto 0)) (get proto 0))
              (progn
                ;; Test if it's a Kl function
                (setq re-fct-kl (regcomp (get proto 0)))
                (setq fct-kl ())
                (dolist (decl decls)
                        (if (regexec re-fct-kl (get decl 0))
                            (progn 
                              (setq fct-kl t)
                              (setq type 1)
;                              (print-format "%0 fct est une fct Kl\n" (get proto 0))
                              (setq lisp-assoc (get decl 1))
                              )
                        ))
                (if (not fct-kl)
                    (print-format *standard-error* "Warning: Function %0, not declared with a KlDeclareSubr\n" (get proto 0))
                          )
                )
            (progn
              ;; Test if it's a C-Kl function
              (setq re-fct-ckl (regcomp (+ (get proto 0) "Kl")))
              (setq fct-ckl ())
              (dolist (decl decls)
                      (if (regexec re-fct-ckl (get decl 0))
                          (progn
                            (setq fct-ckl t)
                            (setq type 2)
;                            (print-format "%0 fct est une fct C-Kl\n" (get proto 0))
                            )))
              (if (not fct-ckl)
                  ;; It's simply a C function
                  (progn
                    (setq type 3)
;                    (print-format "%0 est une fct C\n" (get proto 0))
                    ))
              )
            )
          ;; Define if it's a static function
          (setq static ())
          (if (match "static" (get proto 1))
              (progn
;                (print-format "%0 est une Fct Static\n" (get proto 0))
                (setq static 1)
                )
           )
          ;; Find comment of the function.
          (setq offset 0)
          (setq string-decl (+ "(^|\n)" (get proto 0) "[ ]*\\("))
          (setq re-decl (regcomp string-decl))
          (regexec re-decl buffer offset)
          (setq point-decl (getn (getn re-decl 0) 0))
          (if point-decl
              (dolist (comment comments)
                      (if (< (get comment 0) point-decl) (setq match-commw comment))))
;          (print-format "%0\n" (get match-commw 1))
;          (print-format "\n")
          (lappend big-list (list type static (get proto 0) (get proto 1) (get match-commw 1) lisp-assoc () ))
          )
;  (print-format "##################\n%0\n#############" big-list)

  ;; For the includes exeption for klone
  (if (not autodoc-klone)
      (progn
        (dolist (diese dieses)
                (print-format "%0" (get diese 0)))
        (print-format "\n")))
  
  (if klone-fct
      (extract-klone big-list))
  (if c-fct
      (extract-C big-list))
  (if static-fct
      (extract-static big-list))
  (if autodoc-klone
      (extract-autodoc big-list))

  (setq *standard-output* *standard-output-orig*) 
)

;; Extract Klone Functions with C associated ones.
(defun extract-klone (big-list &aux re-c-name find-?)
  (dolist (big big-list)
          (if (= (get big 0) 1)                        ;; type Kl
              (progn
                (setq re-c-name (regcomp (+ (match "(.+)Kl" (get big 2) 1) "[\t\n\ ]*\\("))) ;; Associated C function
                (setq find-? ())
                (dolist (big2 big-list)
                        (if (regexec re-c-name (get big2 3))
                            (progn
                              (print-format "%0" (get big2 4))
                              (print-format "/* Lisp: The associated lisp function is : %0\n */\n" (get big 5))
                              (print-format "%0%1{}\n\n" (get big 4) (get big2 3))
                              (setq find-? t)
                              (put big2 6 t)
                              )))
                ;; If no c function
                (if (not find-?)
                    (progn
                      (print-format "%0" (get big 4))
                      (print-format "/* Lisp: The associated lisp function is : %0\n */" (get big 5))
                      (print-format "%0{}\n\n" (get big 3)))) 
            )))
)

;; Extract C functions.
(defun extract-C (big-list)
  (dolist (big big-list)
          (if (or (= (get big 0) 2) (= (get big 0) 3)) ;; type = 2 ou 3
              (if (not (get big 6))                    ;; not used for C-Kl
                  (if (not (get big 1))                ;; not a static C fct
                      (progn
                        (print-format "%0%1{}\n\n" (get big 4) (get big 3))
                        (put big 6 t)))
            )))
)

;; Extract Static functions.
(defun extract-static (big-list)
  (dolist (big big-list)
          (if (= (get big 1) 1)                        ;; static = 1
              (if (not (get big 6))                    ;; not already used
                  (print-format "%0%1{}\n\n" (get big 4) (get big 3)))
            ))
)

(defun get-sub-comm (buffer start-point start-car end-car &aux indice parite real-st-pt)
  (setq indice start-point)
;  (print-format "Start-Car : %0, End-Car : %1\n" (get start-car 0) (get end-car 0))
  (while (/= (get buffer indice) (get start-car 0))
    (incf indice))
  (setq real-st-pt indice)
  ;; We find first car => parite = 1 and indice=indice+1
  (incf indice)
  (while (and (/= (get buffer indice) (get end-car 0)))
      (incf indice))
  (incf indice)
  (setq end__ indice)
  (subseq buffer (incf real-st-pt) (incf indice -1))
)


(defun extract-line-comm (buffer offset)
  (while (/= (setq com-line (get-sub-comm buffer offset "*" "\n")) "/")
    (print-format ";;%0\n" com-line)
    (setq offset end__))
)


;; Extract Klone Functions and generate .kl for AUTODOC
(defun extract-autodoc (big-list &aux com-line offset)
  (dolist (big big-list)
          (if (= (get big 0) 1)                        ;; type Kl
              (progn
                (print-format ";;AUTODOC: %0 \"" (get big 5))
                (setq re-c-name (regcomp (+ (match "(.+)Kl" (get big 2) 1) "[\t\n\ ]*\\("))) ;; Associated C function
                (setq find-? ())
                (dolist (big2 big-list)
                        (if (regexec re-c-name (get big2 3))
                            (progn
                              (setq com-line (get-sub-comm (get big2 4) 0 "*" "\n"))
                              (setq offset end__)
                              (print-format "%0\"\n" com-line)
                              (extract-line-comm (get big2 4) offset)
                              (setq offset 0)
                              (extract-line-comm (get big 4) offset)
                              (setq find-? t)
                              (put big2 6 t)
                              (print "\n")
                              )))
                ;; If no c function
                (if (not find-?)
                    (progn
                      (setq com-line (get-sub-comm (get big 4) 0 "*" "\n"))
                      (setq offset end__)
                      (print-format "%0\"\n" com-line)
                      (extract-line-comm (get big 4) offset)
;;                      (print-format "%0\n" (get big 4))
;                      (print-format "%0{}\n\n" (get big 3))
                      (print "\n")
                      )) 
            )))
)


(main)
